Mercurial > hg > xemacs-beta

comparison lisp/custom/cus-face.el @ 120:cca96a509cfe r20-1b12

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b12
author cvs
date Mon, 13 Aug 2007 09:25:29 +0200
parents 7d55a9ba150c
children 9b50b4588a93
comparison
equal deleted inserted replaced
119:d101af7320b8 120:cca96a509cfe
2 ;; 2 ;;
3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
4 ;; 4 ;;
5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> 5 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
6 ;; Keywords: help, faces 6 ;; Keywords: help, faces
7 ;; Version: 1.69 7 ;; Version: 1.74
8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/ 8 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
9 9
10 ;;; Commentary: 10 ;;; Commentary:
11 ;; 11 ;;
12 ;; See `custom.el'. 12 ;; See `custom.el'.
30 (defun custom-face-foreground (face &optional frame) 30 (defun custom-face-foreground (face &optional frame)
31 ;; Specifiers suck! 31 ;; Specifiers suck!
32 "Return the background color name of face FACE, or nil if unspecified." 32 "Return the background color name of face FACE, or nil if unspecified."
33 (color-instance-name (specifier-instance (face-foreground face) frame))) 33 (color-instance-name (specifier-instance (face-foreground face) frame)))
34 (defalias 'custom-face-foreground 'face-foreground)) 34 (defalias 'custom-face-foreground 'face-foreground))
35
36 (defalias 'custom-face-font-name (if (string-match "XEmacs" emacs-version)
37 'face-font-name
38 'face-font))
35 39
36 (eval-and-compile 40 (eval-and-compile
37 (unless (fboundp 'frame-property) 41 (unless (fboundp 'frame-property)
38 ;; XEmacs function missing in Emacs 19.34. 42 ;; XEmacs function missing in Emacs 19.34.
39 (defun frame-property (frame property &optional default) 43 (defun frame-property (frame property &optional default)
274 ;;; Font Attributes. 278 ;;; Font Attributes.
275 279
276 (defconst custom-face-attributes 280 (defconst custom-face-attributes
277 '((:bold (toggle :format "Bold: %[%v%]\n" 281 '((:bold (toggle :format "Bold: %[%v%]\n"
278 :help-echo "Control whether a bold font should be used.") 282 :help-echo "Control whether a bold font should be used.")
279 custom-set-face-bold) 283 custom-set-face-bold
284 custom-face-bold)
280 (:italic (toggle :format "Italic: %[%v%]\n" 285 (:italic (toggle :format "Italic: %[%v%]\n"
281 :help-echo "\ 286 :help-echo "\
282 Control whether an italic font should be used.") 287 Control whether an italic font should be used.")
283 custom-set-face-italic) 288 custom-set-face-italic
289 custom-face-italic)
284 (:underline (toggle :format "Underline: %[%v%]\n" 290 (:underline (toggle :format "Underline: %[%v%]\n"
285 :help-echo "\ 291 :help-echo "\
286 Control whether the text should be underlined.") 292 Control whether the text should be underlined.")
287 set-face-underline-p 293 set-face-underline-p
288 face-underline-p) 294 face-underline-p)
304 ;; (lambda (face value &optional frame) 310 ;; (lambda (face value &optional frame)
305 ;; ;; We don't use VALUE. 311 ;; ;; We don't use VALUE.
306 ;; (custom-invert-face face frame))) 312 ;; (custom-invert-face face frame)))
307 (:stipple (editable-field :format "Stipple: %v" 313 (:stipple (editable-field :format "Stipple: %v"
308 :help-echo "Name of background bitmap file.") 314 :help-echo "Name of background bitmap file.")
309 set-face-stipple)) 315 set-face-stipple custom-face-stipple))
310 "Alist of face attributes. 316 "Alist of face attributes.
311 317
312 The elements are of the form (KEY TYPE SET GET) where KEY is a symbol 318 The elements are of the form (KEY TYPE SET GET) where KEY is a symbol
313 identifying the attribute, TYPE is a widget type for editing the 319 identifying the attribute, TYPE is a widget type for editing the
314 attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value. 320 attibute, SET is a function for setting the attribute value, and GET is a function for getiing the attribute value.
337 (defun custom-face-attributes-get (face frame) 343 (defun custom-face-attributes-get (face frame)
338 "For FACE on FRAME get the attributes [KEYWORD VALUE].... 344 "For FACE on FRAME get the attributes [KEYWORD VALUE]....
339 Each keyword should be listed in `custom-face-attributes'. 345 Each keyword should be listed in `custom-face-attributes'.
340 346
341 If FRAME is nil, use the default face." 347 If FRAME is nil, use the default face."
348 (condition-case nil
349 ;; Attempt to get `font.el' from w3.
350 (require 'font)
351 (error nil))
342 (let ((atts custom-face-attributes) 352 (let ((atts custom-face-attributes)
343 att result get) 353 att result get)
344 (while atts 354 (while atts
345 (setq att (car atts) 355 (setq att (car atts)
346 atts (cdr atts) 356 atts (cdr atts)
356 "Set the bold property of FACE to VALUE." 366 "Set the bold property of FACE to VALUE."
357 (if value 367 (if value
358 (make-face-bold face frame) 368 (make-face-bold face frame)
359 (make-face-unbold face frame))) 369 (make-face-unbold face frame)))
360 370
371 (defun custom-face-bold (face &rest args)
372 "Return non-nil if the font of FACE is bold."
373 (let* ((font (apply 'custom-face-font-name face args))
374 (fontobj (font-create-object font)))
375 (font-bold-p fontobj)))
376
361 (defun custom-set-face-italic (face value &optional frame) 377 (defun custom-set-face-italic (face value &optional frame)
362 "Set the italic property of FACE to VALUE." 378 "Set the italic property of FACE to VALUE."
363 (if value 379 (if value
364 (make-face-italic face frame) 380 (make-face-italic face frame)
365 (make-face-unitalic face frame))) 381 (make-face-unitalic face frame)))
366 382
383 (defun custom-face-italic (face &rest args)
384 "Return non-nil if the font of FACE is italic."
385 (let* ((font (apply 'custom-face-font-name face args))
386 (fontobj (font-create-object font)))
387 (font-italic-p fontobj)))
388
389 (defun custom-face-stipple (face &rest args)
390 "Return the name of the stipple file used for FACE."
391 (if (string-match "XEmacs" emacs-version)
392 (let ((image (apply 'specifier-instance
393 (face-background-pixmap face) args)))
394 (when image
395 (image-instance-file-name image)))
396 (apply 'face-stipple face args)))
397
367 (when (string-match "XEmacs" emacs-version) 398 (when (string-match "XEmacs" emacs-version)
368 ;; Support for special XEmacs font attributes. 399 ;; Support for special XEmacs font attributes.
369 (autoload 'font-create-object "font" nil) 400 (autoload 'font-create-object "font" nil)
370 401
371 (unless (fboundp 'face-font-name)
372 (defun face-font-name (face &rest args)
373 (apply 'face-font face args)))
374
375 (defun custom-set-face-font-size (face size &rest args) 402 (defun custom-set-face-font-size (face size &rest args)
376 "Set the font of FACE to SIZE" 403 "Set the font of FACE to SIZE"
377 (let* ((font (apply 'face-font-name face args)) 404 (let* ((font (apply 'custom-face-font-name face args))
378 (fontobj (font-create-object font))) 405 (fontobj (font-create-object font)))
379 (set-font-size fontobj size) 406 (set-font-size fontobj size)
380 (apply 'font-set-face-font face fontobj args))) 407 (apply 'font-set-face-font face fontobj args)))
381 408
409 (defun custom-face-font-size (face &rest args)
410 "Return the size of the font of FACE as a string."
411 (let* ((font (apply 'custom-face-font-name face args))
412 (fontobj (font-create-object font)))
413 (format "%d" (font-size fontobj))))
414
382 (defun custom-set-face-font-family (face family &rest args) 415 (defun custom-set-face-font-family (face family &rest args)
383 "Set the font of FACE to FAMILY" 416 "Set the font of FACE to FAMILY."
384 (let* ((font (apply 'face-font-name face args)) 417 (let* ((font (apply 'custom-face-font-name face args))
385 (fontobj (font-create-object font))) 418 (fontobj (font-create-object font)))
386 (set-font-family fontobj family) 419 (set-font-family fontobj family)
387 (apply 'font-set-face-font face fontobj args))) 420 (apply 'font-set-face-font face fontobj args)))
388 421
389 (nconc custom-face-attributes 422 (defun custom-face-font-family (face &rest args)
390 '((:family (editable-field :format "Font Family: %v" 423 "Return the name of the font family of FACE."
391 :help-echo "\ 424 (let* ((font (apply 'custom-face-font-name face args))
425 (fontobj (font-create-object font)))
426 (font-family fontobj)))
427
428 (setq custom-face-attributes
429 (append '((:family (editable-field :format "Font Family: %v"
430 :help-echo "\
392 Name of font family to use (e.g. times).") 431 Name of font family to use (e.g. times).")
393 custom-set-face-font-family) 432 custom-set-face-font-family
394 (:size (editable-field :format "Size: %v" 433 custom-face-font-family)
395 :help-echo "\ 434 (:size (editable-field :format "Size: %v"
435 :help-echo "\
396 Text size (e.g. 9pt or 2mm).") 436 Text size (e.g. 9pt or 2mm).")
397 custom-set-face-font-size)))) 437 custom-set-face-font-size
438 custom-face-font-size)
439 (:strikethru (toggle :format "Strikethru: %[%v%]\n"
440 :help-echo "\
441 Control whether the text should be strikethru.")
442 set-face-strikethru-p
443 face-strikethru-p))
444 custom-face-attributes)))
398 445
399 ;;; Frames. 446 ;;; Frames.
400 447
401 (defun custom-face-display-set (face spec &optional frame) 448 (defun custom-face-display-set (face spec &optional frame)
402 "Set FACE to the attributes to the first matching entry in SPEC. 449 "Set FACE to the attributes to the first matching entry in SPEC.
500 (setq frame (car (frame-list)))) 547 (setq frame (car (frame-list))))
501 (unless (equal (custom-get-frame-properties) 548 (unless (equal (custom-get-frame-properties)
502 (custom-get-frame-properties frame)) 549 (custom-get-frame-properties frame))
503 (custom-initialize-faces frame))) 550 (custom-initialize-faces frame)))
504 551
505 ;; Enable. This should go away when bundled with Emacs.
506 (unless (string-match "XEmacs" emacs-version)
507 (add-hook 'after-make-frame-hook 'custom-initialize-frame))
508
509 ;;; Initializing. 552 ;;; Initializing.
510 553
511 (and (fboundp 'make-face) 554 (and (fboundp 'make-face)
512 (make-face 'custom-face-empty)) 555 (make-face 'custom-face-empty))
513 556