Mercurial > hg > xemacs-beta

comparison lisp/x11/x-faces.el @ 70:131b0175ea99 r20-0b30

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-0b30
author cvs
date Mon, 13 Aug 2007 09:02:59 +0200
parents ec9a17fef872
children cf808b4c4290
comparison
equal deleted inserted replaced
69:804d1389bcd6 70:131b0175ea99
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
20 ;; General Public License for more details. 20 ;; General Public License for more details.
21 21
22 ;; You should have received a copy of the GNU General Public License 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 Free 23 ;; along with XEmacs; see the file COPYING. If not, write to the
24 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA.
25 26
26 ;; This file does the magic to parse X font names, and make sure that the 27 ;; This file does the magic to parse X font names, and make sure that the
27 ;; default and modeline attributes of new frames are specified enough. 28 ;; default and modeline attributes of new frames are specified enough.
28 ;; 29 ;;
29 ;; The resource-manager syntax for faces is 30 ;; The resource-manager syntax for faces is
165 (defun x-make-font-unbold (font &optional device) 166 (defun x-make-font-unbold (font &optional device)
166 "Given an X font specification, this attempts to make a non-bold font. 167 "Given an X font specification, this attempts to make a non-bold font.
167 If it fails, it returns nil." 168 If it fails, it returns nil."
168 (try-font-name (x-frob-font-weight font "medium") device)) 169 (try-font-name (x-frob-font-weight font "medium") device))
169 170
170 (defvar *try-oblique-before-italic-fonts* nil
171 "*If NIL, italic fonts are searched before oblique fonts. If
172 non-NIL, oblique fonts are tried before italic fonts. This is mostly
173 applicable to adobe-courier fonts")
174
175 (defun x-make-font-italic (font &optional device) 171 (defun x-make-font-italic (font &optional device)
176 "Given an X font specification, this attempts to make an `italic' font. 172 "Given an X font specification, this attempts to make an `italic' font.
177 If it fails, it returns nil." 173 If it fails, it returns nil."
178 (if *try-oblique-before-italic-fonts* 174 (or (try-font-name (x-frob-font-slant font "i") device)
179 (or (try-font-name (x-frob-font-slant font "o") device) 175 (try-font-name (x-frob-font-slant font "o") device)))
180 (try-font-name (x-frob-font-slant font "i") device))
181 (or (try-font-name (x-frob-font-slant font "i") device)
182 (try-font-name (x-frob-font-slant font "o") device))))
183 176
184 (defun x-make-font-unitalic (font &optional device) 177 (defun x-make-font-unitalic (font &optional device)
185 "Given an X font specification, this attempts to make a non-italic font. 178 "Given an X font specification, this attempts to make a non-italic font.
186 If it fails, it returns nil." 179 If it fails, it returns nil."
187 (try-font-name (x-frob-font-slant font "r") device)) 180 (try-font-name (x-frob-font-slant font "r") device))
377 ;;; 370 ;;;
378 ;;; This had better not signal an error. The frame is in an intermediate 371 ;;; This had better not signal an error. The frame is in an intermediate
379 ;;; state where signalling an error or entering the debugger would likely 372 ;;; state where signalling an error or entering the debugger would likely
380 ;;; result in a crash. 373 ;;; result in a crash.
381 374
382 (defun x-init-face-from-resources (face &optional locale set-anyway) 375 (defun x-init-face-from-resources (face locale)
383
384 ;; 376 ;;
385 ;; These are things like "attributeForeground" instead of simply 377 ;; These are things like "attributeForeground" instead of simply
386 ;; "foreground" because people tend to do things like "*foreground", 378 ;; "foreground" because people tend to do things like "*foreground",
387 ;; which would cause all faces to be fully qualified, making faces 379 ;; which would cause all faces to be fully qualified, making faces
388 ;; inherit attributes in a non-useful way. So we've made them slightly 380 ;; inherit attributes in a non-useful way. So we've made them slightly
391 ;; 383 ;;
392 ;; I think these should be called "face.faceForeground" instead of 384 ;; I think these should be called "face.faceForeground" instead of
393 ;; "face.attributeForeground", but they're the way they are for 385 ;; "face.attributeForeground", but they're the way they are for
394 ;; hysterical reasons. (jwz) 386 ;; hysterical reasons. (jwz)
395 387
396 (let* ((append (if set-anyway nil 'append)) 388 (let* ((face-sym (face-name face))
397 (face-sym (face-name face))
398 (name (symbol-name face-sym)) 389 (name (symbol-name face-sym))
399 (fn (x-get-resource-and-maybe-bogosity-check 390 (fn (x-get-resource-and-maybe-bogosity-check
400 (concat name ".attributeFont") 391 (concat name ".attributeFont")
401 "Face.AttributeFont" 392 "Face.AttributeFont"
402 'string locale)) 393 'string locale))
467 "cursorColor" "CursorColor" 'string locale) bg))) 458 "cursorColor" "CursorColor" 'string locale) bg)))
468 ;; #### should issue warnings? I think this should be 459 ;; #### should issue warnings? I think this should be
469 ;; done when the instancing actually happens, but I'm not 460 ;; done when the instancing actually happens, but I'm not
470 ;; sure how it should actually be dealt with. 461 ;; sure how it should actually be dealt with.
471 (if fn 462 (if fn
472 (set-face-font face fn locale nil append)) 463 (set-face-font face fn locale nil 'append))
473 ;; Kludge-o-rooni. Set the foreground and background resources for 464 ;; Kludge-o-rooni. Set the foreground and background resources for
474 ;; X devices only -- otherwise things tend to get all messed up 465 ;; X devices only -- otherwise things tend to get all messed up
475 ;; if you start up an X frame and then later create a TTY frame. 466 ;; if you start up an X frame and then later create a TTY frame.
476 (if fg 467 (if fg
477 (set-face-foreground face fg locale 'x append)) 468 (set-face-foreground face fg locale 'x 'append))
478 (if bg 469 (if bg
479 (set-face-background face bg locale 'x append)) 470 (set-face-background face bg locale 'x 'append))
480 (if bgp 471 (if bgp
481 (set-face-background-pixmap face bgp locale nil append)) 472 (set-face-background-pixmap face bgp locale nil 'append))
482 (if ulp 473 (if ulp
483 (set-face-underline-p face ulp locale nil append)) 474 (set-face-underline-p face ulp locale nil 'append))
484 (if stp 475 (if stp
485 (set-face-strikethru-p face stp locale nil append)) 476 (set-face-strikethru-p face stp locale nil 'append))
486 (if hp 477 (if hp
487 (set-face-highlight-p face hp locale nil append)) 478 (set-face-highlight-p face hp locale nil 'append))
488 (if dp 479 (if dp
489 (set-face-dim-p face dp locale nil append)) 480 (set-face-dim-p face dp locale nil 'append))
490 (if bp 481 (if bp
491 (set-face-blinking-p face bp locale nil append)) 482 (set-face-blinking-p face bp locale nil 'append))
492 (if rp 483 (if rp
493 (set-face-reverse-p face rp locale nil append)) 484 (set-face-reverse-p face rp locale nil 'append))
494 )) 485 ))
495
496 ;; GNU Emacs compatibility. (move to obsolete.el?)
497 (defalias 'make-face-x-resource-internal 'x-init-face-from-resources)
498 486
499 ;;; x-init-global-faces is responsible for ensuring that the 487 ;;; x-init-global-faces is responsible for ensuring that the
500 ;;; default face has some reasonable fallbacks if nothing else is 488 ;;; default face has some reasonable fallbacks if nothing else is
501 ;;; specified. 489 ;;; specified.
502 ;;; 490 ;;;
506 "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*") 494 "-*-courier-medium-r-*-*-*-120-*-*-*-*-iso8859-*")
507 'global) 495 'global)
508 (or (face-foreground 'default 'global) 496 (or (face-foreground 'default 'global)
509 (set-face-foreground 'default "black" 'global 'x)) 497 (set-face-foreground 'default "black" 'global 'x))
510 (or (face-background 'default 'global) 498 (or (face-background 'default 'global)
511 (set-face-background 'default "gray80" 'global 'x))) 499 (set-face-background 'default "white" 'global 'x)))
512 500
513 ;;; x-init-device-faces is responsible for initializing default 501 ;;; x-init-device-faces is responsible for initializing default
514 ;;; values for faces on a newly created device. 502 ;;; values for faces on a newly created device.
515 ;;; 503 ;;;
516 (defun x-init-device-faces (device) 504 (defun x-init-device-faces (device)
588 (if (or (and fg (equal (downcase (color-instance-name fg)) "white")) 576 (if (or (and fg (equal (downcase (color-instance-name fg)) "white"))
589 (and bg (equal (downcase (color-instance-name bg)) "black"))) 577 (and bg (equal (downcase (color-instance-name bg)) "black")))
590 (progn 578 (progn
591 (or fg (set-face-foreground 'default "white" device)) 579 (or fg (set-face-foreground 'default "white" device))
592 (or bg (set-face-background 'default "black" device))) 580 (or bg (set-face-background 'default "black" device)))
593 (or fg (set-face-foreground 'default "white" device)) 581 (or fg (set-face-foreground 'default "black" device))
594 (or bg (set-face-background 'default "black" device))))) 582 (or bg (set-face-background 'default "white" device)))))
595 583
596 ;; Don't look at reverseVideo now or initialize the modeline. This 584 ;; Don't look at reverseVideo now or initialize the modeline. This
597 ;; is done on a per-frame basis at the appropriate time. 585 ;; is done on a per-frame basis at the appropriate time.
598 586
599 ;; 587 ;;