Mercurial > hg > xemacs-beta
annotate lisp/faces.el @ 4981:4aebb0131297
Cleanups/renaming of EXTERNAL_TO_C_STRING and friends
-------------------- ChangeLog entries follow: --------------------
modules/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* postgresql/postgresql.c:
* postgresql/postgresql.c (CHECK_LIVE_CONNECTION):
* postgresql/postgresql.c (Fpq_connectdb):
* postgresql/postgresql.c (Fpq_connect_start):
* postgresql/postgresql.c (Fpq_lo_import):
* postgresql/postgresql.c (Fpq_lo_export):
* ldap/eldap.c (Fldap_open):
* ldap/eldap.c (Fldap_search_basic):
* ldap/eldap.c (Fldap_add):
* ldap/eldap.c (Fldap_modify):
* ldap/eldap.c (Fldap_delete):
* canna/canna_api.c (Fcanna_initialize):
* canna/canna_api.c (Fcanna_store_yomi):
* canna/canna_api.c (Fcanna_parse):
* canna/canna_api.c (Fcanna_henkan_begin):
EXTERNAL_TO_C_STRING returns its argument instead of storing it
in a parameter, and is renamed to EXTERNAL_TO_ITEXT. Similar
things happen to related macros. See entry in src/ChangeLog.
More Mule-izing of postgresql.c. Extract out common code
between `pq-connectdb' and `pq-connect-start'. Fix places
that signal an error string using a formatted string to instead
follow the standard and have a fixed reason followed by the
particular error message stored as one of the frobs.
src/ChangeLog addition:
2010-02-05 Ben Wing <ben@xemacs.org>
* console-msw.c (write_string_to_mswindows_debugging_output):
* console-msw.c (Fmswindows_message_box):
* console-x.c (x_perhaps_init_unseen_key_defaults):
* console.c:
* database.c (dbm_get):
* database.c (dbm_put):
* database.c (dbm_remove):
* database.c (berkdb_get):
* database.c (berkdb_put):
* database.c (berkdb_remove):
* database.c (Fopen_database):
* device-gtk.c (gtk_init_device):
* device-msw.c (msprinter_init_device_internal):
* device-msw.c (msprinter_default_printer):
* device-msw.c (msprinter_init_device):
* device-msw.c (sync_printer_with_devmode):
* device-msw.c (Fmsprinter_select_settings):
* device-x.c (sanity_check_geometry_resource):
* device-x.c (Dynarr_add_validified_lisp_string):
* device-x.c (x_init_device):
* device-x.c (Fx_put_resource):
* device-x.c (Fx_valid_keysym_name_p):
* device-x.c (Fx_set_font_path):
* dialog-msw.c (push_lisp_string_as_unicode):
* dialog-msw.c (handle_directory_dialog_box):
* dialog-msw.c (handle_file_dialog_box):
* dialog-x.c (dbox_descriptor_to_widget_value):
* editfns.c (Fformat_time_string):
* editfns.c (Fencode_time):
* editfns.c (Fset_time_zone_rule):
* emacs.c (make_argc_argv):
* emacs.c (Fdump_emacs):
* emodules.c (emodules_load):
* eval.c:
* eval.c (maybe_signal_error_1):
* event-msw.c (Fdde_alloc_advise_item):
* event-msw.c (mswindows_dde_callback):
* event-msw.c (mswindows_wnd_proc):
* fileio.c (report_error_with_errno):
* fileio.c (Fsysnetunam):
* fileio.c (Fdo_auto_save):
* font-mgr.c (extract_fcapi_string):
* font-mgr.c (Ffc_config_app_font_add_file):
* font-mgr.c (Ffc_config_app_font_add_dir):
* font-mgr.c (Ffc_config_filename):
* frame-gtk.c (gtk_set_frame_text_value):
* frame-gtk.c (gtk_create_widgets):
* frame-msw.c (mswindows_init_frame_1):
* frame-msw.c (mswindows_set_title_from_ibyte):
* frame-msw.c (msprinter_init_frame_3):
* frame-x.c (x_set_frame_text_value):
* frame-x.c (x_set_frame_properties):
* frame-x.c (start_drag_internal_1):
* frame-x.c (x_cde_transfer_callback):
* frame-x.c (x_create_widgets):
* glyphs-eimage.c (my_jpeg_output_message):
* glyphs-eimage.c (jpeg_instantiate):
* glyphs-eimage.c (gif_instantiate):
* glyphs-eimage.c (png_instantiate):
* glyphs-eimage.c (tiff_instantiate):
* glyphs-gtk.c (xbm_instantiate_1):
* glyphs-gtk.c (gtk_xbm_instantiate):
* glyphs-gtk.c (gtk_xpm_instantiate):
* glyphs-gtk.c (gtk_xface_instantiate):
* glyphs-gtk.c (cursor_font_instantiate):
* glyphs-gtk.c (gtk_redisplay_widget):
* glyphs-gtk.c (gtk_widget_instantiate_1):
* glyphs-gtk.c (gtk_add_tab_item):
* glyphs-msw.c (mswindows_xpm_instantiate):
* glyphs-msw.c (bmp_instantiate):
* glyphs-msw.c (mswindows_resource_instantiate):
* glyphs-msw.c (xbm_instantiate_1):
* glyphs-msw.c (mswindows_xbm_instantiate):
* glyphs-msw.c (mswindows_xface_instantiate):
* glyphs-msw.c (mswindows_redisplay_widget):
* glyphs-msw.c (mswindows_widget_instantiate):
* glyphs-msw.c (add_tree_item):
* glyphs-msw.c (add_tab_item):
* glyphs-msw.c (mswindows_combo_box_instantiate):
* glyphs-msw.c (mswindows_widget_query_string_geometry):
* glyphs-x.c (x_locate_pixmap_file):
* glyphs-x.c (xbm_instantiate_1):
* glyphs-x.c (x_xbm_instantiate):
* glyphs-x.c (extract_xpm_color_names):
* glyphs-x.c (x_xpm_instantiate):
* glyphs-x.c (x_xface_instantiate):
* glyphs-x.c (autodetect_instantiate):
* glyphs-x.c (safe_XLoadFont):
* glyphs-x.c (cursor_font_instantiate):
* glyphs-x.c (x_redisplay_widget):
* glyphs-x.c (Fchange_subwindow_property):
* glyphs-x.c (x_widget_instantiate):
* glyphs-x.c (x_tab_control_redisplay):
* glyphs.c (pixmap_to_lisp_data):
* gui-x.c (menu_separator_style_and_to_external):
* gui-x.c (add_accel_and_to_external):
* gui-x.c (button_item_to_widget_value):
* hpplay.c (player_error_internal):
* hpplay.c (play_sound_file):
* hpplay.c (play_sound_data):
* intl.c (Fset_current_locale):
* lisp.h:
* menubar-gtk.c (gtk_xemacs_set_accel_keys):
* menubar-msw.c (populate_menu_add_item):
* menubar-msw.c (populate_or_checksum_helper):
* menubar-x.c (menu_item_descriptor_to_widget_value_1):
* nt.c (init_user_info):
* nt.c (get_long_basename):
* nt.c (nt_get_resource):
* nt.c (init_mswindows_environment):
* nt.c (get_cached_volume_information):
* nt.c (mswindows_readdir):
* nt.c (read_unc_volume):
* nt.c (mswindows_stat):
* nt.c (mswindows_getdcwd):
* nt.c (mswindows_executable_type):
* nt.c (Fmswindows_short_file_name):
* ntplay.c (nt_play_sound_file):
* objects-gtk.c:
* objects-gtk.c (gtk_valid_color_name_p):
* objects-gtk.c (gtk_initialize_font_instance):
* objects-gtk.c (gtk_font_list):
* objects-msw.c (font_enum_callback_2):
* objects-msw.c (parse_font_spec):
* objects-x.c (x_parse_nearest_color):
* objects-x.c (x_valid_color_name_p):
* objects-x.c (x_initialize_font_instance):
* objects-x.c (x_font_instance_truename):
* objects-x.c (x_font_list):
* objects-xlike-inc.c (XFUN):
* objects-xlike-inc.c (xft_find_charset_font):
* process-nt.c (mswindows_report_winsock_error):
* process-nt.c (nt_create_process):
* process-nt.c (get_internet_address):
* process-nt.c (nt_open_network_stream):
* process-unix.c:
* process-unix.c (allocate_pty):
* process-unix.c (get_internet_address):
* process-unix.c (unix_canonicalize_host_name):
* process-unix.c (unix_open_network_stream):
* realpath.c:
* select-common.h (lisp_data_to_selection_data):
* select-gtk.c (symbol_to_gtk_atom):
* select-gtk.c (atom_to_symbol):
* select-msw.c (symbol_to_ms_cf):
* select-msw.c (mswindows_register_selection_data_type):
* select-x.c (symbol_to_x_atom):
* select-x.c (x_atom_to_symbol):
* select-x.c (hack_motif_clipboard_selection):
* select-x.c (Fx_store_cutbuffer_internal):
* sound.c (Fplay_sound_file):
* sound.c (Fplay_sound):
* sound.h (sound_perror):
* sysdep.c:
* sysdep.c (qxe_allocating_getcwd):
* sysdep.c (qxe_execve):
* sysdep.c (copy_in_passwd):
* sysdep.c (qxe_getpwnam):
* sysdep.c (qxe_ctime):
* sysdll.c (dll_open):
* sysdll.c (dll_function):
* sysdll.c (dll_variable):
* sysdll.c (search_linked_libs):
* sysdll.c (dll_error):
* sysfile.h:
* sysfile.h (PATHNAME_CONVERT_OUT_TSTR):
* sysfile.h (PATHNAME_CONVERT_OUT_UTF_8):
* sysfile.h (PATHNAME_CONVERT_OUT):
* sysfile.h (LISP_PATHNAME_CONVERT_OUT):
* syswindows.h (ITEXT_TO_TSTR):
* syswindows.h (LOCAL_FILE_FORMAT_TO_TSTR):
* syswindows.h (TSTR_TO_LOCAL_FILE_FORMAT):
* syswindows.h (LOCAL_FILE_FORMAT_TO_INTERNAL_MSWIN):
* syswindows.h (LISP_LOCAL_FILE_FORMAT_MAYBE_URL_TO_TSTR):
* text.h:
* text.h (eicpy_ext_len):
* text.h (enum new_dfc_src_type):
* text.h (EXTERNAL_TO_ITEXT):
* text.h (GET_STRERROR):
* tooltalk.c (check_status):
* tooltalk.c (Fadd_tooltalk_message_arg):
* tooltalk.c (Fadd_tooltalk_pattern_attribute):
* tooltalk.c (Fadd_tooltalk_pattern_arg):
* win32.c (tstr_to_local_file_format):
* win32.c (mswindows_lisp_error_1):
* win32.c (mswindows_report_process_error):
* win32.c (Fmswindows_shell_execute):
* win32.c (mswindows_read_link_1):
Changes involving external/internal format conversion,
mostly code cleanup and renaming.
1. Eliminate the previous macros like LISP_STRING_TO_EXTERNAL
that stored its result in a parameter. The new version of
LISP_STRING_TO_EXTERNAL returns its result through the
return value, same as the previous NEW_LISP_STRING_TO_EXTERNAL.
Use the new-style macros throughout the code.
2. Rename C_STRING_TO_EXTERNAL and friends to ITEXT_TO_EXTERNAL,
in keeping with overall naming rationalization involving
Itext and related types.
Macros involved in previous two:
EXTERNAL_TO_C_STRING -> EXTERNAL_TO_ITEXT
EXTERNAL_TO_C_STRING_MALLOC -> EXTERNAL_TO_ITEXT_MALLOC
SIZED_EXTERNAL_TO_C_STRING -> SIZED_EXTERNAL_TO_ITEXT
SIZED_EXTERNAL_TO_C_STRING_MALLOC -> SIZED_EXTERNAL_TO_ITEXT_MALLOC
C_STRING_TO_EXTERNAL -> ITEXT_TO_EXTERNAL
C_STRING_TO_EXTERNAL_MALLOC -> ITEXT_TO_EXTERNAL_MALLOC
LISP_STRING_TO_EXTERNAL
LISP_STRING_TO_EXTERNAL_MALLOC
LISP_STRING_TO_TSTR
C_STRING_TO_TSTR -> ITEXT_TO_TSTR
TSTR_TO_C_STRING -> TSTR_TO_ITEXT
The following four still return their values through parameters,
since they have more than one value to return:
C_STRING_TO_SIZED_EXTERNAL -> ITEXT_TO_SIZED_EXTERNAL
LISP_STRING_TO_SIZED_EXTERNAL
C_STRING_TO_SIZED_EXTERNAL_MALLOC -> ITEXT_TO_SIZED_EXTERNAL_MALLOC
LISP_STRING_TO_SIZED_EXTERNAL_MALLOC
Sometimes additional casts had to be inserted, since the old
macros played strange games and completely defeated the type system
of the store params.
3. Rewrite many places where direct calls to TO_EXTERNAL_FORMAT
occurred with calls to one of the convenience macros listed above,
or to make_extstring().
4. Eliminate SIZED_C_STRING macros (they were hardly used, anyway)
and use a direct call to TO_EXTERNAL_FORMAT or TO_INTERNAL_FORMAT.
4. Use LISP_PATHNAME_CONVERT_OUT in many places instead of something
like LISP_STRING_TO_EXTERNAL(..., Qfile_name).
5. Eliminate some temporary variables that are no longer necessary
now that we return a value rather than storing it into a variable.
6. Some Mule-izing in database.c.
7. Error functions:
-- A bit of code cleanup in maybe_signal_error_1.
-- Eliminate report_file_type_error; it's just an alias for
signal_error_2 with params in a different order.
-- Fix some places in the hostname-handling code that directly
inserted externally-retrieved error strings into the
supposed ASCII "reason" param instead of doing the right thing
and sticking text descriptive of what was going on in "reason"
and putting the external message in a frob.
8. Use Ascbyte instead of CIbyte in process-unix.c and maybe one
or two other places.
9. Some code cleanup in copy_in_passwd() in sysdep.c.
10. Fix a real bug due to accidental variable shadowing in
tstr_to_local_file_format() in win32.c.
| author | Ben Wing <ben@xemacs.org> |
|---|---|
| date | Fri, 05 Feb 2010 11:02:24 -0600 |
| parents | e29fcfd8df5f |
| children | 5502045ec510 |
| rev | line source |
|---|---|
| 428 | 1 ;;; faces.el --- Lisp interface to the C "face" structure |
| 2 | |
| 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. | |
| 4 ;; Copyright (C) 1995 Board of Trustees, University of Illinois | |
| 3027 | 5 ;; Copyright (C) 1995, 1996, 2002, 2005 Ben Wing |
| 428 | 6 |
| 7 ;; Author: Ben Wing <ben@xemacs.org> | |
| 8 ;; Keywords: faces, internal, dumped | |
| 9 | |
| 10 ;; This file is part of XEmacs. | |
| 11 | |
| 12 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 13 ;; under the terms of the GNU General Public License as published by | |
| 14 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 15 ;; any later version. | |
| 16 | |
| 17 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 20 ;; General Public License for more details. | |
| 21 | |
| 22 ;; You should have received a copy of the GNU General Public License | |
| 23 ;; along with XEmacs; see the file COPYING. If not, write to the | |
| 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Synched up with: Not synched with FSF. Almost completely divergent. | |
| 28 | |
| 29 ;;; Commentary: | |
| 30 | |
| 31 ;; This file is dumped with XEmacs. | |
| 32 | |
| 33 ;; face implementation #1 (used Lisp vectors and parallel C vectors; | |
| 34 ;; FSFmacs still uses this) authored by Jamie Zawinski <jwz@jwz.org> | |
| 35 ;; pre Lucid-Emacs 19.0. | |
| 36 | |
| 37 ;; face implementation #2 (used one face object per frame per face) | |
| 38 ;; authored by Jamie Zawinski for 19.9. | |
| 39 | |
| 40 ;; face implementation #3 (use one face object per face) originally | |
| 41 ;; authored for 19.12 by Chuck Thompson <cthomp@cs.uiuc.edu>, | |
| 42 ;; rewritten by Ben Wing with the advent of specifiers. | |
| 43 | |
| 44 | |
| 45 ;;; Some stuff in FSF's faces.el is in our x-faces.el. | |
| 46 | |
| 47 ;;; Code: | |
| 48 | |
| 771 | 49 ;; To elude the warnings for font functions. (Normally autoloaded when |
| 50 ;; font-create-object is called) | |
| 51 (eval-when-compile | |
| 3094 | 52 (require 'font) |
| 53 (load "cl-macs")) | |
| 771 | 54 |
| 428 | 55 (defgroup faces nil |
| 56 "Support for multiple text attributes (fonts, colors, ...) | |
| 57 Such a collection of attributes is called a \"face\"." | |
| 58 :group 'emacs) | |
| 59 | |
| 60 | |
| 61 (defun read-face-name (prompt) | |
| 62 (let (face) | |
| 63 (while (= (length face) 0) ; nil or "" | |
| 64 (setq face (completing-read prompt | |
| 65 (mapcar (lambda (x) (list (symbol-name x))) | |
| 66 (face-list)) | |
| 67 nil t))) | |
| 68 (intern face))) | |
| 69 | |
| 70 (defun face-interactive (what &optional bool) | |
| 71 (let* ((fn (intern (concat "face-" what "-instance"))) | |
| 72 (face (read-face-name (format "Set %s of face: " what))) | |
| 73 (default (if (fboundp fn) | |
| 74 ;; #### we should distinguish here between | |
| 75 ;; explicitly setting the value to be the | |
| 76 ;; same as the default face's value, and | |
| 77 ;; not setting a value at all. | |
| 78 (funcall fn face))) | |
| 79 (value (if bool | |
| 80 (y-or-n-p (format "Should face %s be %s? " | |
| 81 (symbol-name face) bool)) | |
| 82 (read-string (format "Set %s of face %s to: " | |
| 83 what (symbol-name face)) | |
| 84 (cond ((font-instance-p default) | |
| 85 (font-instance-name default)) | |
| 86 ((color-instance-p default) | |
| 87 (color-instance-name default)) | |
| 88 ((image-instance-p default) | |
| 89 (image-instance-file-name default)) | |
| 90 (t default)))))) | |
| 91 (list face (if (equal value "") nil value)))) | |
| 92 | |
| 93 (defconst built-in-face-specifiers | |
| 94 (built-in-face-specifiers) | |
| 95 "A list of the built-in face properties that are specifiers.") | |
| 96 | |
| 97 (defun face-property (face property &optional locale tag-set exact-p) | |
| 98 "Return FACE's value of the given PROPERTY. | |
| 99 | |
| 3027 | 100 NOTE: If you are looking for the \"value\" of a built-in face property |
| 101 (`foreground', `background', `font', `background-pixmap', etc.), you | |
| 102 are probably better off calling `face-property-instance'. The return | |
| 103 value of `face-property' for built-in properties describes the original | |
| 104 specification used to determine the face property, which may be nil, | |
| 105 a list of instantiators, or something else that is unexpected. For | |
| 106 example, if you ask for a face property in a particular buffer (by | |
| 107 specifying a buffer for LOCALE), you will get a non-nil return value | |
| 108 only if a buffer-local specification for that particular buffer had | |
| 109 previously been given. | |
| 110 | |
| 111 For a full list of built-in property names and their semantics, see | |
| 112 `set-face-property'. | |
| 428 | 113 |
| 3027 | 114 If LOCALE is omitted, the FACE's actual value for PROPERTY will be |
| 115 returned. In this case, this function appears to behave rather | |
| 116 differently depending on whether PROPERTY is a built-in face property of | |
| 117 a user-defined face property. This is because the most basic value of a | |
| 118 user-defined property is simply whatever was set using | |
| 119 `set-face-property', but for a built-in property it's always a specifier, | |
| 120 which is an abstract object encapsulating all the specifications for that | |
| 121 particular property. | |
| 122 | |
| 123 LOCALE, if supplied, will generally be a buffer, frame or | |
| 124 `global' (for the global value), but there are other possibilities -- see | |
| 125 the following paragraph. This mostly applies to built-in properties. In | |
| 126 this case, the return value will not be a specifier object but the | |
| 127 specification(s) for the given locale or locale type will be returned | |
| 128 (equivalent to calling `specifier-specs' on the specifier). | |
| 129 (Technically, the same thing happens if the basic value of a user- | |
| 130 defined property is a specifier, although this usage is rare.) | |
| 428 | 131 |
| 132 The return value will be a list of instantiators (e.g. strings | |
| 133 specifying a font or color name), or a list of specifications, each | |
| 134 of which is a cons of a locale and a list of instantiators. | |
| 135 Specifically, if LOCALE is a particular locale (a buffer, window, | |
| 3027 | 136 frame, device, or `global'), a list of instantiators for that locale |
| 428 | 137 will be returned. Otherwise, if LOCALE is a locale type (one of |
| 3027 | 138 the symbols `buffer', `window', `frame', or `device'), the specifications |
| 428 | 139 for all locales of that type will be returned. Finally, if LOCALE is |
| 3027 | 140 `all', the specifications for all locales of all types will be returned. |
| 428 | 141 |
| 142 The specifications in a specifier determine what the value of | |
| 143 PROPERTY will be in a particular \"domain\" or set of circumstances, | |
| 3027 | 144 which is typically a particular Emacs window -- which in turn defines |
| 145 a buffer (the buffer in the window), a frame (the frame that the window | |
| 146 is in), and a device (the device that the frame is in). The value is | |
| 442 | 147 derived from the instantiator associated with the most specific |
| 3027 | 148 locale (in the order buffer, window, frame, device, and `global') |
| 428 | 149 that matches the domain in question. In other words, given a domain |
| 442 | 150 (i.e. an Emacs window, usually), the specifier for PROPERTY will |
| 151 first be searched for a specification whose locale is the buffer | |
| 152 contained within that window; then for a specification whose locale | |
| 153 is the window itself; then for a specification whose locale is the | |
| 154 frame that the window is contained within; etc. The first | |
| 155 instantiator that is valid for the domain (usually this means that | |
| 156 the instantiator is recognized by the device [i.e. MS Windows, the X | |
| 3027 | 157 server or TTY device]) will be \"instantiated\", which generates |
| 158 a Lisp object encapsulating the original instantiator and the underlying | |
| 159 window-system object describing the property. The function | |
| 160 `face-property-instance' actually does all this." | |
| 428 | 161 |
| 162 (setq face (get-face face)) | |
| 163 (let ((value (get face property))) | |
| 164 (if (and locale | |
| 165 (or (memq property built-in-face-specifiers) | |
| 166 (specifierp value))) | |
| 167 (setq value (specifier-specs value locale tag-set exact-p))) | |
| 168 value)) | |
| 169 | |
| 170 (defun convert-face-property-into-specifier (face property) | |
| 171 "Convert PROPERTY on FACE into a specifier, if it's not already." | |
| 172 (setq face (get-face face)) | |
| 173 (let ((specifier (get face property))) | |
| 174 ;; if a user-property does not have a specifier but a | |
| 175 ;; locale was specified, put a specifier there. | |
| 176 ;; If there was already a value there, convert it to a | |
| 3027 | 177 ;; specifier with the value as its `global' instantiator. |
| 428 | 178 (unless (specifierp specifier) |
| 179 (let ((new-specifier (make-specifier 'generic))) | |
| 180 (if (or (not (null specifier)) | |
| 181 ;; make sure the nil returned from `get' wasn't | |
| 182 ;; actually the value of the property | |
| 183 (null (get face property t))) | |
| 184 (add-spec-to-specifier new-specifier specifier)) | |
| 185 (setq specifier new-specifier) | |
| 186 (put face property specifier))))) | |
| 187 | |
| 188 (defun face-property-instance (face property | |
| 872 | 189 &optional domain default no-fallback) |
| 428 | 190 "Return the instance of FACE's PROPERTY in the specified DOMAIN. |
| 191 | |
| 192 Under most circumstances, DOMAIN will be a particular window, | |
| 193 and the returned instance describes how the specified property | |
| 194 actually is displayed for that window and the particular buffer | |
| 195 in it. Note that this may not be the same as how the property | |
| 196 appears when the buffer is displayed in a different window or | |
| 197 frame, or how the property appears in the same window if you | |
| 198 switch to another buffer in that window; and in those cases, | |
| 199 the returned instance would be different. | |
| 200 | |
| 201 The returned instance will typically be a color-instance, | |
| 3027 | 202 font-instance, or image-instance object, and you can query |
| 428 | 203 it using the appropriate object-specific functions. For example, |
| 204 you could use `color-instance-rgb-components' to find out the | |
| 3027 | 205 RGB (red, green, and blue) components of how the `background' |
| 206 property of the `highlight' face is displayed in a particular | |
| 428 | 207 window. The results might be different from the results |
| 208 you would get for another window (perhaps the user | |
| 209 specified a different color for the frame that window is on; | |
| 210 or perhaps the same color was specified but the window is | |
| 211 on a different X server, and that X server has different RGB | |
| 212 values for the color from this one). | |
| 213 | |
| 214 DOMAIN defaults to the selected window if omitted. | |
| 215 | |
| 216 DOMAIN can be a frame or device, instead of a window. The value | |
| 217 returned for a such a domain is used in special circumstances | |
| 218 when a more specific domain does not apply; for example, a frame | |
| 219 value might be used for coloring a toolbar, which is conceptually | |
| 220 attached to a frame rather than a particular window. The value | |
| 221 is also useful in determining what the value would be for a | |
| 222 particular window within the frame or device, if it is not | |
| 223 overridden by a more specific specification. | |
| 224 | |
| 225 If PROPERTY does not name a built-in property, its value will | |
| 226 simply be returned unless it is a specifier object, in which case | |
| 227 it will be instanced using `specifier-instance'. | |
| 228 | |
| 229 Optional arguments DEFAULT and NO-FALLBACK are the same as in | |
| 230 `specifier-instance'." | |
| 231 | |
| 232 (setq face (get-face face)) | |
| 233 (let ((value (get face property))) | |
| 234 (if (specifierp value) | |
| 235 (setq value (specifier-instance value domain default no-fallback))) | |
| 236 value)) | |
| 237 | |
| 238 (defun face-property-matching-instance (face property matchspec | |
| 872 | 239 &optional domain default |
| 240 no-fallback) | |
| 428 | 241 "Return the instance of FACE's PROPERTY matching MATCHSPEC in DOMAIN. |
| 242 Currently the only useful value for MATCHSPEC is a charset, when used | |
| 243 in conjunction with the face's font; this allows you to retrieve a | |
| 244 font that can be used to display a particular charset, rather than just | |
| 245 any font. | |
| 246 | |
| 247 Other than MATCHSPEC, this function is identical to `face-property-instance'. | |
| 248 See also `specifier-matching-instance' for a fuller description of the | |
| 249 matching process." | |
| 250 | |
| 251 (setq face (get-face face)) | |
| 252 (let ((value (get face property))) | |
| 3659 | 253 (when (specifierp value) |
| 254 (setq value (specifier-matching-instance value matchspec domain | |
| 255 default no-fallback))) | |
| 428 | 256 value)) |
| 257 | |
| 258 (defun set-face-property (face property value &optional locale tag-set | |
| 872 | 259 how-to-add) |
| 428 | 260 "Change a property of FACE. |
| 261 | |
| 262 NOTE: If you want to remove a property from a face, use `remove-face-property' | |
| 263 rather than attempting to set a value of nil for the property. | |
| 264 | |
| 265 For built-in properties, the actual value of the property is a | |
| 266 specifier and you cannot change this; but you can change the | |
| 267 specifications within the specifier, and that is what this function | |
| 268 will do. For user-defined properties, you can use this function | |
| 269 to either change the actual value of the property or, if this value | |
| 270 is a specifier, change the specifications within it. | |
| 271 | |
| 272 If PROPERTY is a built-in property, the specifications to be added to | |
| 273 this property can be supplied in many different ways: | |
| 274 | |
| 275 -- If VALUE is a simple instantiator (e.g. a string naming a font or | |
| 276 color) or a list of instantiators, then the instantiator(s) will | |
| 277 be added as a specification of the property for the given LOCALE | |
| 3027 | 278 (which defaults to `global' if omitted). |
| 428 | 279 -- If VALUE is a list of specifications (each of which is a cons of |
| 280 a locale and a list of instantiators), then LOCALE must be nil | |
| 281 (it does not make sense to explicitly specify a locale in this | |
| 282 case), and specifications will be added as given. | |
| 283 -- If VALUE is a specifier (as would be returned by `face-property' | |
| 284 if no LOCALE argument is given), then some or all of the | |
| 285 specifications in the specifier will be added to the property. | |
| 286 In this case, the function is really equivalent to | |
| 287 `copy-specifier' and LOCALE has the same semantics (if it is | |
| 288 a particular locale, the specification for the locale will be | |
| 289 copied; if a locale type, specifications for all locales of | |
| 3027 | 290 that type will be copied; if nil or `all', then all |
| 428 | 291 specifications will be copied). |
| 292 | |
| 3027 | 293 HOW-TO-ADD should be either nil or one of the symbols `prepend', |
| 294 `append', `remove-tag-set-prepend', `remove-tag-set-append', `remove-locale', | |
| 295 `remove-locale-type', or `remove-all'. See `copy-specifier' and | |
| 428 | 296 `add-spec-to-specifier' for a description of what each of |
| 297 these means. Most of the time, you do not need to worry about | |
| 298 this argument; the default behavior usually is fine. | |
| 299 | |
| 300 In general, it is OK to pass an instance object (e.g. as returned | |
| 301 by `face-property-instance') as an instantiator in place of | |
| 302 an actual instantiator. In such a case, the instantiator used | |
| 303 to create that instance object will be used (for example, if | |
| 3027 | 304 you set a font-instance object as the value of the `font' |
| 428 | 305 property, then the font name used to create that object will |
| 306 be used instead). If some cases, however, doing this | |
| 307 conversion does not make sense, and this will be noted in | |
| 308 the documentation for particular types of instance objects. | |
| 309 | |
| 310 If PROPERTY is not a built-in property, then this function will | |
| 311 simply set its value if LOCALE is nil. However, if LOCALE is | |
| 312 given, then this function will attempt to add VALUE as the | |
| 313 instantiator for the given LOCALE, using `add-spec-to-specifier'. | |
| 314 If the value of the property is not a specifier, it will | |
| 3027 | 315 automatically be converted into a `generic' specifier. |
| 428 | 316 |
| 317 | |
| 318 The following symbols have predefined meanings: | |
| 319 | |
| 320 foreground The foreground color of the face. | |
| 442 | 321 For valid instantiators, see `make-color-specifier'. |
| 428 | 322 |
| 323 background The background color of the face. | |
| 442 | 324 For valid instantiators, see `make-color-specifier'. |
| 428 | 325 |
| 326 font The font used to display text covered by this face. | |
| 442 | 327 For valid instantiators, see `make-font-specifier'. |
| 428 | 328 |
| 329 display-table The display table of the face. | |
| 330 This should be a vector of 256 elements. | |
| 331 | |
| 332 background-pixmap The pixmap displayed in the background of the face. | |
| 442 | 333 Only used by faces on X and MS Windows devices. |
| 334 For valid instantiators, see `make-image-specifier'. | |
| 428 | 335 |
| 336 underline Underline all text covered by this face. | |
| 442 | 337 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 338 |
| 339 strikethru Draw a line through all text covered by this face. | |
| 442 | 340 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 341 |
| 342 highlight Highlight all text covered by this face. | |
| 343 Only used by faces on TTY devices. | |
| 442 | 344 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 345 |
| 346 dim Dim all text covered by this face. | |
| 442 | 347 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 348 |
| 349 blinking Blink all text covered by this face. | |
| 350 Only used by faces on TTY devices. | |
| 442 | 351 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 352 |
| 353 reverse Reverse the foreground and background colors. | |
| 354 Only used by faces on TTY devices. | |
| 442 | 355 For valid instantiators, see `make-face-boolean-specifier'. |
| 428 | 356 |
| 3027 | 357 inherit Face name or face object from which to inherit attributes, |
| 358 or a list of such elements. Attributes from inherited | |
| 359 faces are merged into the face like an underlying face | |
| 360 would be, with higher priority than underlying faces. | |
| 361 | |
| 428 | 362 doc-string Description of what the face's normal use is. |
| 363 NOTE: This is not a specifier, unlike all | |
| 364 the other built-in properties, and cannot | |
| 365 contain locale-specific values." | |
| 366 | |
| 367 (setq face (get-face face)) | |
| 368 (if (memq property built-in-face-specifiers) | |
| 369 (set-specifier (get face property) value locale tag-set how-to-add) | |
| 370 | |
| 371 ;; This section adds user defined properties. | |
| 372 (if (not locale) | |
| 373 (put face property value) | |
| 374 (convert-face-property-into-specifier face property) | |
| 375 (add-spec-to-specifier (get face property) value locale tag-set | |
| 376 how-to-add))) | |
| 377 value) | |
| 378 | |
| 379 (defun remove-face-property (face property &optional locale tag-set exact-p) | |
| 380 "Remove a property from FACE. | |
| 381 For built-in properties, this is analogous to `remove-specifier'. | |
| 382 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P | |
| 383 arguments." | |
| 384 (or locale (setq locale 'all)) | |
| 385 (if (memq property built-in-face-specifiers) | |
| 386 (remove-specifier (face-property face property) locale tag-set exact-p) | |
| 387 (if (eq locale 'all) | |
| 388 (remprop (get-face face) property) | |
| 389 (convert-face-property-into-specifier face property) | |
| 390 (remove-specifier (face-property face property) locale tag-set | |
| 391 exact-p)))) | |
| 392 | |
| 393 (defun reset-face (face &optional locale tag-set exact-p) | |
| 394 "Clear all existing built-in specifications from FACE. | |
| 3027 | 395 This makes FACE inherit all its display properties from `default'. |
| 428 | 396 WARNING: Be absolutely sure you want to do this!!! It is a dangerous |
| 397 operation and is not undoable. | |
| 398 | |
| 399 The arguments LOCALE, TAG-SET and EXACT-P are the same as for | |
| 400 `remove-specifier'." | |
| 3918 | 401 ;; Don't reset the default face. |
| 402 (unless (eq 'default face) | |
| 403 (dolist (x built-in-face-specifiers nil) | |
| 404 (remove-specifier (face-property face x) locale tag-set exact-p)))) | |
| 428 | 405 |
| 406 (defun set-face-parent (face parent &optional locale tag-set how-to-add) | |
| 407 "Set the parent of FACE to PARENT, for all properties. | |
| 408 This makes all properties of FACE inherit from PARENT." | |
| 409 (setq parent (get-face parent)) | |
|
4783
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
410 (mapc (lambda (x) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
411 (set-face-property face x (vector parent) locale tag-set |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
412 how-to-add)) |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
413 (set-difference built-in-face-specifiers |
|
e29fcfd8df5f
Eliminate most core code byte-compile warnings.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4764
diff
changeset
|
414 '(display-table background-pixmap inherit))) |
| 428 | 415 (set-face-background-pixmap face (vector 'inherit ':face parent) |
| 416 locale tag-set how-to-add) | |
| 417 nil) | |
| 418 | |
| 419 (defun face-doc-string (face) | |
| 420 "Return the documentation string for FACE." | |
| 421 (face-property face 'doc-string)) | |
| 422 | |
| 423 (defun set-face-doc-string (face doc-string) | |
| 424 "Change the documentation string of FACE to DOC-STRING." | |
| 425 (interactive (face-interactive "doc-string")) | |
| 426 (set-face-property face 'doc-string doc-string)) | |
| 427 | |
| 428 (defun face-font-name (face &optional domain charset) | |
| 429 "Return the font name of FACE in DOMAIN, or nil if it is unspecified. | |
| 3027 | 430 DOMAIN is as in `face-font-instance'. |
| 431 | |
| 432 Font names are strings, as described in `make-font-specifier'." | |
| 428 | 433 (let ((f (face-font-instance face domain charset))) |
| 434 (and f (font-instance-name f)))) | |
| 435 | |
| 436 (defun face-font (face &optional locale tag-set exact-p) | |
| 3027 | 437 "Return the font spec of FACE in LOCALE, or nil if it is unspecified. |
| 438 | |
| 439 NOTE: This returns a locale-specific specification, not any sort of value | |
| 440 corresponding to the actual font being used. If you want to know the | |
| 441 actual font used in a particular domain, use `face-font-instance', or | |
| 442 `face-font-name' for its name (i.e. the instantiator used to create it). | |
| 428 | 443 |
| 444 FACE may be either a face object or a symbol representing a face. | |
| 445 | |
| 446 LOCALE may be a locale (the instantiators for that particular locale | |
| 447 will be returned), a locale type (the specifications for all locales | |
| 3027 | 448 of that type will be returned), `all' (all specifications will be |
| 428 | 449 returned), or nil (the actual specifier object will be returned). |
| 450 | |
| 451 See `face-property' for more information." | |
| 452 (face-property face 'font locale tag-set exact-p)) | |
| 453 | |
| 454 (defun face-font-instance (face &optional domain charset) | |
| 455 "Return the instance of FACE's font in DOMAIN. | |
| 456 | |
| 3027 | 457 Return value will be a font instance object; query its properties using |
| 458 `font-instance-name', `font-instance-height', `font-instance-width', etc. | |
| 459 | |
| 428 | 460 FACE may be either a face object or a symbol representing a face. |
| 461 | |
| 462 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 463 and an instance object describing how the font appears in that | |
| 464 particular window and buffer will be returned. | |
| 465 | |
| 3659 | 466 CHARSET is a Mule charset (meaning return the font used for that charset) or |
| 467 nil (meaning return the font used for ASCII.) | |
| 468 | |
| 428 | 469 See `face-property-instance' for more information." |
| 3659 | 470 (if (null charset) |
| 471 (face-property-instance face 'font domain) | |
| 472 (let (matchspec) | |
| 473 ;; get-charset signals an error if its argument doesn't have an | |
| 474 ;; associated charset. | |
| 4222 | 475 (setq charset (if-fboundp #'get-charset |
| 476 (get-charset charset) | |
| 477 (error 'unimplemented "Charset support not available")) | |
| 3659 | 478 matchspec (cons charset nil)) |
| 479 (or (null (setcdr matchspec 'initial)) | |
| 480 (face-property-matching-instance | |
| 481 face 'font matchspec domain) | |
| 482 (null (setcdr matchspec 'final)) | |
| 483 (face-property-matching-instance | |
| 484 face 'font matchspec domain))))) | |
| 428 | 485 |
| 486 (defun set-face-font (face font &optional locale tag-set how-to-add) | |
| 487 "Change the font of FACE to FONT in LOCALE. | |
| 488 | |
| 489 FACE may be either a face object or a symbol representing a face. | |
| 490 | |
| 3659 | 491 FONT should be an instantiator (see `make-font-specifier'; a common |
| 492 instantiator is a platform-dependent string naming the font), a list | |
| 493 of instantiators, an alist of specifications (each mapping a locale | |
| 494 to an instantiator list), or a font specifier object. | |
| 428 | 495 |
| 3659 | 496 If FONT is an alist, LOCALE must be omitted. If FONT is a specifier |
| 497 object, LOCALE can be a locale, a locale type, `all', or nil; see | |
| 498 `copy-specifier' for its semantics. Common LOCALEs are buffer | |
| 499 objects, window objects, device objects and `global'. Otherwise | |
| 500 LOCALE specifies the locale under which the specified | |
| 501 instantiator(s) will be added, and defaults to `global'. | |
| 428 | 502 |
| 503 See `set-face-property' for more information." | |
| 504 (interactive (face-interactive "font")) | |
| 505 (set-face-property face 'font font locale tag-set how-to-add)) | |
| 506 | |
| 507 (defun face-foreground (face &optional locale tag-set exact-p) | |
| 3027 | 508 "Return the foreground spec of FACE in LOCALE, or nil if it is unspecified. |
| 509 | |
| 510 NOTE: This returns a locale-specific specification, not any sort of value | |
| 511 corresponding to the actual foreground being used. If you want to know the | |
| 512 actual foreground color used in a particular domain, use | |
| 513 `face-foreground-instance', or `face-foreground-name' for its name | |
| 514 \(i.e. the instantiator used to create it). | |
| 428 | 515 |
| 516 FACE may be either a face object or a symbol representing a face. | |
| 517 | |
| 518 LOCALE may be a locale (the instantiators for that particular locale | |
| 519 will be returned), a locale type (the specifications for all locales | |
| 3027 | 520 of that type will be returned), `all' (all specifications will be |
| 428 | 521 returned), or nil (the actual specifier object will be returned). |
| 522 | |
| 523 See `face-property' for more information." | |
| 524 (face-property face 'foreground locale tag-set exact-p)) | |
| 525 | |
| 526 (defun face-foreground-instance (face &optional domain default no-fallback) | |
| 527 "Return the instance of FACE's foreground in DOMAIN. | |
| 528 | |
| 3027 | 529 Return value will be a color instance object; query its properties using |
| 530 `color-instance-name' or `color-instance-rgb-properties'. | |
| 531 | |
| 428 | 532 FACE may be either a face object or a symbol representing a face. |
| 533 | |
| 534 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 535 and an instance object describing how the foreground appears in that | |
| 536 particular window and buffer will be returned. | |
| 537 | |
| 538 See `face-property-instance' for more information." | |
| 539 (face-property-instance face 'foreground domain default no-fallback)) | |
| 540 | |
| 541 (defun face-foreground-name (face &optional domain default no-fallback) | |
| 542 "Return the name of FACE's foreground color in DOMAIN. | |
| 543 | |
| 544 FACE may be either a face object or a symbol representing a face. | |
| 545 | |
| 546 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 547 and an instance object describing how the background appears in that | |
| 548 particular window and buffer will be returned. | |
| 549 | |
| 550 See `face-property-instance' for more information." | |
| 551 (color-instance-name (face-foreground-instance | |
| 552 face domain default no-fallback))) | |
| 553 | |
| 554 (defun set-face-foreground (face color &optional locale tag-set how-to-add) | |
| 555 "Change the foreground color of FACE to COLOR in LOCALE. | |
| 556 | |
| 557 FACE may be either a face object or a symbol representing a face. | |
| 558 | |
| 442 | 559 COLOR should be an instantiator (see `make-color-specifier'), a list of |
| 428 | 560 instantiators, an alist of specifications (each mapping a locale to |
| 561 an instantiator list), or a color specifier object. | |
| 562 | |
| 563 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 3027 | 564 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 565 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 566 specifies the locale under which the specified instantiator(s) | |
| 3027 | 567 will be added, and defaults to `global'. |
| 428 | 568 |
| 569 See `set-face-property' for more information." | |
| 570 (interactive (face-interactive "foreground")) | |
| 571 (set-face-property face 'foreground color locale tag-set how-to-add)) | |
| 572 | |
| 573 (defun face-background (face &optional locale tag-set exact-p) | |
| 574 "Return the background color of FACE in LOCALE, or nil if it is unspecified. | |
| 575 | |
| 3027 | 576 NOTE: This returns a locale-specific specification, not any sort of value |
| 577 corresponding to the actual background being used. If you want to know the | |
| 578 actual background color used in a particular domain, use | |
| 579 `face-background-instance', or `face-background-name' for its name | |
| 580 \(i.e. the instantiator used to create it). | |
| 581 | |
| 428 | 582 FACE may be either a face object or a symbol representing a face. |
| 583 | |
| 584 LOCALE may be a locale (the instantiators for that particular locale | |
| 585 will be returned), a locale type (the specifications for all locales | |
| 3027 | 586 of that type will be returned), `all' (all specifications will be |
| 428 | 587 returned), or nil (the actual specifier object will be returned). |
| 588 | |
| 589 See `face-property' for more information." | |
| 590 (face-property face 'background locale tag-set exact-p)) | |
| 591 | |
| 592 (defun face-background-instance (face &optional domain default no-fallback) | |
| 593 "Return the instance of FACE's background in DOMAIN. | |
| 594 | |
| 3027 | 595 Return value will be a color instance object; query its properties using |
| 596 `color-instance-name' or `color-instance-rgb-properties'. | |
| 597 | |
| 428 | 598 FACE may be either a face object or a symbol representing a face. |
| 599 | |
| 600 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 601 and an instance object describing how the background appears in that | |
| 602 particular window and buffer will be returned. | |
| 603 | |
| 604 See `face-property-instance' for more information." | |
| 605 (face-property-instance face 'background domain default no-fallback)) | |
| 606 | |
| 607 (defun face-background-name (face &optional domain default no-fallback) | |
| 608 "Return the name of FACE's background color in DOMAIN. | |
| 609 | |
| 610 FACE may be either a face object or a symbol representing a face. | |
| 611 | |
| 612 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 613 and an instance object describing how the background appears in that | |
| 614 particular window and buffer will be returned. | |
| 615 | |
| 616 See `face-property-instance' for more information." | |
| 617 (color-instance-name (face-background-instance | |
| 618 face domain default no-fallback))) | |
| 619 | |
| 620 (defun set-face-background (face color &optional locale tag-set how-to-add) | |
| 621 "Change the background color of FACE to COLOR in LOCALE. | |
| 622 | |
| 623 FACE may be either a face object or a symbol representing a face. | |
| 624 | |
| 442 | 625 COLOR should be an instantiator (see `make-color-specifier'), a list of |
| 428 | 626 instantiators, an alist of specifications (each mapping a locale to |
| 627 an instantiator list), or a color specifier object. | |
| 628 | |
| 629 If COLOR is an alist, LOCALE must be omitted. If COLOR is a | |
| 3027 | 630 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 631 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 632 specifies the locale under which the specified instantiator(s) | |
| 3027 | 633 will be added, and defaults to `global'. |
| 428 | 634 |
| 635 See `set-face-property' for more information." | |
| 636 (interactive (face-interactive "background")) | |
| 637 (set-face-property face 'background color locale tag-set how-to-add)) | |
| 638 | |
| 639 (defun face-background-pixmap (face &optional locale tag-set exact-p) | |
| 3027 | 640 "Return the background pixmap spec of FACE in LOCALE, or nil if unspecified. |
| 428 | 641 This property is only used on window system devices. |
| 642 | |
| 3027 | 643 NOTE: This returns a locale-specific specification, not any sort of value |
| 644 corresponding to the actual background pixmap being used. If you want to | |
| 645 know the actual background pixmap used in a particular domain, use | |
| 646 `face-background-pixmap-instance'. | |
| 647 | |
| 428 | 648 FACE may be either a face object or a symbol representing a face. |
| 649 | |
| 650 LOCALE may be a locale (the instantiators for that particular locale | |
| 651 will be returned), a locale type (the specifications for all locales | |
| 3027 | 652 of that type will be returned), `all' (all specifications will be |
| 428 | 653 returned), or nil (the actual specifier object will be returned). |
| 654 | |
| 655 See `face-property' for more information." | |
| 656 (face-property face 'background-pixmap locale tag-set exact-p)) | |
| 657 | |
| 658 (defun face-background-pixmap-instance (face &optional domain default | |
| 659 no-fallback) | |
| 660 "Return the instance of FACE's background pixmap in DOMAIN. | |
| 661 | |
| 3027 | 662 Return value will be an image instance object; query its properties using |
| 663 `image-instance-instantiator' (the original instantiator used to create | |
| 664 the image, which may be a complex beast -- see `make-image-specifier'), | |
| 665 `image-instance-file-name' (the file, if any, from which the image was | |
| 666 created), `image-instance-height', etc. | |
| 667 | |
| 428 | 668 FACE may be either a face object or a symbol representing a face. |
| 669 | |
| 670 Normally DOMAIN will be a window or nil (meaning the selected window), | |
| 671 and an instance object describing how the background appears in that | |
| 672 particular window and buffer will be returned. | |
| 673 | |
| 674 See `face-property-instance' for more information." | |
| 675 (face-property-instance face 'background-pixmap domain default no-fallback)) | |
| 676 | |
| 677 (defun set-face-background-pixmap (face pixmap &optional locale tag-set | |
| 678 how-to-add) | |
| 679 "Change the background pixmap of FACE to PIXMAP in LOCALE. | |
| 680 This property is only used on window system devices. | |
| 681 | |
| 682 FACE may be either a face object or a symbol representing a face. | |
| 683 | |
| 442 | 684 PIXMAP should be an instantiator (see `make-image-specifier'), a list |
| 428 | 685 of instantiators, an alist of specifications (each mapping a locale |
| 686 to an instantiator list), or an image specifier object. | |
| 687 | |
| 688 If PIXMAP is an alist, LOCALE must be omitted. If PIXMAP is a | |
| 3027 | 689 specifier object, LOCALE can be a locale, a locale type, `all', |
| 428 | 690 or nil; see `copy-specifier' for its semantics. Otherwise LOCALE |
| 691 specifies the locale under which the specified instantiator(s) | |
| 3027 | 692 will be added, and defaults to `global'. |
| 428 | 693 |
| 694 See `set-face-property' for more information." | |
| 695 (interactive (face-interactive "background-pixmap")) | |
| 696 (set-face-property face 'background-pixmap pixmap locale tag-set how-to-add)) | |
| 697 | |
| 1137 | 698 (defvar background-pixmap-file-history nil |
| 699 ;; History for `set-face-background-pixmap-file' | |
| 700 ) | |
| 701 | |
| 702 (defun set-face-background-pixmap-file (face file) | |
| 703 "Read (and set) the background pixmap of FACE from FILE. | |
| 704 This function is a simplified version of `set-face-background-pixmap', | |
| 705 designed for interactive use." | |
| 706 (interactive | |
| 707 (let* ((face (read-face-name "Set background pixmap of face: ")) | |
| 1139 | 708 (default (and (face-background-pixmap-instance face) |
|
4670
5a54ce6dc945
Remove some extra parentheses, #'set-face-background-pixmap-file.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
709 (image-instance-file-name |
|
5a54ce6dc945
Remove some extra parentheses, #'set-face-background-pixmap-file.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4222
diff
changeset
|
710 (face-background-pixmap-instance face)))) |
| 1137 | 711 (file (read-file-name |
| 712 (format "Set background pixmap of face %s to: " | |
| 713 (symbol-name face)) | |
| 1139 | 714 nil default t nil |
| 1137 | 715 'background-pixmap-file-history))) |
| 716 (list face (if (equal file "") nil file)))) | |
| 717 (set-face-property face 'background-pixmap file)) | |
| 718 | |
| 428 | 719 (defun face-display-table (face &optional locale tag-set exact-p) |
| 3027 | 720 "Return the display table spec of FACE in LOCALE, or nil if unspecified.. |
| 428 | 721 |
| 3027 | 722 NOTE: This returns a locale-specific specification, not any sort of value |
| 723 corresponding to the actual display table being used. If you want to | |
| 724 know the actual display table used in a particular domain, use | |
| 725 `face-display-table-instance'. | |
| 726 | |
| 727 FACE may be either a face object or a symbol representing a face. | |
| 428 | 728 |
| 729 LOCALE may be a locale (the instantiators for that particular locale | |
| 730 will be returned), a locale type (the specifications for all locales | |
| 3027 | 731 of that type will be returned), `all' (all specifications will be |
| 428 | 732 returned), or nil (the actual specifier object will be returned). |
| 733 | |
| 734 See `face-property' for more information." | |
| 735 (face-property face 'display-table locale tag-set exact-p)) | |
| 736 | |
| 737 (defun face-display-table-instance (face &optional domain default no-fallback) | |
| 738 "Return the instance of FACE's display table in DOMAIN. | |
| 3027 | 739 |
| 740 Return value will be a vector, char table or range table; see | |
| 741 `current-display-table'. | |
| 742 | |
| 743 FACE may be either a face object or a symbol representing a face. | |
| 428 | 744 |
| 3027 | 745 Normally DOMAIN will be a window or nil (meaning the selected window), |
| 746 and the actual display table used in that particular window and buffer | |
| 747 will be returned. | |
| 748 | |
| 749 See `face-property-instance' for more information." | |
| 428 | 750 (face-property-instance face 'display-table domain default no-fallback)) |
| 751 | |
| 752 (defun set-face-display-table (face display-table &optional locale tag-set | |
| 872 | 753 how-to-add) |
| 428 | 754 "Change the display table of FACE to DISPLAY-TABLE in LOCALE. |
| 755 DISPLAY-TABLE should be a vector as returned by `make-display-table'. | |
| 756 | |
| 757 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and | |
| 758 HOW-TO-ADD arguments." | |
| 759 (interactive (face-interactive "display-table")) | |
| 760 (set-face-property face 'display-table display-table locale tag-set | |
| 761 how-to-add)) | |
| 762 | |
| 763 ;; The following accessors and mutators are, IMHO, good | |
| 764 ;; implementation. Cf. with `make-face-bold'. | |
| 765 | |
| 766 (defun face-underline-p (face &optional domain default no-fallback) | |
| 767 "Return t if FACE is underlined in DOMAIN. | |
| 768 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 769 (face-property-instance face 'underline domain default no-fallback)) | |
| 770 | |
| 771 (defun set-face-underline-p (face underline-p &optional locale tag-set | |
| 872 | 772 how-to-add) |
| 428 | 773 "Change the underline property of FACE to UNDERLINE-P. |
| 774 UNDERLINE-P is normally a face-boolean instantiator; see | |
| 442 | 775 `make-face-boolean-specifier'. |
| 428 | 776 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 777 HOW-TO-ADD arguments." | |
| 778 (interactive (face-interactive "underline-p" "underlined")) | |
| 779 (set-face-property face 'underline underline-p locale tag-set how-to-add)) | |
| 780 | |
| 781 (defun face-strikethru-p (face &optional domain default no-fallback) | |
| 782 "Return t if FACE is strikethru-d (i.e. struck through) in DOMAIN. | |
| 783 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 784 (face-property-instance face 'strikethru domain default no-fallback)) | |
| 785 | |
| 786 (defun set-face-strikethru-p (face strikethru-p &optional locale tag-set | |
| 872 | 787 how-to-add) |
| 428 | 788 "Change whether FACE is strikethru-d (i.e. struck through) in LOCALE. |
| 789 STRIKETHRU-P is normally a face-boolean instantiator; see | |
| 442 | 790 `make-face-boolean-specifier'. |
| 428 | 791 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 792 HOW-TO-ADD arguments." | |
| 793 (interactive (face-interactive "strikethru-p" "strikethru-d")) | |
| 794 (set-face-property face 'strikethru strikethru-p locale tag-set how-to-add)) | |
| 795 | |
| 796 (defun face-highlight-p (face &optional domain default no-fallback) | |
| 797 "Return t if FACE is highlighted in DOMAIN (TTY domains only). | |
| 798 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 799 (face-property-instance face 'highlight domain default no-fallback)) | |
| 800 | |
| 801 (defun set-face-highlight-p (face highlight-p &optional locale tag-set | |
| 872 | 802 how-to-add) |
| 428 | 803 "Change whether FACE is highlighted in LOCALE (TTY locales only). |
| 804 HIGHLIGHT-P is normally a face-boolean instantiator; see | |
| 442 | 805 `make-face-boolean-specifier'. |
| 428 | 806 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 807 HOW-TO-ADD arguments." | |
| 808 (interactive (face-interactive "highlight-p" "highlighted")) | |
| 809 (set-face-property face 'highlight highlight-p locale tag-set how-to-add)) | |
| 810 | |
| 811 (defun face-dim-p (face &optional domain default no-fallback) | |
| 812 "Return t if FACE is dimmed in DOMAIN. | |
| 813 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 814 (face-property-instance face 'dim domain default no-fallback)) | |
| 815 | |
| 816 (defun set-face-dim-p (face dim-p &optional locale tag-set how-to-add) | |
| 817 "Change whether FACE is dimmed in LOCALE. | |
| 818 DIM-P is normally a face-boolean instantiator; see | |
| 442 | 819 `make-face-boolean-specifier'. |
| 428 | 820 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 821 HOW-TO-ADD arguments." | |
| 822 (interactive (face-interactive "dim-p" "dimmed")) | |
| 823 (set-face-property face 'dim dim-p locale tag-set how-to-add)) | |
| 824 | |
| 825 (defun face-blinking-p (face &optional domain default no-fallback) | |
| 826 "Return t if FACE is blinking in DOMAIN (TTY domains only). | |
| 827 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 828 (face-property-instance face 'blinking domain default no-fallback)) | |
| 829 | |
| 830 (defun set-face-blinking-p (face blinking-p &optional locale tag-set | |
| 872 | 831 how-to-add) |
| 428 | 832 "Change whether FACE is blinking in LOCALE (TTY locales only). |
| 833 BLINKING-P is normally a face-boolean instantiator; see | |
| 442 | 834 `make-face-boolean-specifier'. |
| 428 | 835 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 836 HOW-TO-ADD arguments." | |
| 837 (interactive (face-interactive "blinking-p" "blinking")) | |
| 838 (set-face-property face 'blinking blinking-p locale tag-set how-to-add)) | |
| 839 | |
| 840 (defun face-reverse-p (face &optional domain default no-fallback) | |
| 841 "Return t if FACE is reversed in DOMAIN (TTY domains only). | |
| 842 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 843 (face-property-instance face 'reverse domain default no-fallback)) | |
| 844 | |
| 845 (defun set-face-reverse-p (face reverse-p &optional locale tag-set how-to-add) | |
| 846 "Change whether FACE is reversed in LOCALE (TTY locales only). | |
| 847 REVERSE-P is normally a face-boolean instantiator; see | |
| 442 | 848 `make-face-boolean-specifier'. |
| 428 | 849 See `set-face-property' for the semantics of the LOCALE, TAG-SET, and |
| 850 HOW-TO-ADD arguments." | |
| 851 (interactive (face-interactive "reverse-p" "reversed")) | |
| 852 (set-face-property face 'reverse reverse-p locale tag-set how-to-add)) | |
| 853 | |
| 854 | |
| 855 (defun face-property-equal (face1 face2 prop domain) | |
| 856 (equal (face-property-instance face1 prop domain) | |
| 857 (face-property-instance face2 prop domain))) | |
| 858 | |
| 859 (defun face-equal-loop (props face1 face2 domain) | |
| 860 (while (and props | |
| 861 (face-property-equal face1 face2 (car props) domain)) | |
| 862 (setq props (cdr props))) | |
| 863 (null props)) | |
| 864 | |
| 865 (defun face-equal (face1 face2 &optional domain) | |
| 866 "Return t if FACE1 and FACE2 will display in the same way in DOMAIN. | |
| 867 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 868 (if (null domain) (setq domain (selected-window))) | |
| 869 (if (not (valid-specifier-domain-p domain)) | |
| 870 (error "Invalid specifier domain")) | |
| 871 (let ((device (dfw-device domain)) | |
| 872 (common-props '(foreground background font display-table underline | |
| 3027 | 873 dim inherit)) |
| 428 | 874 (win-props '(background-pixmap strikethru)) |
| 875 (tty-props '(highlight blinking reverse))) | |
| 876 | |
| 877 ;; First check the properties which are used in common between the | |
| 878 ;; x and tty devices. Then, check those properties specific to | |
| 879 ;; the particular device type. | |
| 880 (and (face-equal-loop common-props face1 face2 domain) | |
| 881 (cond ((eq 'tty (device-type device)) | |
| 882 (face-equal-loop tty-props face1 face2 domain)) | |
| 872 | 883 ((console-on-window-system-p (device-console device)) |
| 428 | 884 (face-equal-loop win-props face1 face2 domain)) |
| 885 (t t))))) | |
| 886 | |
| 887 (defun face-differs-from-default-p (face &optional domain) | |
| 888 "Return t if FACE will display differently from the default face in DOMAIN. | |
| 889 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 890 (not (face-equal face 'default domain))) | |
| 891 | |
| 892 (defun try-font-name (name &optional device) | |
| 872 | 893 "Return NAME if it's a valid font name on DEVICE, else nil." |
| 428 | 894 ;; yes, name really should be here twice. |
| 895 (and name (make-font-instance name device t) name)) | |
| 896 | |
| 897 | |
| 872 | 898 |
| 899 (defcustom face-frob-from-locale-first nil | |
| 900 "*If non nil, use kludgy way of frobbing fonts suitable for non-mule | |
| 901 multi-charset environments." | |
| 902 :group 'faces | |
| 903 :type 'boolean) | |
| 904 | |
| 428 | 905 ;; This function is a terrible, disgusting hack!!!! Need to |
| 906 ;; separate out the font elements as separate face properties! | |
| 907 | |
| 908 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 909 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 910 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 911 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 912 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 913 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 914 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 915 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 916 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 917 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 918 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 919 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 920 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 921 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 922 ;; WE DEMAND LEXICAL SCOPING!!! | |
| 872 | 923 |
| 924 ;; When we are initializing a device, it won't be selected; we communicate | |
| 925 ;; the device to consider as selected using this variable. | |
| 926 (defvar Face-frob-property-device-considered-current nil) | |
| 428 | 927 |
| 872 | 928 (defun Face-frob-property (face locale tag-set exact-p |
| 929 unfrobbed-face frobbed-face | |
| 930 win-prop tty-props | |
| 931 frob-mapping standard-face-mapping) | |
| 932 ;; implement the semantics of `make-face-bold' et al. FACE, LOCALE, TAG-SET | |
| 933 ;; and EXACT-P are as in that call. UNFROBBED-FACE and FROBBED-FACE are | |
| 934 ;; what we expect the original face and the result to look like, | |
| 935 ;; respectively. TTY-PROPS is a list of face properties to frob in place | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
936 ;; of `font' for TTYs. FROB-MAPPING is either a plist mapping device |
| 872 | 937 ;; types to functions of two args (NAME DEVICE) that will frob the |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
938 ;; instantiator to NAME as appropriate for DEVICE's type (this includes |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
939 ;; TTYs #### TTYs are not passed the device, just the symbol 'tty), or a |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
940 ;; function to handle the mapping for all device types. |
| 872 | 941 ;; STANDARD-FACE-MAPPING is an alist of mappings of inheritance |
| 942 ;; instantiators to be replaced with other inheritance instantiators, meant | |
| 943 ;; for e.g. converting [bold] into [bold-italic]. | |
| 944 | |
| 945 ;; #### it would be nice if this function could be generalized to be | |
| 946 ;; a general specifier frobber. but so much of what it does is specific | |
| 947 ;; to faces -- e.g. handling of inheritance, standard faces, | |
| 948 ;; special-casing in various ways for tty's, etc. i've already extracted | |
| 949 ;; as much of the functionality as i can into subfunctions in the | |
| 950 ;; heuristic section of specifier.el. | |
| 442 | 951 |
| 872 | 952 ;; #### Note: The old code was totally different (and there was much less |
| 953 ;; of it). It didn't bother with trying to frob all the instantiators, | |
| 954 ;; or handle inheritance vectors as instantiators, or do something | |
| 955 ;; sensible with buffer locales, or many other things. (It always, or | |
| 956 ;; usually, did a specifier-instance and frobbed the result.) But it did | |
| 957 ;; do three things we don't: | |
| 958 ;; | |
| 959 ;; (1) Map over all devices when processing global or buffer locales. | |
| 960 ;; Should we be doing this in stages 2 and/or 3? The fact that we | |
| 961 ;; now process all fallback instantiators seems to make this less | |
| 962 ;; necessary, at least for global locales. | |
| 963 ;; | |
| 964 ;; (2) Remove all instantiators tagged with `default' when putting the | |
| 965 ;; instantiators back. I don't see why this is necessary, but maybe | |
| 966 ;; it is. | |
| 967 ;; | |
| 968 ;; (3) Pay attention to the face-frob-from-locale-first variable. #### | |
| 969 ;; I don't understand its purpose. Undocumented hacks like this, | |
| 970 ;; clearly added after-the-fact, don't deserve to live. DOCUMENT | |
| 971 ;; THIS SHIT! | |
| 428 | 972 |
| 872 | 973 (flet |
| 974 ( | |
| 975 | |
| 976 ;; non-nil if either instantiator non-nil, or nil instantiators allowed. | |
| 977 (nil-instantiator-ok (inst devtype-spec) | |
| 978 (or inst (eq devtype-spec 'tty))) | |
| 979 | |
| 980 ;; if LOCALE is a global locale (all, nil, global), return 'global, | |
| 981 ;; else nil. | |
| 982 (global-locale (locale) | |
| 983 (and (memq locale '(all nil global)) 'global)) | |
| 444 | 984 |
| 872 | 985 ;; Given a locale and the inst-list from that locale, frob the |
| 986 ;; instantiators according to FROB-MAPPING, a plist mapping device | |
| 987 ;; types to functions that frob instantiators of that device type. | |
| 988 ;; NOTE: TAG-SET and FROB-MAPPING from environment. | |
| 989 (frob-face-inst-list (locale inst-list prop devtype-spec) | |
| 990 (let* ((ffpdev Face-frob-property-device-considered-current) | |
| 991 (results | |
| 992 ;; for each inst-pair, frob it (the result will be 0 or | |
| 993 ;; more inst-pairs; we may get more than one if, e.g. the | |
| 994 ;; instantiator specifies inheritance and we expand the | |
| 995 ;; inheritance); then nconc the results together | |
| 996 (loop for (tag-set . x) in inst-list | |
| 997 for devtype = (derive-device-type-from-locale-and-tag-set | |
| 998 locale tag-set devtype-spec ffpdev) | |
| 999 ;; devtype may be nil if it fails to match DEVTYPE-SPEC | |
| 1000 if devtype | |
| 3360 | 1001 if (let* ((mapper |
| 1002 (cond ((functionp frob-mapping) frob-mapping) | |
| 1003 ((plist-get frob-mapping devtype)) | |
| 1004 (t (error 'unimplemented "mapper" devtype)))) | |
| 872 | 1005 (result |
| 1006 (cond | |
| 1007 ;; if a vector ... | |
| 1008 ((vectorp x) | |
| 1009 (let ((change-to | |
| 1010 (cdr (assoc x standard-face-mapping)))) | |
| 1011 (cond | |
| 1012 ;; (1) handle standard mappings/null vectors | |
| 1013 ((or change-to (null (length x))) | |
| 1014 (list (cons tag-set | |
| 1015 (cond ((eq change-to t) x) | |
| 1016 (change-to) | |
| 1017 (t x))))) | |
| 1018 ;; (2) inheritance vectors. retrieve the | |
| 1019 ;; inherited value and recursively frob. | |
| 1020 ;; stick the tag-set into the result. | |
| 1021 (t (let* | |
| 1022 ((subprop | |
| 1023 (if (> (length x) 1) (elt x 1) | |
| 1024 prop)) | |
| 1025 (subinsts | |
| 1026 (frob-face-inst-list | |
| 1027 locale | |
| 1028 (cdar | |
| 1029 (specifier-spec-list | |
| 1030 (face-property (elt x 0) | |
| 1031 subprop))) | |
| 1032 subprop devtype-spec))) | |
| 1033 ;; #### we don't currently handle | |
| 1034 ;; the "reverse the sense" flag on | |
| 1035 ;; tty inheritance vectors. | |
| 1036 (add-tag-to-inst-list subinsts | |
| 1037 tag-set)))))) | |
| 1038 ;; (3) not a vector. just process it. | |
| 1039 (t | |
| 1040 (let ((value | |
| 1041 (if (eq devtype-spec 'tty) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1042 ;; #### not quite right but need |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1043 ;; two args to match documentation |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1044 ;; mostly we just ignore TTYs so |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1045 ;; for now just pass the devtype |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1046 (funcall mapper x 'tty) |
| 872 | 1047 (funcall mapper x |
| 1048 (derive-domain-from-locale | |
| 1049 locale devtype-spec | |
| 1050 ffpdev))))) | |
| 1051 (and (nil-instantiator-ok value devtype-spec) | |
| 1052 (list (cons tag-set value)))))))) | |
| 1053 ;; if we're adding to a tty, we need to tag our | |
| 1054 ;; additions with `tty'; see [note 1] below. we leave | |
| 1055 ;; the old spec in place, however -- if e.g. we're | |
| 1056 ;; italicizing a font that was always set to be | |
| 1057 ;; underlined, even on window systems, then we still | |
| 1058 ;; want the underline there. unless we put the old | |
| 1059 ;; spec back, the underline will disappear, since | |
| 1060 ;; the new specs are all tagged with `tty'. this | |
| 1061 ;; doesn't apply to the [note 1] situations below | |
| 1062 ;; because there we're just adding, not substituting. | |
| 1063 (if (and (eq 'tty devtype-spec) | |
| 1064 (not (or (eq 'tty tag-set) | |
| 1065 (memq 'tty tag-set)))) | |
| 1066 (nconc (add-tag-to-inst-list result 'tty) | |
| 1067 (list (cons tag-set x))) | |
| 1068 result)) | |
| 1069 nconc it))) | |
| 1070 (delete-duplicates results :test #'equal))) | |
| 428 | 1071 |
| 872 | 1072 ;; Frob INST-LIST, which came from LOCALE, and put the new value back |
| 1073 ;; into SP at LOCALE. THUNK is a cons of (PROP . DEVTYPE-SPEC), the | |
| 1074 ;; property being processed and whether this is a TTY property or a | |
| 1075 ;; win property. | |
| 1076 (frob-locale (sp locale inst-list thunk) | |
| 1077 (let ((newinst (frob-face-inst-list locale inst-list | |
| 1078 (car thunk) (cdr thunk)))) | |
| 1079 (remove-specifier sp locale tag-set exact-p) | |
| 1080 (add-spec-list-to-specifier sp (list (cons locale newinst)))) | |
| 1081 ;; map-specifier should keep going | |
| 1082 nil) | |
| 428 | 1083 |
| 872 | 1084 ;; map over all specified locales in LOCALE; for each locale, |
| 1085 ;; frob the instantiators in that locale in the specifier in both | |
| 1086 ;; WIN-PROP and TTY-PROPS in FACE. Takes values from environment. | |
| 1087 (map-over-locales (locale) | |
| 1088 (map-specifier (get face win-prop) #'frob-locale locale | |
| 1089 (cons win-prop 'window-system) | |
| 1090 tag-set exact-p) | |
| 1091 (loop for prop in tty-props do | |
| 1092 (map-specifier (get face prop) #'frob-locale locale | |
| 1093 (cons prop 'tty) | |
| 1094 tag-set exact-p))) | |
| 1095 | |
| 1096 ;; end of flets | |
| 1097 ) | |
| 1098 | |
| 1099 ;; the function itself | |
| 452 | 1100 |
| 872 | 1101 (let* ((ffpdev Face-frob-property-device-considered-current) |
| 1102 (do-later-stages | |
| 1103 (or (global-locale locale) | |
| 1104 (valid-specifier-domain-p locale) | |
| 1105 (bufferp locale))) | |
| 1106 (domain (and do-later-stages | |
| 1107 (derive-domain-from-locale locale 'window-system | |
| 1108 ffpdev))) | |
| 1109 (check-differences | |
| 1110 (and unfrobbed-face frobbed-face domain | |
| 1111 (not (memq (face-name face) | |
| 1112 '(default bold italic bold-italic))))) | |
| 1113 (orig-instance | |
| 1114 (and check-differences | |
| 1115 (face-property-instance face win-prop domain)))) | |
| 1116 | |
| 1117 ;; first do the frobbing | |
| 1118 (setq face (get-face face)) | |
| 1119 (map-over-locales locale) | |
| 1120 | |
| 1121 (when do-later-stages | |
| 1122 | |
| 1123 (if (global-locale locale) (setq locale 'global)) | |
| 428 | 1124 |
| 872 | 1125 ;; now do the second stage -- if there's nothing there, try |
| 1126 ;; harder to find an instantiator, and frob it. | |
| 1127 (let (do-something) | |
| 1128 (loop for prop in (cons win-prop tty-props) | |
| 1129 for propspec = (get face prop) | |
| 1130 for devtype-spec = (if (eq prop win-prop) 'window-system 'tty) | |
| 1131 if propspec | |
| 1132 do | |
| 1133 (or (specifier-spec-list propspec locale) | |
| 1134 (let ((doit (derive-specifier-specs-from-locale | |
| 1135 propspec locale devtype-spec ffpdev | |
| 1136 ;; #### does this make sense? When no tags | |
| 1137 ;; given, frob the whole list of fallbacks when | |
| 1138 ;; global, else just retrieve a current-device | |
| 1139 ;; value. this tries to mirror normal practices, | |
| 1140 ;; where with no tags you want everything frobbed, | |
| 1141 ;; but with a tag you want only the tag frobbed | |
| 1142 ;; and hence you probably don't want lots and lots | |
| 1143 ;; of items there. (#### Perhaps the best way -- | |
| 1144 ;; or at least a way with some theoretical | |
| 1145 ;; justifiability -- is to fetch the fallbacks | |
| 1146 ;; that match the TAG-SET/EXACT-P, and if none, | |
| 1147 ;; fall back onto doing the selected-device | |
| 1148 ;; trick.) | |
| 1149 (and (not tag-set) (not exact-p))))) | |
| 1150 (if (and (not doit) (eq locale 'global)) | |
| 1151 (error | |
| 1152 "No fallback for specifier property %s in face %s???" | |
| 1153 prop face)) | |
| 1154 ;; [note 1] whenever we add to a tty property, | |
| 1155 ;; make sure we tag our additions with `tty' to | |
| 1156 ;; avoid accidentally messing things up on window | |
| 1157 ;; systems (e.g. when making things italic we | |
| 1158 ;; don't want to set the underline property on | |
| 1159 ;; window systems) | |
| 1160 (when doit | |
| 1161 (add-spec-list-to-specifier | |
| 1162 propspec | |
| 1163 (list (cons locale | |
| 1164 (add-tag-to-inst-list | |
| 1165 doit | |
| 1166 (append (if (listp tag-set) tag-set | |
| 1167 (list tag-set)) | |
| 1168 (if (eq devtype-spec 'tty) '(tty))) | |
| 1169 )))) | |
| 1170 (setq do-something t))))) | |
| 1171 (when do-something | |
| 1172 (map-over-locales (or (global-locale locale) locale)))) | |
| 1173 | |
| 1174 ;; then do the third stage -- check for whether we have to do | |
| 1175 ;; the inheritance trick. | |
| 1176 | |
| 1177 (when (and check-differences | |
| 1178 (let ((new-instance | |
| 1179 (face-property-instance face win-prop domain))) | |
| 1180 (and | |
| 1181 (equal orig-instance new-instance) | |
| 1182 (equal orig-instance | |
| 1183 (face-property-instance unfrobbed-face win-prop | |
| 1184 domain))))) | |
| 1185 (set-face-property face win-prop (vector frobbed-face) | |
| 1186 (or (global-locale locale) locale) tag-set)))))) | |
| 428 | 1187 |
| 707 | 1188 ;; WE DEMAND FOUNDRY FROBBING! |
| 1189 | |
| 1190 ;; Family frobbing | |
| 1191 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> | |
| 1192 ;; Brainlessly derived from make-face-size by Stephen; don't blame Jan. | |
| 1193 ;; I'm long since flown to Rio, it does you little good to blame me, either. | |
| 872 | 1194 (defun make-face-family (face family &optional locale tags exact-p) |
| 1195 "Set FACE's family to FAMILY in LOCALE, if possible." | |
| 1196 (interactive (list (read-face-name "Set family of which face: ") | |
| 1197 (read-string "Family to set: "))) | |
| 707 | 1198 |
| 872 | 1199 (Face-frob-property face locale tags exact-p |
| 1200 nil nil 'font nil | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1201 ;; #### this code is duplicated in make-face-size |
| 872 | 1202 `(lambda (f d) |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1203 ;; keep the dependency on font.el for now |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1204 ;; #### The filter on null d is a band-aid. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1205 ;; Frob-face-property should not be passing in |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1206 ;; null devices. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1207 (unless (or (null d) (eq d 'tty)) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1208 (let ((fo (font-create-object f d))) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1209 (set-font-family fo ,family) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1210 (font-create-name fo d)))) |
| 872 | 1211 nil)) |
| 707 | 1212 |
| 1213 ;; Style (ie, typographical face) frobbing | |
| 872 | 1214 (defun make-face-bold (face &optional locale tags exact-p) |
| 428 | 1215 "Make FACE bold in LOCALE, if possible. |
| 872 | 1216 This will attempt to make the font bold for window-system locales and will |
| 1217 set the highlight flag for TTY locales. | |
| 1218 | |
| 1219 The actual behavior of this function is somewhat messy, in an attempt to | |
| 1220 get more intuitive behavior in quite a lot of different circumstances. (You | |
| 1221 might view this as indicative of design failures with specifiers, but in | |
| 1222 fact almost all code that attempts to interface to humans and produce | |
| 1223 \"intuitive\" results gets messy, particularly with a system as complicated | |
| 1224 as specifiers, whose complexity results from an attempt to work well in | |
| 1225 many different circumstances.) | |
| 1226 | |
| 1227 The meaning of LOCALE is the same as for `specifier-spec-list', i.e.: | |
| 1228 | |
| 1229 -- If LOCALE is nil, omitted, or `all', this will attempt to \"frob\" all | |
| 1230 font specifications for FACE to make them appear bold (i.e. the | |
| 1231 specifications are replaced with equivalent specifications, where the | |
| 1232 font names have been changed to the closest bold font). | |
| 1233 | |
| 1234 -- If LOCALE is a locale type \(`buffer', `window', etc.), this frobs all | |
| 1235 font specifications for locales of that type. | |
| 1236 | |
| 1237 -- If LOCALE is a particular locale, this frobs all font specifications for | |
| 1238 that locale. | |
| 428 | 1239 |
| 872 | 1240 If TAGS is given, this only processes instantiators whose tag set includes |
| 1241 all tags mentioned in TAGS. In addition, if EXACT-P is non-nil, only | |
| 1242 instantiators whose tag set exactly matches TAGS are processed; otherwise, | |
| 1243 additional tags may be present in the instantiator's tag set. | |
| 1244 | |
| 1245 This function proceeeds in three stages. | |
| 1246 | |
| 1247 STAGE 1: Frob the settings that are already present. | |
| 1248 STAGE 2: (if called for) Ensure that *some* setting exists in the locale | |
| 1249 that was given, finding it in various ways and frobbing it as in | |
| 1250 stage 1. This ensures that there is an actual setting for | |
| 1251 the locale, so you will get the expected buffer-local/frame-local | |
| 1252 behavior -- changes to the global value, to other locales, won't | |
| 1253 affect this locale, (b) the face will actually look bold in | |
| 1254 the locale. | |
| 1137 | 1255 STAGE 3: (if called for) |
| 872 | 1256 |
| 1257 The way the frobbing works depends on the device type -- first on whether | |
| 1258 or not it's TTY, and second, if it's a window-system device type, on which | |
| 1259 particular window-system device type. For locales with a specific device | |
| 1260 type, we do the frobbing in the context of that device type -- this means | |
| 1261 that for TTY device types we set the highlight flag, and for window-system | |
| 1262 device types we modify the font spec according to the rules for font specs | |
| 1263 of that device type. For global locales, we may process both the highlight | |
| 1264 flag and the font specs (depending on the device types compiled into this | |
| 1265 XEmacs). When processing font specs, we check the tag set associated with | |
| 1266 each font spec to see if it's specific to a particular device type; if so, | |
| 1267 we frob it in the context of that type, else we use the type of the current | |
| 1268 device. (A hack, but works well in practice -- and if a new device is | |
| 1269 created, we will automatically frob all the standard fonts to make sure | |
| 1270 they display OK on that device.) | |
| 1271 | |
| 1272 If LOCALE is not a locale type, and both TAGS and EXACT-P are omitted, we | |
| 1273 do further frobbing in an attempt to give more intuitive behavior. | |
| 428 | 1274 |
| 872 | 1275 First, if there are no specifications in LOCALE (if LOCALE is `all', we act |
| 1276 as if it were `global' for this step), we do our utmost to put a | |
| 1277 specification there; otherwise, this function will have no effect. For | |
| 1278 device, frame, or window locales, the face's font is instantiated using the | |
| 1279 locale as a domain, and the resulting font is frobbed and added back as a | |
| 1280 specification for this locale. If LOCALE is `global', we retrieve the | |
| 1281 fallback specs and frob them. If LOCALE is a buffer, things get tricky | |
| 1282 since you can't instantiate a specifier in a buffer domain \(the buffer can | |
| 1283 appear in multiple places, or in different places over time, so this | |
| 1284 operation is not well-defined). We used to signal an error in this case, | |
| 1285 but now we instead try to do something logical so that we work somewhat | |
| 1286 similarly to buffer-local variables. Specifically, we use | |
| 1287 `get-buffer-window' to find a window viewing the buffer, and if there is | |
| 1288 one, use this as a domain to instantiate the font, and frob the resulting | |
| 1289 value. Otherwise, we use the selected window for the same purpose. | |
| 1290 | |
| 1291 Finally, if the frobbing didn't actually make the font look any different | |
| 1292 in whatever domain we instantiated the font in (this happens, for example, | |
| 1293 if your font specification is already bold or has no bold equivalent; note | |
| 1294 that in this step, we use the selected device in place of `global' or `all' | |
| 1295 -- another hack, but works well in practice since there's usually only one | |
| 1296 device), and the font currently looks like the font of the `default' face, | |
| 1297 it is set to inherit from the `bold' face. | |
| 1298 | |
| 1299 NOTE: For the other functions defined below, the identity of these two | |
| 1300 standard faces mentioned in the previous paragraph, and the TTY properties | |
| 1301 that are modified, may be different, and whether the TTY property or | |
| 1302 properties are set or unset may be different. For example, for | |
| 1303 `make-face-unitalic', the last sentence in the previous paragraph would | |
| 1304 read \"... and the font currently looks like the font of the `italic' face, | |
| 1305 it is set to inherit from the `default' face.\", and the second sentence in | |
| 1306 the first paragraph would read \"This will attempt to make the font | |
| 1307 non-italic for window-system locales and will unset the underline flag for | |
| 1308 TTY locales.\" | |
| 1309 | |
| 1310 Here's a table indicating the behavior differences with the different | |
| 1311 functions: | |
| 1312 | |
| 1313 function face1 face2 tty-props tty-val | |
| 1314 ---------------------------------------------------------------------------- | |
| 1315 make-face-bold default bold highlight t | |
| 1316 make-face-italic default italic underline t | |
| 1317 make-face-bold-italic default bold-italic highlight,underline t | |
| 1318 make-face-unbold bold default highlight nil | |
| 1319 make-face-unitalic italic default underline nil | |
| 1320 " | |
| 428 | 1321 (interactive (list (read-face-name "Make which face bold: "))) |
| 872 | 1322 (Face-frob-property face locale tags exact-p |
| 1323 'default 'bold 'font '(highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1324 '(tty (lambda (f d) t) |
| 872 | 1325 x x-make-font-bold |
| 1326 gtk gtk-make-font-bold | |
| 1327 mswindows mswindows-make-font-bold | |
| 1328 msprinter mswindows-make-font-bold) | |
| 1329 '(([default] . [bold]) | |
| 1330 ([bold] . t) | |
| 1331 ([italic] . [bold-italic]) | |
| 1332 ([bold-italic] . t)))) | |
| 428 | 1333 |
| 872 | 1334 (defun make-face-italic (face &optional locale tags exact-p) |
| 428 | 1335 "Make FACE italic in LOCALE, if possible. |
| 442 | 1336 This will attempt to make the font italic for X/MS Windows locales and |
| 1337 will set the underline flag for TTY locales. See `make-face-bold' for | |
| 1338 the semantics of the LOCALE argument and for more specifics on exactly | |
| 1339 how this function works." | |
| 428 | 1340 (interactive (list (read-face-name "Make which face italic: "))) |
| 872 | 1341 (Face-frob-property face locale tags exact-p |
| 1342 'default 'italic 'font '(underline) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1343 '(tty (lambda (f d) t) |
| 872 | 1344 x x-make-font-italic |
| 1345 gtk gtk-make-font-italic | |
| 1346 mswindows mswindows-make-font-italic | |
| 1347 msprinter mswindows-make-font-italic) | |
| 1348 '(([default] . [italic]) | |
| 1349 ([bold] . [bold-italic]) | |
| 1350 ([italic] . t) | |
| 1351 ([bold-italic] . t)))) | |
| 428 | 1352 |
| 872 | 1353 (defun make-face-bold-italic (face &optional locale tags exact-p) |
| 428 | 1354 "Make FACE bold and italic in LOCALE, if possible. |
| 442 | 1355 This will attempt to make the font bold-italic for X/MS Windows |
| 1356 locales and will set the highlight and underline flags for TTY | |
| 1357 locales. See `make-face-bold' for the semantics of the LOCALE | |
| 1358 argument and for more specifics on exactly how this function works." | |
| 428 | 1359 (interactive (list (read-face-name "Make which face bold-italic: "))) |
| 872 | 1360 (Face-frob-property face locale tags exact-p |
| 1361 'default 'bold-italic 'font '(underline highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1362 '(tty (lambda (f d) t) |
| 872 | 1363 x x-make-font-bold-italic |
| 1364 gtk gtk-make-font-bold-italic | |
| 1365 mswindows mswindows-make-font-bold-italic | |
| 1366 msprinter mswindows-make-font-bold-italic) | |
| 1367 '(([default] . [italic]) | |
| 1368 ([bold] . [bold-italic]) | |
| 1369 ([italic] . [bold-italic]) | |
| 1370 ([bold-italic] . t)))) | |
| 428 | 1371 |
| 872 | 1372 |
| 1373 (defun make-face-unbold (face &optional locale tags exact-p) | |
| 428 | 1374 "Make FACE non-bold in LOCALE, if possible. |
| 442 | 1375 This will attempt to make the font non-bold for X/MS Windows locales |
| 1376 and will unset the highlight flag for TTY locales. See | |
| 1377 `make-face-bold' for the semantics of the LOCALE argument and for more | |
| 1378 specifics on exactly how this function works." | |
| 428 | 1379 (interactive (list (read-face-name "Make which face non-bold: "))) |
| 872 | 1380 (Face-frob-property face locale tags exact-p |
| 1381 'bold 'default 'font '(highlight) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1382 '(tty (lambda (f d) nil) |
| 872 | 1383 x x-make-font-unbold |
| 1384 gtk gtk-make-font-unbold | |
| 1385 mswindows mswindows-make-font-unbold | |
| 1386 msprinter mswindows-make-font-unbold) | |
| 1387 '(([default] . t) | |
| 1388 ([bold] . [default]) | |
| 1389 ([italic] . t) | |
| 1390 ([bold-italic] . [italic])))) | |
| 428 | 1391 |
| 872 | 1392 (defun make-face-unitalic (face &optional locale tags exact-p) |
| 428 | 1393 "Make FACE non-italic in LOCALE, if possible. |
| 442 | 1394 This will attempt to make the font non-italic for X/MS Windows locales |
| 1395 and will unset the underline flag for TTY locales. See | |
| 1396 `make-face-bold' for the semantics of the LOCALE argument and for more | |
| 1397 specifics on exactly how this function works." | |
| 428 | 1398 (interactive (list (read-face-name "Make which face non-italic: "))) |
| 872 | 1399 (Face-frob-property face locale tags exact-p |
| 1400 'italic 'default 'font '(underline) | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1401 '(tty (lambda (f d) nil) |
| 872 | 1402 x x-make-font-unitalic |
| 1403 gtk gtk-make-font-unitalic | |
| 1404 mswindows mswindows-make-font-unitalic | |
| 1405 msprinter mswindows-make-font-unitalic) | |
| 1406 '(([default] . t) | |
| 1407 ([bold] . t) | |
| 1408 ([italic] . [default]) | |
| 1409 ([bold-italic] . [bold])))) | |
| 428 | 1410 |
| 1411 | |
| 707 | 1412 ;; Size frobbing |
| 1413 ;; Thx Jan Vroonhof, Ref xemacs-beta <87oflypbum.fsf@petteflet.ntlworld.com> | |
| 1137 | 1414 ;; Jan had a separate helper function |
| 872 | 1415 (defun make-face-size (face size &optional locale tags exact-p) |
| 1416 "Adjust FACE to SIZE in LOCALE, if possible." | |
| 1417 (interactive (list (read-face-name "Set size of which face: ") | |
| 1418 (read-number "Size to set: " t 10))) | |
| 1419 (Face-frob-property face locale tags exact-p | |
| 1420 nil nil 'font nil | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1421 ;; #### this code is duplicated in make-face-family |
| 872 | 1422 `(lambda (f d) |
| 1423 ;; keep the dependency on font.el for now | |
|
4764
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1424 ;; #### The filter on null d is a band-aid. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1425 ;; Frob-face-property should not be passing in |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1426 ;; null devices. |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1427 (unless (or (null d) (eq d 'tty)) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1428 (let ((fo (font-create-object f d))) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1429 (set-font-size fo ,size) |
|
dec62ca5a899
Prevent font frobbers from operating on TTY specs.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4741
diff
changeset
|
1430 (font-create-name fo d)))) |
| 872 | 1431 nil)) |
| 707 | 1432 |
| 428 | 1433 ;; Why do the following two functions lose so badly in so many |
| 1434 ;; circumstances? | |
| 1435 | |
| 872 | 1436 (defun make-face-smaller (face &optional locale tags exact-p) |
| 428 | 1437 "Make the font of FACE be smaller, if possible. |
| 1438 LOCALE works as in `make-face-bold' et al., but the ``inheriting- | |
| 1439 from-the-bold-face'' operations described there are not done | |
| 1440 because they don't make sense in this context." | |
| 1441 (interactive (list (read-face-name "Shrink which face: "))) | |
| 872 | 1442 (Face-frob-property face locale tags exact-p |
| 1443 nil nil 'font nil | |
| 1444 '(x x-find-smaller-font | |
| 1445 gtk gtk-find-smaller-font | |
| 1446 mswindows mswindows-find-smaller-font | |
| 1447 msprinter mswindows-find-smaller-font) | |
| 1448 nil)) | |
| 428 | 1449 |
| 872 | 1450 (defun make-face-larger (face &optional locale tags exact-p) |
| 428 | 1451 "Make the font of FACE be larger, if possible. |
| 1452 See `make-face-smaller' for the semantics of the LOCALE argument." | |
| 1453 (interactive (list (read-face-name "Enlarge which face: "))) | |
| 872 | 1454 (Face-frob-property face locale tags exact-p |
| 1455 nil nil 'font nil | |
| 1456 '(x x-find-larger-font | |
| 1457 gtk gtk-find-larger-font | |
| 1458 mswindows mswindows-find-larger-font | |
| 1459 msprinter mswindows-find-larger-font) | |
| 1460 nil)) | |
| 428 | 1461 |
| 1462 (defun invert-face (face &optional locale) | |
| 1463 "Swap the foreground and background colors of the face." | |
| 1464 (interactive (list (read-face-name "Invert face: "))) | |
| 1465 (if (valid-specifier-domain-p locale) | |
| 1466 (let ((foreface (face-foreground-instance face locale))) | |
| 1467 (set-face-foreground face (face-background-instance face locale) | |
| 1468 locale) | |
| 1469 (set-face-background face foreface locale)) | |
| 1470 (let ((forespec (copy-specifier (face-foreground face) nil locale))) | |
| 1471 (copy-specifier (face-background face) (face-foreground face) locale) | |
| 1472 (copy-specifier forespec (face-background face) locale)))) | |
| 1473 | |
| 1474 | |
| 1475 ;;; Convenience functions | |
| 1476 | |
| 1477 (defun face-ascent (face &optional domain charset) | |
| 1478 "Return the ascent of FACE in DOMAIN. | |
| 1479 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1480 (font-ascent (face-font face) domain charset)) | |
| 1481 | |
| 1482 (defun face-descent (face &optional domain charset) | |
| 1483 "Return the descent of FACE in DOMAIN. | |
| 1484 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1485 (font-descent (face-font face) domain charset)) | |
| 1486 | |
| 1487 (defun face-width (face &optional domain charset) | |
| 1488 "Return the width of FACE in DOMAIN. | |
| 1489 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1490 (font-width (face-font face) domain charset)) | |
| 1491 | |
| 1492 (defun face-height (face &optional domain charset) | |
| 1493 "Return the height of FACE in DOMAIN. | |
| 1494 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1495 (+ (face-ascent face domain charset) (face-descent face domain charset))) | |
| 1496 | |
| 1497 (defun face-proportional-p (face &optional domain charset) | |
| 1498 "Return t if FACE is proportional in DOMAIN. | |
| 1499 See `face-property-instance' for the semantics of the DOMAIN argument." | |
| 1500 (font-proportional-p (face-font face) domain charset)) | |
| 1501 | |
| 1502 | |
| 1503 ;; Functions that used to be in cus-face.el, but logically go here. | |
| 1504 | |
| 1505 (defcustom frame-background-mode nil | |
| 1506 "*The brightness of the background. | |
| 1507 Set this to the symbol dark if your background color is dark, light if | |
| 1508 your background is light, or nil (default) if you want Emacs to | |
| 1509 examine the brightness for you." | |
| 1510 :group 'faces | |
| 1511 :type '(choice (choice-item dark) | |
| 1512 (choice-item light) | |
| 1513 (choice-item :tag "Auto" nil))) | |
| 1514 | |
| 1515 ;; The old variable that many people still have in .emacs files. | |
| 1516 (define-obsolete-variable-alias 'custom-background-mode | |
| 1517 'frame-background-mode) | |
| 1518 | |
| 1519 (defun get-frame-background-mode (frame) | |
| 1520 "Detect background mode for FRAME." | |
| 1521 (let* ((color-instance (face-background-instance 'default frame)) | |
| 1522 (mode (condition-case nil | |
| 1523 (if (< (apply '+ (color-instance-rgb-components | |
| 1524 color-instance)) 65536) | |
| 1525 'dark 'light) | |
| 872 | 1526 ;; Here, we get an error on a TTY (Return value from |
| 1527 ;; color-instance-rgb-components is nil), and on the | |
| 1528 ;; initial stream device (Return value from | |
| 1529 ;; face-background-instance is nil). As we don't have a | |
| 1530 ;; good way of detecting whether a TTY is light or dark, | |
| 1531 ;; we'll guess it's dark. | |
| 428 | 1532 (error 'dark)))) |
| 1533 (set-frame-property frame 'background-mode mode) | |
| 1534 mode)) | |
| 1535 | |
| 1536 (defun extract-custom-frame-properties (frame) | |
| 1537 "Return a plist with the frame properties of FRAME used by custom." | |
| 1538 (list 'type (or (frame-property frame 'display-type) | |
| 1539 (device-type (frame-device frame))) | |
| 1540 'class (device-class (frame-device frame)) | |
| 1541 'background (or frame-background-mode | |
| 1542 (frame-property frame 'background-mode) | |
| 1543 (get-frame-background-mode frame)))) | |
| 1544 | |
| 1545 (defcustom init-face-from-resources t | |
| 1546 "If non nil, attempt to initialize faces from the resource database." | |
| 1547 :group 'faces | |
| 1548 :type 'boolean) | |
| 1549 | |
| 1550 ;; Old name, used by custom. Also, FSFmacs name. | |
| 1551 (defvaralias 'initialize-face-resources 'init-face-from-resources) | |
| 1552 | |
| 1553 ;; Make sure all custom setting are added with this tag so we can | |
| 1554 ;; identify-them | |
| 1555 (define-specifier-tag 'custom) | |
| 1556 | |
| 1557 (defun face-spec-set (face spec &optional frame tags) | |
| 1558 "Set FACE's face attributes according to the first matching entry in SPEC. | |
| 1559 If optional FRAME is non-nil, set it for that frame only. | |
| 1560 If it is nil, then apply SPEC to each frame individually. | |
| 1561 See `defface' for information about SPEC." | |
| 1562 (if frame | |
| 1563 (progn | |
| 1564 (reset-face face frame tags) | |
| 1565 (face-display-set face spec frame tags) | |
| 1566 (init-face-from-resources face frame)) | |
| 1567 (let ((frames (relevant-custom-frames))) | |
| 1568 (reset-face face nil tags) | |
| 1569 ;; This should not be needed. We only remove our own specifiers | |
| 1570 ;; (if (and (eq 'default face) (featurep 'x)) | |
| 1571 ;; (x-init-global-faces)) | |
| 1572 (face-display-set face spec nil tags) | |
| 1573 (while frames | |
| 1574 (face-display-set face spec (car frames) tags) | |
| 1575 (pop frames)) | |
| 1576 (init-face-from-resources face)))) | |
| 1577 | |
| 1578 (defun face-display-set (face spec &optional frame tags) | |
| 1579 "Set FACE to the attributes to the first matching entry in SPEC. | |
| 1580 Iff optional FRAME is non-nil, set it for that frame only. | |
| 1581 See `defface' for information about SPEC." | |
| 1582 (while spec | |
| 1583 (let ((display (caar spec)) | |
| 1584 (atts (cadar spec))) | |
| 1585 (pop spec) | |
| 1586 (when (face-spec-set-match-display display frame) | |
| 1587 ;; Avoid creating frame local duplicates of the global face. | |
| 1588 (unless (and frame (eq display (get face 'custom-face-display))) | |
| 1589 (apply 'face-custom-attributes-set face frame tags atts)) | |
| 1590 (unless frame | |
| 1591 (put face 'custom-face-display display)) | |
| 1592 (setq spec nil))))) | |
| 1593 | |
| 1594 (defvar default-custom-frame-properties nil | |
| 1595 "The frame properties used for the global faces. | |
| 442 | 1596 Frames not matching these properties should have frame local faces. |
| 428 | 1597 The value should be nil, if uninitialized, or a plist otherwise. |
| 1598 See `defface' for a list of valid keys and values for the plist.") | |
| 1599 | |
| 1600 (defun get-custom-frame-properties (&optional frame) | |
| 1601 "Return a plist with the frame properties of FRAME used by custom. | |
| 1602 If FRAME is nil, return the default frame properties." | |
| 1603 (cond (frame | |
| 1604 ;; Try to get from cache. | |
| 1605 (let ((cache (frame-property frame 'custom-properties))) | |
| 1606 (unless cache | |
| 1607 ;; Oh well, get it then. | |
| 1608 (setq cache (extract-custom-frame-properties frame)) | |
| 1609 ;; and cache it... | |
| 1610 (set-frame-property frame 'custom-properties cache)) | |
| 1611 cache)) | |
| 1612 (default-custom-frame-properties) | |
| 1613 (t | |
| 1614 (setq default-custom-frame-properties | |
| 1615 (extract-custom-frame-properties (selected-frame)))))) | |
| 1616 | |
| 1617 (defun face-spec-update-all-matching (spec display plist) | |
| 1618 "Update all entries in the face spec that could match display to | |
| 444 | 1619 have the entries from the new plist and return the new spec." |
| 428 | 1620 (mapcar |
| 1621 (lambda (e) | |
| 1622 (let ((entries (car e)) | |
| 1623 (options (cadr e)) | |
| 1624 (match t) | |
| 1625 dplist | |
| 1626 (new-options plist) | |
| 1627 ) | |
| 1628 (unless (eq display t) | |
| 1629 (mapc (lambda (arg) | |
| 1630 (setq dplist (plist-put dplist (car arg) (cadr arg)))) | |
| 1631 display)) | |
| 1632 (unless (eq entries t) | |
| 1633 (mapc (lambda (arg) | |
| 1634 (setq match (and match (eq (cadr arg) | |
| 1635 (plist-get | |
| 1636 dplist (car arg) | |
| 1637 (cadr arg)))))) | |
| 1638 entries)) | |
| 1639 (if (not match) | |
| 1640 e | |
| 1641 (while new-options | |
| 1642 (setq options | |
| 1643 (plist-put options (car new-options) (cadr new-options))) | |
| 1644 (setq new-options (cddr new-options))) | |
| 1645 (list entries options)))) | |
| 1646 (copy-sequence spec))) | |
| 444 | 1647 |
| 1648 | |
| 428 | 1649 |
| 1650 (defun face-spec-set-match-display (display &optional frame) | |
| 1651 "Return non-nil if DISPLAY matches FRAME. | |
| 1652 DISPLAY is part of a spec such as can be used in `defface'. | |
| 1653 If FRAME is nil or omitted, the selected frame is used." | |
| 1654 (if (eq display t) | |
| 1655 t | |
| 1656 (let* ((props (get-custom-frame-properties frame)) | |
| 1657 (type (plist-get props 'type)) | |
| 1658 (class (plist-get props 'class)) | |
| 1659 (background (plist-get props 'background)) | |
| 1660 (match t) | |
| 1661 (entries display) | |
| 1662 entry req options) | |
| 1663 (while (and entries match) | |
| 1664 (setq entry (car entries) | |
| 1665 entries (cdr entries) | |
| 1666 req (car entry) | |
| 1667 options (cdr entry) | |
| 1668 match (case req | |
| 1669 (type (memq type options)) | |
| 1670 (class (memq class options)) | |
| 1671 (background (memq background options)) | |
| 1672 (t (warn "Unknown req `%S' with options `%S'" | |
| 1673 req options) | |
| 1674 nil)))) | |
| 1675 match))) | |
| 1676 | |
| 1677 (defun relevant-custom-frames () | |
| 1678 "List of frames whose custom properties differ from the default." | |
| 1679 (let ((relevant nil) | |
| 1680 (default (get-custom-frame-properties)) | |
| 1681 (frames (frame-list)) | |
| 1682 frame) | |
| 1683 (while frames | |
| 1684 (setq frame (car frames) | |
| 1685 frames (cdr frames)) | |
| 1686 (unless (equal default (get-custom-frame-properties frame)) | |
| 1687 (push frame relevant))) | |
| 1688 relevant)) | |
| 1689 | |
| 1690 (defun initialize-custom-faces (&optional frame) | |
| 1691 "Initialize all custom faces for FRAME. | |
| 1692 If FRAME is nil or omitted, initialize them for all frames." | |
| 1693 (mapc (lambda (symbol) | |
| 1694 (let ((spec (or (get symbol 'saved-face) | |
| 1695 (get symbol 'face-defface-spec)))) | |
| 1696 (when spec | |
| 1697 ;; No need to init-face-from-resources -- code in | |
| 1698 ;; `init-frame-faces' does it already. | |
| 1699 (face-display-set symbol spec frame)))) | |
| 1700 (face-list))) | |
| 1701 | |
| 1702 (defun custom-initialize-frame (frame) | |
| 1703 "Initialize frame-local custom faces for FRAME if necessary." | |
| 1704 (unless (equal (get-custom-frame-properties) | |
| 1705 (get-custom-frame-properties frame)) | |
| 1706 (initialize-custom-faces frame))) | |
| 1707 | |
| 440 | 1708 (defun startup-initialize-custom-faces () |
| 1709 "Reset faces created by defface. Only called at startup. | |
| 1710 Don't use this function in your program." | |
| 1711 (when default-custom-frame-properties | |
| 1712 ;; Reset default value to the actual frame, not stream. | |
| 1713 (setq default-custom-frame-properties | |
| 1714 (extract-custom-frame-properties (selected-frame))) | |
| 1715 ;; like initialize-custom-faces but removes property first. | |
| 1716 (mapc (lambda (symbol) | |
| 1717 (let ((spec (or (get symbol 'saved-face) | |
| 1718 (get symbol 'face-defface-spec)))) | |
| 1719 (when spec | |
| 1720 ;; Reset faces created during auto-autoloads loading. | |
| 1721 (reset-face symbol) | |
| 1722 ;; And set it according to the spec. | |
| 1723 (face-display-set symbol spec nil)))) | |
| 1724 (face-list)))) | |
| 1725 | |
| 428 | 1726 |
| 1727 (defun make-empty-face (name &optional doc-string temporary) | |
| 1728 "Like `make-face', but doesn't query the resource database." | |
| 1729 (let ((init-face-from-resources nil)) | |
| 1730 (make-face name doc-string temporary))) | |
| 1731 | |
| 1732 (defun init-face-from-resources (face &optional locale) | |
| 1733 "Initialize FACE from the resource database. | |
| 3027 | 1734 If LOCALE is specified, it should be a frame, device, or `global', and |
| 428 | 1735 the face will be resourced over that locale. Otherwise, the face will |
| 1736 be resourced over all possible locales (i.e. all frames, all devices, | |
| 3027 | 1737 and `global')." |
| 428 | 1738 (cond ((null init-face-from-resources) |
| 1739 ;; Do nothing. | |
| 1740 ) | |
| 1741 ((not locale) | |
| 1742 ;; Global, set for all frames. | |
| 1743 (progn | |
| 1744 (init-face-from-resources face 'global) | |
| 1745 (let ((devices (device-list))) | |
| 1746 (while devices | |
| 1747 (init-face-from-resources face (car devices)) | |
| 1748 (setq devices (cdr devices)))) | |
| 1749 (let ((frames (frame-list))) | |
| 1750 (while frames | |
| 1751 (init-face-from-resources face (car frames)) | |
| 1752 (setq frames (cdr frames)))))) | |
| 1753 (t | |
| 1754 ;; Specific. | |
| 1755 (let ((devtype (cond ((devicep locale) (device-type locale)) | |
| 1756 ((framep locale) (frame-type locale)) | |
| 1757 (t nil)))) | |
| 1758 (cond ((or (and (not devtype) (featurep 'x)) (eq 'x devtype)) | |
| 502 | 1759 (declare-fboundp (x-init-face-from-resources face locale))) |
| 428 | 1760 ((or (not devtype) (eq 'tty devtype)) |
| 1761 ;; Nothing to do for TTYs? | |
| 1762 )))))) | |
| 1763 | |
| 1764 (defun init-device-faces (device) | |
| 1765 ;; First, add any device-local face resources. | |
| 1766 (when init-face-from-resources | |
| 1767 (loop for face in (face-list) do | |
| 1768 (init-face-from-resources face device)) | |
| 1769 ;; Then do any device-specific initialization. | |
| 1770 (cond ((eq 'x (device-type device)) | |
| 502 | 1771 (declare-fboundp (x-init-device-faces device))) |
| 462 | 1772 ((eq 'gtk (device-type device)) |
| 502 | 1773 (declare-fboundp (gtk-init-device-faces device))) |
| 428 | 1774 ((eq 'mswindows (device-type device)) |
| 502 | 1775 (declare-fboundp (mswindows-init-device-faces device))) |
| 428 | 1776 ;; Nothing to do for TTYs? |
| 1777 ) | |
| 1778 (or (eq 'stream (device-type device)) | |
| 1779 (init-other-random-faces device)))) | |
| 1780 | |
| 1781 (defun init-frame-faces (frame) | |
| 1782 (when init-face-from-resources | |
| 1783 ;; First, add any frame-local face resources. | |
| 1784 (loop for face in (face-list) do | |
| 1785 (init-face-from-resources face frame)) | |
| 1786 ;; Then do any frame-specific initialization. | |
| 1787 (cond ((eq 'x (frame-type frame)) | |
| 502 | 1788 (declare-fboundp (x-init-frame-faces frame))) |
| 462 | 1789 ((eq 'gtk (frame-type frame)) |
| 502 | 1790 (declare-fboundp (gtk-init-frame-faces frame))) |
| 428 | 1791 ((eq 'mswindows (frame-type frame)) |
| 502 | 1792 (declare-fboundp (mswindows-init-frame-faces frame))) |
| 428 | 1793 ;; Is there anything which should be done for TTY's? |
| 1794 ))) | |
| 1795 | |
| 872 | 1796 ;; Called when the first device created. |
| 428 | 1797 |
| 872 | 1798 (defun init-global-faces (device) |
| 1799 (let ((Face-frob-property-device-considered-current device)) | |
| 1800 ;; Look for global face resources. | |
| 1801 (loop for face in (face-list) do | |
| 1802 (init-face-from-resources face 'global)) | |
| 1803 ;; Further frobbing. | |
| 1804 (and (featurep 'x) (declare-fboundp (x-init-global-faces))) | |
| 1805 (and (featurep 'gtk) (declare-fboundp (gtk-init-global-faces))) | |
| 1806 (and (featurep 'mswindows) (declare-fboundp (mswindows-init-global-faces))) | |
| 462 | 1807 |
| 872 | 1808 ;; for bold and the like, make the global specification be bold etc. |
| 1809 ;; if the user didn't already specify a value. These will also be | |
| 1810 ;; frobbed further in init-other-random-faces. | |
| 1811 (unless (face-font 'bold 'global) | |
| 1812 (make-face-bold 'bold 'global)) | |
| 1813 ;; | |
| 1814 (unless (face-font 'italic 'global) | |
| 1815 (make-face-italic 'italic 'global)) | |
| 1816 ;; | |
| 428 | 1817 (unless (face-font 'bold-italic 'global) |
| 872 | 1818 (make-face-bold-italic 'bold-italic 'global) |
| 1819 (unless (face-font 'bold-italic 'global) | |
| 1820 (copy-face 'bold 'bold-italic) | |
| 1821 (make-face-italic 'bold-italic))) | |
| 428 | 1822 |
| 872 | 1823 (when (face-equal 'bold 'bold-italic device) |
| 1824 (copy-face 'italic 'bold-italic) | |
| 1825 (make-face-bold 'bold-italic)))) | |
| 428 | 1826 |
| 1827 | |
| 1828 ;; These warnings are there for a reason. Just specify your fonts | |
| 1829 ;; correctly. Deal with it. Additionally, one can use | |
| 1830 ;; `log-warning-minimum-level' instead of this. | |
| 1831 ;(defvar inhibit-font-complaints nil | |
| 1832 ; "Whether to suppress complaints about incomplete sets of fonts.") | |
| 1833 | |
| 1834 (defun face-complain-about-font (face device) | |
| 1835 (if (symbolp face) (setq face (symbol-name face))) | |
| 1836 ;; (if (not inhibit-font-complaints) | |
| 707 | 1837 ;; complaining for printers is generally annoying. |
| 1838 (unless (device-printer-p device) | |
| 1839 (display-warning | |
| 1840 'font | |
| 1841 (let ((default-name (face-font-name 'default device))) | |
| 1842 (format "%s: couldn't deduce %s %s version of the font | |
| 428 | 1843 %S. |
| 1844 | |
| 1845 Please specify X resources to make the %s face | |
| 1846 visually distinguishable from the default face. | |
| 1847 For example, you could add one of the following to $HOME/Emacs: | |
| 1848 | |
| 2703 | 1849 XEmacs.%s.attributeFont: -dt-*-medium-i-* |
| 428 | 1850 or |
| 2703 | 1851 XEmacs.%s.attributeForeground: hotpink\n" |
| 707 | 1852 invocation-name |
| 1853 (if (string-match "\\`[aeiouAEIOU]" face) "an" "a") | |
| 1854 face | |
| 1855 default-name | |
| 1856 face | |
| 1857 face | |
| 1858 face | |
| 1859 ))))) | |
| 428 | 1860 |
| 1861 | |
| 1862 ;; #### This is quite a mess. We should use the custom mechanism for | |
| 1863 ;; most of this stuff. Currently we don't do it, because Custom | |
| 1864 ;; doesn't use specifiers (yet.) FSF does it the Right Way. | |
| 1865 | |
| 1866 ;; For instance, the definition of `bold' should be something like | |
| 1867 ;; (defface bold ((t (:bold t))) "Bold text.") -- and `:bold t' should | |
| 1868 ;; make sure that everything works properly. | |
| 1869 | |
| 1870 (defun init-other-random-faces (device) | |
| 1871 "Initialize the colors and fonts of the bold, italic, bold-italic, | |
| 1872 zmacs-region, list-mode-item-selected, highlight, primary-selection, | |
| 1873 secondary-selection, and isearch faces when each device is created. If | |
| 1874 you want to add code to do stuff like this, use the create-device-hook." | |
| 1875 | |
| 1876 ;; try to make 'bold look different from the default on this device. | |
| 1877 ;; If that doesn't work at all, then issue a warning. | |
| 1878 (unless (face-differs-from-default-p 'bold device) | |
| 1879 (make-face-bold 'bold device) | |
| 1880 (unless (face-differs-from-default-p 'bold device) | |
| 1881 (make-face-unbold 'bold device) | |
| 1882 (unless (face-differs-from-default-p 'bold device) | |
| 1883 ;; the luser specified one of the bogus font names | |
| 1884 (face-complain-about-font 'bold device)))) | |
| 1885 | |
| 1886 ;; Similar for italic. | |
| 1887 ;; It's unreasonable to expect to be able to make a font italic all | |
| 1888 ;; the time. For many languages, italic is an alien concept. | |
| 1889 ;; Basically, because italic is not a globally meaningful concept, | |
| 440 | 1890 ;; the use of the italic face should really be obsoleted. |
| 428 | 1891 |
| 1892 ;; I disagree with above. In many languages, the concept of capital | |
| 1893 ;; letters is just as alien, and yet we use them. Italic is here to | |
| 1894 ;; stay. -hniksic | |
| 1895 | |
| 1896 ;; In a Solaris Japanese environment, there just aren't any italic | |
| 1897 ;; fonts - period. CDE recognizes this reality, and fonts | |
| 1898 ;; -dt-interface user-medium-r-normal-*-*-*-*-*-*-*-*-* don't come | |
| 1899 ;; in italic versions. So we first try to make the font bold before | |
| 1900 ;; complaining. | |
| 1901 (unless (face-differs-from-default-p 'italic device) | |
| 1902 (make-face-italic 'italic device) | |
| 1903 (unless (face-differs-from-default-p 'italic device) | |
| 1904 (make-face-bold 'italic device) | |
| 1905 (unless (face-differs-from-default-p 'italic device) | |
| 1906 (face-complain-about-font 'italic device)))) | |
| 1907 | |
| 1908 ;; similar for bold-italic. | |
| 1909 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1910 (make-face-bold-italic 'bold-italic device) | |
| 1911 ;; if we couldn't get a bold-italic version, try just bold. | |
| 1912 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1913 (make-face-bold 'bold-italic device) | |
| 1914 ;; if we couldn't get bold or bold-italic, then that's probably because | |
| 1915 ;; the default font is bold, so make the `bold-italic' face be unbold. | |
| 1916 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1917 (make-face-unbold 'bold-italic device) | |
| 1918 (make-face-italic 'bold-italic device) | |
| 1919 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1920 ;; if that didn't work, try plain italic | |
| 1921 ;; (can this ever happen? what the hell.) | |
| 1922 (make-face-italic 'bold-italic device) | |
| 1923 (unless (face-differs-from-default-p 'bold-italic device) | |
| 1924 ;; then bitch and moan. | |
| 1925 (face-complain-about-font 'bold-italic device)))))) | |
| 1926 | |
| 1927 ;; Set the text-cursor colors unless already specified. | |
| 1928 (when (and (not (eq 'tty (device-type device))) | |
| 1929 (not (face-background 'text-cursor 'global)) | |
| 1930 (face-property-equal 'text-cursor 'default 'background device)) | |
| 1931 (set-face-background 'text-cursor [default foreground] 'global | |
| 1932 nil 'append)) | |
| 1933 (when (and (not (eq 'tty (device-type device))) | |
| 1934 (not (face-foreground 'text-cursor 'global)) | |
| 1935 (face-property-equal 'text-cursor 'default 'foreground device)) | |
| 1936 (set-face-foreground 'text-cursor [default background] 'global | |
| 1937 nil 'append)) | |
|
4741
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1938 |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1939 ;; The faces buffers-tab, modeline-mousable and modeline-buffer-id all |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1940 ;; inherit directly from modeline; they require that modeline's details be |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1941 ;; specified, that it not use fallbacks, otherwise *they* use the general |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1942 ;; fallback of the default face instead, which clashes with the gui |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1943 ;; element faces. So take the modeline face information from its |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1944 ;; fallbacks, themselves ultimately set up in faces.c: |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1945 (loop |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1946 for face-property in '(foreground background background-pixmap) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1947 do (when (and (setq face-property (face-property 'modeline face-property)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1948 (null (specifier-instance face-property device nil t)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1949 (specifier-instance face-property device)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1950 (set-specifier face-property |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1951 (or (specifier-specs (specifier-fallback |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1952 face-property)) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1953 ;; This will error at startup if the |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1954 ;; corresponding C fallback doesn't exist, |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1955 ;; which is well and good. |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1956 (specifier-fallback (specifier-fallback |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1957 face-property)))))) |
|
e14f9fdd5096
Fix modeline-mousable, other faces that inherit from modeline, on startup.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4676
diff
changeset
|
1958 nil) |
| 428 | 1959 |
| 442 | 1960 ;; New function with 20.1, suggested by Per Abrahamsen, coded by Kyle |
| 1961 ;; Jones and Hrvoje Niksic. | |
| 428 | 1962 (defun set-face-stipple (face pixmap &optional frame) |
| 1963 "Change the stipple pixmap of FACE to PIXMAP. | |
| 1964 This is an Emacs compatibility function; consider using | |
| 1965 set-face-background-pixmap instead. | |
| 1966 | |
| 1967 PIXMAP should be a string, the name of a file of pixmap data. | |
| 442 | 1968 The directories listed in the variables `x-bitmap-file-path' and |
| 1969 `mswindows-bitmap-file-path' under X and MS Windows respectively | |
| 1970 are searched. | |
| 428 | 1971 |
| 1972 Alternatively, PIXMAP may be a list of the form (WIDTH HEIGHT | |
| 1973 DATA) where WIDTH and HEIGHT are the size in pixels, and DATA is | |
| 1974 a string, containing the raw bits of the bitmap. XBM data is | |
| 1975 expected in this case, other types of image data will not work. | |
| 1976 | |
| 1977 If the optional FRAME argument is provided, change only | |
| 1978 in that frame; otherwise change each frame." | |
| 1979 (while (not (find-face face)) | |
| 446 | 1980 (setq face (wrong-type-argument 'facep face))) |
| 502 | 1981 (let ((bitmap-path |
| 1982 (ecase (console-type) | |
| 1983 (x (declare-boundp x-bitmap-file-path)) | |
| 1984 (mswindows (declare-boundp mswindows-bitmap-file-path)))) | |
| 442 | 1985 instantiator) |
| 1986 (while | |
| 1987 (null | |
| 1988 (setq instantiator | |
| 1989 (cond ((stringp pixmap) | |
| 1990 (let ((file (if (file-name-absolute-p pixmap) | |
| 1991 pixmap | |
| 1992 (locate-file pixmap bitmap-path | |
| 1993 '(".xbm" ""))))) | |
| 1994 (and file | |
| 1995 `[xbm :file ,file]))) | |
| 1996 ((and (listp pixmap) (= (length pixmap) 3)) | |
| 1997 `[xbm :data ,pixmap]) | |
| 1998 (t nil)))) | |
| 1999 ;; We're signaling a continuable error; let's make sure the | |
| 2000 ;; function `stipple-pixmap-p' at least exists. | |
| 2001 (flet ((stipple-pixmap-p (pixmap) | |
| 2002 (or (stringp pixmap) | |
| 2003 (and (listp pixmap) (= (length pixmap) 3))))) | |
| 2004 (setq pixmap (signal 'wrong-type-argument | |
| 2005 (list 'stipple-pixmap-p pixmap))))) | |
| 446 | 2006 (check-type frame (or null frame)) |
| 442 | 2007 (set-face-background-pixmap face instantiator frame))) |
| 428 | 2008 |
| 2009 | |
| 2010 ;; Create the remaining standard faces now. This way, packages that we dump | |
| 2011 ;; can reference these faces as parents. | |
| 2012 ;; | |
| 2013 ;; The default, modeline, left-margin, right-margin, text-cursor, | |
| 2014 ;; and pointer faces are created in C. | |
| 2015 | |
| 2016 (make-face 'bold "Bold text.") | |
| 2017 (make-face 'italic "Italic text.") | |
| 2018 (make-face 'bold-italic "Bold-italic text.") | |
| 2019 (make-face 'underline "Underlined text.") | |
| 2020 (or (face-differs-from-default-p 'underline) | |
| 2021 (set-face-underline-p 'underline t 'global '(default))) | |
| 735 | 2022 (make-face 'zmacs-region "Used on highlighted region between point and mark.") |
| 428 | 2023 (make-face 'isearch "Used on region matched by isearch.") |
| 2024 (make-face 'isearch-secondary "Face to use for highlighting all matches.") | |
| 2025 (make-face 'list-mode-item-selected | |
| 2026 "Face for the selected list item in list-mode.") | |
| 2027 (make-face 'highlight "Highlight face.") | |
| 2028 (make-face 'primary-selection "Primary selection face.") | |
| 2029 (make-face 'secondary-selection "Secondary selection face.") | |
| 2030 | |
| 2031 ;; Several useful color faces. | |
| 2032 (dolist (color '(red green blue yellow)) | |
| 2033 (make-face color (concat (symbol-name color) " text.")) | |
| 2034 (set-face-foreground color (symbol-name color) nil 'color)) | |
| 2035 | |
| 2036 ;; Make some useful faces. This happens very early, before creating | |
| 2037 ;; the first non-stream device. | |
| 2038 | |
| 2039 (set-face-background 'text-cursor | |
| 711 | 2040 '(((win default) . "Red3")) |
| 428 | 2041 'global) |
| 2042 | |
| 2043 ;; some older X servers don't recognize "darkseagreen2" | |
| 2044 (set-face-background 'highlight | |
| 711 | 2045 '(((win default color) . "darkseagreen2") |
| 2046 ((win default color) . "green") | |
| 2047 ((win default grayscale) . "gray53")) | |
| 428 | 2048 'global) |
| 2049 (set-face-background-pixmap 'highlight | |
| 711 | 2050 '(((win default mono) . "gray1")) |
| 428 | 2051 'global) |
| 2052 | |
| 2053 (set-face-background 'zmacs-region | |
| 711 | 2054 '(((win default color) . "gray65") |
| 2055 ((win default grayscale) . "gray65")) | |
| 428 | 2056 'global) |
| 2057 (set-face-background-pixmap 'zmacs-region | |
| 711 | 2058 '(((win default mono) . "gray3")) |
| 428 | 2059 'global) |
| 2060 | |
| 2061 (set-face-background 'list-mode-item-selected | |
| 711 | 2062 '(((win default color) . "gray68") |
| 2063 ((win default grayscale) . "gray68") | |
| 2064 ((win default mono) . [default foreground])) | |
| 428 | 2065 'global) |
| 2066 (set-face-foreground 'list-mode-item-selected | |
| 711 | 2067 '(((win default mono) . [default background])) |
| 428 | 2068 'global) |
| 2069 | |
| 2070 (set-face-background 'primary-selection | |
| 711 | 2071 '(((win default color) . "gray65") |
| 2072 ((win default grayscale) . "gray65")) | |
| 428 | 2073 'global) |
| 2074 (set-face-background-pixmap 'primary-selection | |
| 711 | 2075 '(((win default mono) . "gray3")) |
| 428 | 2076 'global) |
| 2077 | |
| 2078 (set-face-background 'secondary-selection | |
| 711 | 2079 '(((win default color) . "paleturquoise") |
| 2080 ((win default color) . "green") | |
| 2081 ((win default grayscale) . "gray53")) | |
| 428 | 2082 'global) |
| 2083 (set-face-background-pixmap 'secondary-selection | |
| 711 | 2084 '(((win default mono) . "gray1")) |
| 428 | 2085 'global) |
| 2086 | |
| 2087 (set-face-background 'isearch | |
| 711 | 2088 '(((win default color) . "paleturquoise") |
| 2089 ((win default color) . "green")) | |
| 428 | 2090 'global) |
| 2091 | |
| 2092 ;; #### This should really, I mean *really*, be converted to some form | |
| 2093 ;; of `defface' one day. | |
| 2094 (set-face-foreground 'isearch-secondary | |
| 711 | 2095 '(((win default color) . "red3")) |
| 428 | 2096 'global) |
| 2097 | |
| 2098 ;; Define some logical color names to be used when reading the pixmap files. | |
| 4222 | 2099 (and-boundp |
| 2100 'xpm-color-symbols | |
| 2101 (featurep 'xpm) | |
| 2102 (setq xpm-color-symbols | |
| 2103 (list | |
| 2104 '("foreground" (face-foreground 'default)) | |
| 2105 '("background" (face-background 'default)) | |
|
4676
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2106 `("backgroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2107 ,(if (featurep 'x) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2108 '(or (x-get-resource "backgroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2109 "BackgroundToolBarColor" 'string |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2110 nil nil 'warn) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2111 (face-background 'toolbar)) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2112 '(face-background 'toolbar))) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2113 `("foregroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2114 ,(if (featurep 'x) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2115 '(or (x-get-resource "foregroundToolBarColor" |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2116 "ForegroundToolBarColor" 'string |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2117 nil nil 'warn) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2118 (face-foreground 'toolbar)) |
|
e3feb329bda9
Make the initialisation of xpm-color-symbols a bit more reasonable.
Aidan Kehoe <kehoea@parhasard.net>
parents:
4670
diff
changeset
|
2119 '(face-foreground 'toolbar)))))) |
| 428 | 2120 |
| 2121 (when (featurep 'tty) | |
| 2122 (set-face-highlight-p 'bold t 'global '(default tty)) | |
| 2123 (set-face-underline-p 'italic t 'global '(default tty)) | |
| 2124 (set-face-highlight-p 'bold-italic t 'global '(default tty)) | |
| 2125 (set-face-underline-p 'bold-italic t 'global '(default tty)) | |
| 2126 (set-face-highlight-p 'highlight t 'global '(default tty)) | |
| 2127 (set-face-reverse-p 'text-cursor t 'global '(default tty)) | |
| 2128 (set-face-reverse-p 'modeline t 'global '(default tty)) | |
| 2129 (set-face-reverse-p 'zmacs-region t 'global '(default tty)) | |
| 2130 (set-face-reverse-p 'primary-selection t 'global '(default tty)) | |
| 2131 (set-face-underline-p 'secondary-selection t 'global '(default tty)) | |
| 2132 (set-face-reverse-p 'list-mode-item-selected t 'global '(default tty)) | |
| 2133 (set-face-reverse-p 'isearch t 'global '(default tty)) | |
| 2134 ) | |
| 2135 | |
| 2136 ;;; faces.el ends here |