git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/glyphs.el

   1 ;;; glyphs.el --- Lisp interface to C glyphs
   2
   3 ;; Copyright (C) 1994, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995, 1996 Ben Wing.
   5
   6 ;; Author: Chuck Thompson <cthomp@cs.uiuc.edu>, Ben Wing <ben@xemacs.org>
   7 ;; Maintainer: XEmacs Development Team
   8 ;; Keywords: extensions, 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, 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Synched up with: Not in FSF.
  28
  29 ;;; Commentary:
  30
  31 ;; This file is dumped with XEmacs.
  32
  33 ;;; Code:
  34
  35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; font specifiers
  36
  37 (defun make-image-specifier (spec-list)
  38   "Return a new `image' specifier object with the specification list SPEC-LIST.
  39 SPEC-LIST can be a list of specifications (each of which is a cons of a
  40 locale and a list of instantiators), a single instantiator, or a list
  41 of instantiators.  See `make-specifier' for more information about
  42 specifiers."
  43   (make-specifier-and-init 'image spec-list))
  44
  45 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; glyphs
  46
  47 (defconst built-in-glyph-specifiers
  48   '(image contrib-p baseline)
  49   "A list of the built-in face properties that are specifiers.")
  50
  51 (defun glyph-property (glyph property &optional locale)
  52   "Return GLYPH's value of PROPERTY in LOCALE.
  53
  54 If LOCALE is omitted, the GLYPH's actual value for PROPERTY will be
  55   returned.  For built-in properties, this will be a specifier object
  56   of a type appropriate to the property (e.g. a font or color
  57   specifier).  For other properties, this could be anything.
  58
  59 If LOCALE is supplied, then instead of returning the actual value,
  60   the specification(s) for the given locale or locale type will
  61   be returned.  This will only work if the actual value of
  62   PROPERTY is a specifier (this will always be the case for built-in
  63   properties, but not or not may apply to user-defined properties).
  64   If the actual value of PROPERTY is not a specifier, this value
  65   will simply be returned regardless of LOCALE.
  66
  67 The return value will be a list of instantiators (e.g. strings
  68   specifying a font or color name), or a list of specifications, each
  69   of which is a cons of a locale and a list of instantiators.
  70   Specifically, if LOCALE is a particular locale (a buffer, window,
  71   frame, device, or 'global), a list of instantiators for that locale
  72   will be returned.  Otherwise, if LOCALE is a locale type (one of
  73   the symbols 'buffer, 'window, 'frame, 'device, 'device-class, or
  74   'device-type), the specifications for all locales of that type will
  75   be returned.  Finally, if LOCALE is 'all, the specifications for all
  76   locales of all types will be returned.
  77
  78 The specifications in a specifier determine what the value of
  79   PROPERTY will be in a particular \"domain\" or set of circumstances,
  80   which is typically a particular Emacs window along with the buffer
  81   it contains and the frame and device it lies within.  The value
  82   is derived from the instantiator associated with the most specific
  83   locale (in the order buffer, window, frame, device, and 'global)
  84   that matches the domain in question.  In other words, given a domain
  85   (i.e. an Emacs window, usually), the specifier for PROPERTY will first
  86   be searched for a specification whose locale is the buffer contained
  87   within that window; then for a specification whose locale is the window
  88   itself; then for a specification whose locale is the frame that the
  89   window is contained within; etc.  The first instantiator that is
  90   valid for the domain (usually this means that the instantiator is
  91   recognized by the device [i.e. the X server or TTY device] that the
  92   domain is on.  The function `glyph-property-instance' actually does
  93   all this, and is used to determine how to display the glyph.
  94
  95 See `set-glyph-property' for the built-in property-names."
  96   (check-argument-type 'glyphp glyph)
  97   (let ((value (get glyph property)))
  98     (if (and locale
  99              (or (memq property built-in-glyph-specifiers)
 100                  (specifierp value)))
 101         (setq value (specifier-specs value locale)))
 102     value))
 103
 104 (defun convert-glyph-property-into-specifier (glyph property)
 105   "Convert PROPERTY on GLYPH into a specifier, if it's not already."
 106   (check-argument-type 'glyphp glyph)
 107   (let ((specifier (get glyph property)))
 108     ;; if a user-property does not have a specifier but a
 109     ;; locale was specified, put a specifier there.
 110     ;; If there was already a value there, convert it to a
 111     ;; specifier with the value as its 'global instantiator.
 112     (if (not (specifierp specifier))
 113         (let ((new-specifier (make-specifier 'generic)))
 114           (if (or (not (null specifier))
 115                   ;; make sure the nil returned from `get' wasn't
 116                   ;; actually the value of the property
 117                   (null (get glyph property t)))
 118               (add-spec-to-specifier new-specifier specifier))
 119           (setq specifier new-specifier)
 120           (put glyph property specifier)))))
 121
 122 (defun glyph-property-instance (glyph property
 123                                       &optional domain default no-fallback)
 124   "Return the instance of GLYPH's PROPERTY in the specified DOMAIN.
 125
 126 Under most circumstances, DOMAIN will be a particular window,
 127   and the returned instance describes how the specified property
 128   actually is displayed for that window and the particular buffer
 129   in it.  Note that this may not be the same as how the property
 130   appears when the buffer is displayed in a different window or
 131   frame, or how the property appears in the same window if you
 132   switch to another buffer in that window; and in those cases,
 133   the returned instance would be different.
 134
 135 DOMAIN defaults to the selected window if omitted.
 136
 137 DOMAIN can be a frame or device, instead of a window.  The value
 138   returned for a such a domain is used in special circumstances
 139   when a more specific domain does not apply; for example, a frame
 140   value might be used for coloring a toolbar, which is conceptually
 141   attached to a frame rather than a particular window.  The value
 142   is also useful in determining what the value would be for a
 143   particular window within the frame or device, if it is not
 144   overridden by a more specific specification.
 145
 146 If PROPERTY does not name a built-in property, its value will
 147   simply be returned unless it is a specifier object, in which case
 148   it will be instanced using `specifier-instance'.
 149
 150 Optional arguments DEFAULT and NO-FALLBACK are the same as in
 151   `specifier-instance'."
 152   (check-argument-type 'glyphp glyph)
 153   (let ((value (get glyph property)))
 154     (if (specifierp value)
 155         (setq value (specifier-instance value domain default no-fallback)))
 156     value))
 157
 158 (defun set-glyph-property (glyph property value &optional locale tag-set
 159                                  how-to-add)
 160   "Change a property of a GLYPH.
 161
 162 NOTE: If you want to remove a property from a glyph, use
 163   `remove-glyph-property' rather than attempting to set a value of nil
 164    for the property.
 165
 166 For built-in properties, the actual value of the property is a
 167   specifier and you cannot change this; but you can change the
 168   specifications within the specifier, and that is what this function
 169   will do.  For user-defined properties, you can use this function
 170   to either change the actual value of the property or, if this value
 171   is a specifier, change the specifications within it.
 172
 173 If PROPERTY is a built-in property, the specifications to be added to
 174   this property can be supplied in many different ways:
 175
 176   -- If VALUE is a simple instantiator (e.g. a string naming a font or
 177      color) or a list of instantiators, then the instantiator(s) will
 178      be added as a specification of the property for the given LOCALE
 179      (which defaults to 'global if omitted).
 180   -- If VALUE is a list of specifications (each of which is a cons of
 181      a locale and a list of instantiators), then LOCALE must be nil
 182      (it does not make sense to explicitly specify a locale in this
 183      case), and specifications will be added as given.
 184   -- If VALUE is a specifier (as would be returned by `glyph-property'
 185      if no LOCALE argument is given), then some or all of the
 186      specifications in the specifier will be added to the property.
 187      In this case, the function is really equivalent to
 188      `copy-specifier' and LOCALE has the same semantics (if it is
 189      a particular locale, the specification for the locale will be
 190      copied; if a locale type, specifications for all locales of
 191      that type will be copied; if nil or 'all, then all
 192      specifications will be copied).
 193
 194 HOW-TO-ADD should be either nil or one of the symbols 'prepend,
 195   'append, 'remove-tag-set-prepend, 'remove-tag-set-append, 'remove-locale,
 196   'remove-locale-type, or 'remove-all.  See `copy-specifier' and
 197   `add-spec-to-specifier' for a description of what each of
 198   these means.  Most of the time, you do not need to worry about
 199   this argument; the default behavior usually is fine.
 200
 201 In general, it is OK to pass an instance object (e.g. as returned
 202   by `glyph-property-instance') as an instantiator in place of
 203   an actual instantiator.  In such a case, the instantiator used
 204   to create that instance object will be used (for example, if
 205   you set a font-instance object as the value of the 'font
 206   property, then the font name used to create that object will
 207   be used instead).  If some cases, however, doing this
 208   conversion does not make sense, and this will be noted in
 209   the documentation for particular types of instance objects.
 210
 211 If PROPERTY is not a built-in property, then this function will
 212   simply set its value if LOCALE is nil.  However, if LOCALE is
 213   given, then this function will attempt to add VALUE as the
 214   instantiator for the given LOCALE, using `add-spec-to-specifier'.
 215   If the value of the property is not a specifier, it will
 216   automatically be converted into a 'generic specifier.
 217
 218
 219 The following symbols have predefined meanings:
 220
 221  image          The image used to display the glyph.
 222
 223  baseline       Percent above baseline that glyph is to be
 224                 displayed.
 225
 226  contrib-p      Whether the glyph contributes to the
 227                 height of the line it's on.
 228
 229  face           Face of this glyph (*not* a specifier)."
 230   (check-argument-type 'glyphp glyph)
 231   (if (memq property built-in-glyph-specifiers)
 232       (set-specifier (get glyph property) value locale tag-set how-to-add)
 233
 234     ;; This section adds user defined properties.
 235     (if (not locale)
 236         (put glyph property value)
 237       (convert-glyph-property-into-specifier glyph property)
 238       (add-spec-to-specifier (get glyph property) value locale tag-set
 239                              how-to-add)))
 240   value)
 241
 242 (defun remove-glyph-property (glyph property &optional locale tag-set exact-p)
 243   "Remove a property from a glyph.
 244 For built-in properties, this is analogous to `remove-specifier'.
 245 See `remove-specifier' for the meaning of the LOCALE, TAG-SET, and EXACT-P
 246   arguments."
 247   (or locale (setq locale 'all))
 248   (if (memq property built-in-glyph-specifiers)
 249       (remove-specifier (glyph-property glyph property) locale tag-set exact-p)
 250     (if (eq locale 'all)
 251         (remprop glyph property)
 252       (convert-glyph-property-into-specifier glyph property)
 253       (remove-specifier (glyph-property glyph property) locale tag-set
 254                         exact-p))))
 255
 256 (defun glyph-face (glyph)
 257   "Return the face of GLYPH."
 258   (glyph-property glyph 'face))
 259
 260 (defun set-glyph-face (glyph face)
 261   "Change the face of GLYPH to FACE."
 262 ;  (interactive (glyph-interactive "face"))
 263   (set-glyph-property glyph 'face face))
 264
 265 (defun glyph-image (glyph &optional locale)
 266   "Return the image of GLYPH in LOCALE, or nil if it is unspecified.
 267
 268 LOCALE may be a locale (the instantiators for that particular locale
 269   will be returned), a locale type (the specifications for all locales
 270   of that type will be returned), 'all (all specifications will be
 271   returned), or nil (the actual specifier object will be returned).
 272
 273 See `glyph-property' for more information."
 274   (glyph-property glyph 'image locale))
 275
 276 (defun glyph-image-instance (glyph &optional domain default no-fallback)
 277   "Return the instance of GLYPH's image in DOMAIN.
 278
 279 Normally DOMAIN will be a window or nil (meaning the selected window),
 280   and an instance object describing how the image appears in that
 281   particular window and buffer will be returned.
 282
 283 See `glyph-property-instance' for more information."
 284   (glyph-property-instance glyph 'image domain default no-fallback))
 285
 286 (defun set-glyph-image (glyph spec &optional locale tag-set how-to-add)
 287   "Change the image of GLYPH in LOCALE.
 288
 289 SPEC should be an instantiator (a string or vector; see
 290   `image-specifier-p' for a description of possible values here),
 291   a list of (possibly tagged) instantiators, an alist of specifications
 292   (each mapping a locale to an instantiator list), or an image specifier
 293   object.
 294
 295 If SPEC is an alist, LOCALE must be omitted.  If SPEC is a
 296   specifier object, LOCALE can be a locale, a locale type, 'all,
 297   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 298   specifies the locale under which the specified instantiator(s)
 299   will be added, and defaults to 'global.
 300
 301 See `set-glyph-property' for more information."
 302   ; (interactive (glyph-interactive "image"))
 303   (set-glyph-property glyph 'image spec locale tag-set how-to-add))
 304
 305 (defun glyph-contrib-p (glyph &optional locale)
 306   "Return whether GLYPH contributes to its line height.
 307
 308 LOCALE may be a locale (the instantiators for that particular locale
 309   will be returned), a locale type (the specifications for all locales
 310   of that type will be returned), 'all (all specifications will be
 311   returned), or nil (the actual specifier object will be returned).
 312
 313 See `glyph-property' for more information."
 314   (glyph-property glyph 'contrib-p locale))
 315
 316 (defun glyph-contrib-p-instance (glyph &optional domain default no-fallback)
 317   "Return the instance of GLYPH's 'contrib-p property in DOMAIN.
 318
 319 Normally DOMAIN will be a window or nil (meaning the selected window),
 320   and an instance object describing what the 'contrib-p property is in
 321   that particular window and buffer will be returned.
 322
 323 See `glyph-property-instance' for more information."
 324   (glyph-property-instance glyph 'contrib-p domain default no-fallback))
 325
 326 (defun set-glyph-contrib-p (glyph spec &optional locale tag-set how-to-add)
 327   "Change the contrib-p property of GLYPH in LOCALE.
 328
 329 SPEC should be an instantiator (t or nil), a list of (possibly
 330   tagged) instantiators, an alist of specifications (each mapping a
 331   locale to an instantiator list), or a boolean specifier object.
 332
 333 If SPEC is an alist, LOCALE must be omitted.  If SPEC is a
 334   specifier object, LOCALE can be a locale, a locale type, 'all,
 335   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 336   specifies the locale under which the specified instantiator(s)
 337   will be added, and defaults to 'global.
 338
 339 See `set-glyph-property' for more information."
 340   ; (interactive (glyph-interactive "contrib-p"))
 341   (set-glyph-property glyph 'contrib-p spec locale tag-set how-to-add))
 342
 343 (defun glyph-baseline (glyph &optional locale)
 344   "Return the baseline of GLYPH in LOCALE, or nil if it is unspecified.
 345
 346 LOCALE may be a locale (the instantiators for that particular locale
 347   will be returned), a locale type (the specifications for all locales
 348   of that type will be returned), 'all (all specifications will be
 349   returned), or nil (the actual specifier object will be returned).
 350
 351 See `glyph-property' for more information."
 352   (glyph-property glyph 'baseline locale))
 353
 354 (defun glyph-baseline-instance (glyph &optional domain default no-fallback)
 355   "Return the instance of GLYPH's baseline in DOMAIN.
 356
 357 Normally DOMAIN will be a window or nil (meaning the selected window),
 358   and an integer or nil (specifying the baseline in that particular
 359   window and buffer) will be returned.
 360
 361 See `glyph-property-instance' for more information."
 362   (glyph-property-instance glyph 'baseline domain default no-fallback))
 363
 364 (defun set-glyph-baseline (glyph spec &optional locale tag-set how-to-add)
 365   "Change the baseline of GLYPH to SPEC in LOCALE.
 366
 367 SPEC should be an instantiator (an integer [a percentage above the
 368   baseline of the line the glyph is on] or nil), a list of (possibly
 369   tagged) instantiators, an alist of specifications (each mapping a
 370   locale to an instantiator list), or a generic specifier object.
 371
 372 If SPEC is an alist, LOCALE must be omitted.  If SPEC is a
 373   specifier object, LOCALE can be a locale, a locale type, 'all,
 374   or nil; see `copy-specifier' for its semantics.  Otherwise LOCALE
 375   specifies the locale under which the specified instantiator(s)
 376   will be added, and defaults to 'global.
 377
 378 See `set-glyph-property' for more information."
 379   ; (interactive (glyph-interactive "baseline"))
 380   (set-glyph-property glyph 'baseline spec locale tag-set how-to-add))
 381
 382 (defun make-glyph (&optional spec-list type)
 383   "Return a new `glyph' object of type TYPE.
 384
 385 TYPE should be one of `buffer' (used for glyphs in an extent, the modeline,
 386 the toolbar, or elsewhere in a buffer), `pointer' (used for the mouse-pointer),
 387 or `icon' (used for a frame's icon), and defaults to `buffer'.
 388
 389 SPEC-LIST is used to initialize the glyph's image.  It is typically an
 390 image instantiator (a string or a vector; see `image-specifier-p' for
 391 a detailed description of the valid image instantiators), but can also
 392 be a list of such instantiators (each one in turn is tried until an
 393 image is successfully produced), a cons of a locale (frame, buffer, etc.)
 394 and an instantiator, a list of such conses, or any other form accepted
 395 by `canonicalize-spec-list'.  See `make-specifier' for more information
 396 about specifiers."
 397   (let ((glyph (make-glyph-internal type)))
 398     (and spec-list (set-glyph-image glyph spec-list))
 399     glyph))
 400
 401 (defun buffer-glyph-p (object)
 402   "Return t if OBJECT is a glyph of type `buffer'."
 403   (and (glyphp object) (eq 'buffer (glyph-type object))))
 404
 405 (defun pointer-glyph-p (object)
 406   "Return t if OBJECT is a glyph of type `pointer'."
 407   (and (glyphp object) (eq 'pointer (glyph-type object))))
 408
 409 (defun icon-glyph-p (object)
 410   "Return t if OBJECT is a glyph of type `icon'."
 411   (and (glyphp object) (eq 'icon (glyph-type object))))
 412
 413 (defun make-pointer-glyph (&optional spec-list)
 414   "Return a new `pointer-glyph' object with the specification list SPEC-LIST.
 415
 416 This is equivalent to calling `make-glyph', specifying a type of `pointer'.
 417
 418 SPEC-LIST is used to initialize the glyph's image.  It is typically an
 419 image instantiator (a string or a vector; see `image-specifier-p' for
 420 a detailed description of the valid image instantiators), but can also
 421 be a list of such instantiators (each one in turn is tried until an
 422 image is successfully produced), a cons of a locale (frame, buffer, etc.)
 423 and an instantiator, a list of such conses, or any other form accepted
 424 by `canonicalize-spec-list'.  See `make-specifier' for more information
 425 about specifiers.
 426
 427 You can also create a glyph with an empty SPEC-LIST and add image
 428 instantiators afterwards using `set-glyph-image'."
 429   (make-glyph spec-list 'pointer))
 430
 431 (defun make-icon-glyph (&optional spec-list)
 432   "Return a new `icon-glyph' object with the specification list SPEC-LIST.
 433
 434 This is equivalent to calling `make-glyph', specifying a type of `icon'.
 435
 436 SPEC-LIST is used to initialize the glyph's image.  It is typically an
 437 image instantiator (a string or a vector; see `image-specifier-p' for
 438 a detailed description of the valid image instantiators), but can also
 439 be a list of such instantiators (each one in turn is tried until an
 440 image is successfully produced), a cons of a locale (frame, buffer, etc.)
 441 and an instantiator, a list of such conses, or any other form accepted
 442 by `canonicalize-spec-list'.  See `make-specifier' for more information
 443 about specifiers.
 444
 445 You can also create a glyph with an empty SPEC-LIST and add image
 446 instantiators afterwards using `set-glyph-image'."
 447   (make-glyph spec-list 'icon))
 448
 449 (defun nothing-image-instance-p (object)
 450   "Return t if OBJECT is an image instance of type `nothing'."
 451   (and (image-instance-p object) (eq 'nothing (image-instance-type object))))
 452
 453 (defun text-image-instance-p (object)
 454   "Return t if OBJECT is an image instance of type `text'."
 455   (and (image-instance-p object) (eq 'text (image-instance-type object))))
 456
 457 (defun mono-pixmap-image-instance-p (object)
 458   "Return t if OBJECT is an image instance of type `mono-pixmap'."
 459   (and (image-instance-p object) (eq 'mono-pixmap
 460                                      (image-instance-type object))))
 461
 462 (defun color-pixmap-image-instance-p (object)
 463   "Return t if OBJECT is an image instance of type `color-pixmap'."
 464   (and (image-instance-p object) (eq 'color-pixmap
 465                                      (image-instance-type object))))
 466
 467 (defun pointer-image-instance-p (object)
 468   "Return t if OBJECT is an image instance of type `pointer'."
 469   (and (image-instance-p object) (eq 'pointer (image-instance-type object))))
 470
 471 (defun subwindow-image-instance-p (object)
 472   "Return t if OBJECT is an image instance of type `subwindow'.
 473 Subwindows are not implemented in this version of XEmacs."
 474   (and (image-instance-p object) (eq 'subwindow (image-instance-type object))))
 475
 476 ;;;;;;;;;; the built-in glyphs
 477
 478 (defvar text-pointer-glyph (make-pointer-glyph)
 479   "*The shape of the mouse-pointer when over text.
 480 This is a glyph; use `set-glyph-image' to change it.")
 481 (set-glyph-face text-pointer-glyph 'pointer)
 482
 483 (defvar nontext-pointer-glyph (make-pointer-glyph)
 484   "*The shape of the mouse-pointer when over a buffer, but not over text.
 485 This is a glyph; use `set-glyph-image' to change it.
 486 If unspecified in a particular domain, `text-pointer-glyph' is used.")
 487 (set-glyph-face nontext-pointer-glyph 'pointer)
 488
 489 (defvar modeline-pointer-glyph (make-pointer-glyph)
 490   "*The shape of the mouse-pointer when over the modeline.
 491 This is a glyph; use `set-glyph-image' to change it.
 492 If unspecified in a particular domain, `nontext-pointer-glyph' is used.")
 493 (set-glyph-face modeline-pointer-glyph 'pointer)
 494
 495 (defvar selection-pointer-glyph (make-pointer-glyph)
 496   "*The shape of the mouse-pointer when over a selectable text region.
 497 This is a glyph; use `set-glyph-image' to change it.
 498 If unspecified in a particular domain, `text-pointer-glyph' is used.")
 499 (set-glyph-face selection-pointer-glyph 'pointer)
 500
 501 (defvar busy-pointer-glyph (make-pointer-glyph)
 502   "*The shape of the mouse-pointer when XEmacs is busy.
 503 This is a glyph; use `set-glyph-image' to change it.
 504 If unspecified in a particular domain, the pointer is not changed
 505 when XEmacs is busy.")
 506 (set-glyph-face busy-pointer-glyph 'pointer)
 507
 508 (defvar toolbar-pointer-glyph (make-pointer-glyph)
 509   "*The shape of the mouse-pointer when over a toolbar.
 510 This is a glyph; use `set-glyph-image' to change it.
 511 If unspecified in a particular domain, `nontext-pointer-glyph' is used.")
 512 (set-glyph-face toolbar-pointer-glyph 'pointer)
 513
 514 (defvar divider-pointer-glyph (make-pointer-glyph)
 515   "*The shape of the mouse-pointer when over a window divider.
 516 This is a glyph; use `set-glyph-image' to change it.
 517 If unspecified in a particular domain, `nontext-pointer-glyph' is used.")
 518 (set-glyph-face divider-pointer-glyph 'pointer)
 519
 520 ;; The following three are in C.
 521 (if (featurep 'menubar)
 522     (set-glyph-face menubar-pointer-glyph 'pointer))
 523 (if (featurep 'scrollbar)
 524     (set-glyph-face scrollbar-pointer-glyph 'pointer))
 525 (set-glyph-face gc-pointer-glyph 'pointer)
 526
 527 ;; Now add the magic access/set behavior.
 528
 529 (defun dontusethis-set-value-glyph-handler (sym args fun harg handler)
 530   (error "Use `set-glyph-image' to set `%s'" sym))
 531 (defun dontusethis-make-unbound-glyph-handler (sym args fun harg handler)
 532   (error "Can't `makunbound' `%s'" sym))
 533 (defun dontusethis-make-local-glyph-handler (sym args fun harg handler)
 534   (error "Use `set-glyph-image' to make local values for `%s'" sym))
 535
 536 (defun define-constant-glyph (sym)
 537   (dontusethis-set-symbol-value-handler
 538    sym 'set-value
 539    'dontusethis-set-value-glyph-handler)
 540   (dontusethis-set-symbol-value-handler
 541    sym 'make-unbound
 542    'dontusethis-make-unbound-glyph-handler)
 543   (dontusethis-set-symbol-value-handler
 544    sym 'make-local
 545    'dontusethis-make-local-glyph-handler)
 546   ;; Make frame properties magically work with glyph variables.
 547   (put sym 'const-glyph-variable t))
 548
 549 (define-constant-glyph 'text-pointer-glyph)
 550 (define-constant-glyph 'nontext-pointer-glyph)
 551 (define-constant-glyph 'modeline-pointer-glyph)
 552 (define-constant-glyph 'selection-pointer-glyph)
 553 (define-constant-glyph 'busy-pointer-glyph)
 554 (define-constant-glyph 'gc-pointer-glyph)
 555 (define-constant-glyph 'divider-pointer-glyph)
 556 (define-constant-glyph 'toolbar-pointer-glyph)
 557 (define-constant-glyph 'menubar-pointer-glyph)
 558 (define-constant-glyph 'scrollbar-pointer-glyph)
 559
 560 (define-constant-glyph 'octal-escape-glyph)
 561 (define-constant-glyph 'control-arrow-glyph)
 562 (define-constant-glyph 'invisible-text-glyph)
 563 (define-constant-glyph 'hscroll-glyph)
 564 (define-constant-glyph 'truncation-glyph)
 565 (define-constant-glyph 'continuation-glyph)
 566
 567 (define-constant-glyph 'frame-icon-glyph)
 568
 569 ;; backwards compatibility garbage
 570
 571 (defun dontusethis-old-pointer-shape-handler (sym args fun harg handler)
 572   (let ((value (car args)))
 573     (if (null value)
 574         (remove-specifier harg 'global)
 575       (set-glyph-image (symbol-value harg) value))))
 576
 577 ;; It might or might not be garbage, but it's rude.  Make these
 578 ;; 'compatible instead of 'obsolete.  -slb
 579 (defun define-obsolete-pointer-glyph (old new)
 580   (define-compatible-variable-alias old new)
 581   (dontusethis-set-symbol-value-handler
 582    old 'set-value 'dontusethis-old-pointer-shape-handler new))
 583
 584 ;;; (defvar x-pointer-shape nil)
 585 (define-obsolete-pointer-glyph 'x-pointer-shape 'text-pointer-glyph)
 586
 587 ;;; (defvar x-nontext-pointer-shape nil)
 588 (define-obsolete-pointer-glyph 'x-nontext-pointer-shape 'nontext-pointer-glyph)
 589
 590 ;;; (defvar x-mode-pointer-shape nil)
 591 (define-obsolete-pointer-glyph 'x-mode-pointer-shape 'modeline-pointer-glyph)
 592
 593 ;;; (defvar x-selection-pointer-shape nil)
 594 (define-obsolete-pointer-glyph 'x-selection-pointer-shape
 595   'selection-pointer-glyph)
 596
 597 ;;; (defvar x-busy-pointer-shape nil)
 598 (define-obsolete-pointer-glyph 'x-busy-pointer-shape 'busy-pointer-glyph)
 599
 600 ;;; (defvar x-gc-pointer-shape nil)
 601 (define-obsolete-pointer-glyph 'x-gc-pointer-shape 'gc-pointer-glyph)
 602
 603 ;;; (defvar x-toolbar-pointer-shape nil)
 604 (define-obsolete-pointer-glyph 'x-toolbar-pointer-shape 'toolbar-pointer-glyph)
 605
 606 ;; for subwindows
 607 (defalias 'subwindow-xid 'image-instance-subwindow-id)
 608 (defalias 'subwindow-width 'image-instance-width)
 609 (defalias 'subwindow-height 'image-instance-height)
 610 ;;;;;;;;;; initialization
 611
 612 (defun init-glyphs ()
 613   ;; initialize default image types
 614   (if (featurep 'x)
 615     (set-console-type-image-conversion-list 'x
 616      `(,@(if (featurep 'xpm) '(("\\.xpm\\'" [xpm :file nil] 2)))
 617          ("\\.xbm\\'" [xbm :file nil] 2)
 618        ,@(if (featurep 'xpm) '(("\\`/\\* XPM \\*/" [xpm :data nil] 2)))
 619        ,@(if (featurep 'xface) '(("\\`X-Face:" [xface :data nil] 2)))
 620        ,@(if (featurep 'gif) '(("\\.gif\\'" [gif :file nil] 2)
 621                                ("\\`GIF8[79]" [gif :data nil] 2)))
 622        ,@(if (featurep 'jpeg) '(("\\.jpe?g\\'" [jpeg :file nil] 2)))
 623        ;; all of the JFIF-format JPEG's that I've seen begin with
 624        ;; the following.  I have no idea if this is standard.
 625        ,@(if (featurep 'jpeg) '(("\\`\377\330\377\340\000\020JFIF"
 626                                  [jpeg :data nil] 2)))
 627        ,@(if (featurep 'png) '(("\\.png\\'" [png :file nil] 2)))
 628        ,@(if (featurep 'png) '(("\\`\211PNG" [png :data nil] 2)))
 629        ("" [autodetect :data nil] 2))))
 630   ;; #### this should really be formatted-string, not string but we
 631   ;; don't have it implemented yet
 632   ;;
 633   ;; #define could also mean a bitmap as well as a version 1 XPM.  Who
 634   ;; cares.  We don't want the file contents getting converted to a
 635   ;; string in either case which is why the entry is there.
 636   (if (featurep 'tty)
 637       (progn
 638         (set-console-type-image-conversion-list
 639          'tty
 640          '(("^#define" [string :data "[xpm]"])
 641            ("\\`X-Face:" [string :data "[xface]"])
 642            ("\\`/\\* XPM \\*/" [string :data "[xpm]"])
 643            ("\\`GIF87" [string :data "[gif]"])
 644            ("\\`\377\330\340\000\020JFIF" [string :data "[jpeg]"])
 645            ("" [string :data nil] 2)
 646            ;; this last one is here for pointers and icons and such --
 647            ;; strings are not allowed so they will be ignored.
 648            ("" [nothing])))
 649
 650         ;; finish initializing truncation glyph -- created internally
 651         ;; because it has a built-in bitmap
 652         (set-glyph-image truncation-glyph "$" 'global 'tty)
 653
 654         ;; finish initializing continuation glyph -- created internally
 655         ;; because it has a built-in bitmap
 656         (set-glyph-image continuation-glyph "\\" 'global 'tty)
 657
 658         ;; finish initializing hscroll glyph -- created internally
 659         ;; because it has a built-in bitmap
 660         (set-glyph-image hscroll-glyph "$" 'global 'tty)))
 661
 662   (set-glyph-image octal-escape-glyph "\\")
 663   (set-glyph-image control-arrow-glyph "^")
 664   (set-glyph-image invisible-text-glyph " ...")
 665   ;; (set-glyph-image hscroll-glyph "$")
 666
 667   (let ((face (make-face 'border-glyph
 668                          "Truncation and continuation glyphs face")))
 669     (set-glyph-face continuation-glyph face)
 670     (set-glyph-face truncation-glyph face)
 671     (set-glyph-face hscroll-glyph face))
 672
 673   ;; finish initializing xemacs logo -- created internally because it
 674   ;; has a built-in bitmap
 675   (if (featurep 'xpm)
 676       (set-glyph-image xemacs-logo
 677                        (concat "../etc/"
 678                                (if emacs-beta-version
 679                                    "xemacs-beta.xpm"
 680                                  "xemacs.xpm"))
 681                        'global 'x))
 682   (cond ((featurep 'xpm)
 683          (set-glyph-image frame-icon-glyph
 684                           (concat "../etc/" "xemacs-icon.xpm")
 685                           'global 'x))
 686         ((featurep 'x)
 687          (set-glyph-image frame-icon-glyph
 688                           (concat "../etc/" "xemacs-icon2.xbm")
 689                           'global 'x)))
 690
 691   (if (featurep 'tty)
 692       (set-glyph-image xemacs-logo
 693                        "XEmacs <insert spiffy graphic logo here>"
 694                        'global 'tty))
 695 )
 696
 697 (init-glyphs)
 698
 699 ;;; glyphs.el ends here.