Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 122:d2f30a177268 r20-1b14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b14
author cvs
date Mon, 13 Aug 2007 09:26:03 +0200
parents cca96a509cfe
children b980b6286996
comparison
equal deleted inserted replaced
121:419db647c998 122:d2f30a177268
27 27
28 (require 'text-props) 28 (require 'text-props)
29 (defvar menu-bar-mode (featurep 'menubar)) 29 (defvar menu-bar-mode (featurep 'menubar))
30 (require 'messagexmas) 30 (require 'messagexmas)
31 31
32 (defvar gnus-xmas-glyph-directory nil 32 (defgroup gnus-xmas nil
33 "XEmacsoid support for Gnus"
34 :group 'gnus)
35
36 (defcustom gnus-xmas-glyph-directory nil
33 "*Directory where Gnus logos and icons are located. 37 "*Directory where Gnus logos and icons are located.
34 If this variable is nil, Gnus will try to locate the directory 38 If this variable is nil, Gnus will try to locate the directory
35 automatically.") 39 automatically."
40 :type '(choice (const :tag "autodetect" nil)
41 directory)
42 :group 'gnus-xmas)
36 43
37 (defvar gnus-xmas-logo-color-alist 44 (defvar gnus-xmas-logo-color-alist
38 '((flame "#cc3300" "#ff2200") 45 '((flame "#cc3300" "#ff2200")
39 (pine "#c0cc93" "#f8ffb8") 46 (pine "#c0cc93" "#f8ffb8")
40 (moss "#a1cc93" "#d2ffb8") 47 (moss "#a1cc93" "#d2ffb8")
47 (berry "#cc6485" "#ff7db5") 54 (berry "#cc6485" "#ff7db5")
48 (neutral "#b4b4b4" "#878787") 55 (neutral "#b4b4b4" "#878787")
49 (september "#bf9900" "#ffcc00")) 56 (september "#bf9900" "#ffcc00"))
50 "Color alist used for the Gnus logo.") 57 "Color alist used for the Gnus logo.")
51 58
52 (defvar gnus-xmas-logo-color-style 'flame 59 (defcustom gnus-xmas-logo-color-style 'flame
53 "Color styles used for the Gnus logo.") 60 "Color styles used for the Gnus logo."
61 :type '(choice (const flame) (const pine) (const moss)
62 (const irish) (const sky) (const tin)
63 (const velvet) (const grape) (const labia)
64 (const berry) (const neutral) (const september))
65 :group 'gnus-xmas)
54 66
55 (defvar gnus-xmas-logo-colors 67 (defvar gnus-xmas-logo-colors
56 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist)) 68 (cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
57 "Colors used for the Gnus logo.") 69 "Colors used for the Gnus logo.")
58 70
59 (defvar gnus-article-x-face-command 71 (defcustom gnus-article-x-face-command
60 (if (featurep 'xface) 72 (if (featurep 'xface)
61 'gnus-xmas-article-display-xface 73 'gnus-xmas-article-display-xface
62 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -") 74 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")
63 "String or function to be executed to display an X-Face header. 75 "String or function to be executed to display an X-Face header.
64 If it is a string, the command will be executed in a sub-shell 76 If it is a string, the command will be executed in a sub-shell
65 asynchronously. The compressed face will be piped to this command.") 77 asynchronously. The compressed face will be piped to this command."
78 :type '(choice string function))
66 79
67 ;;; Internal variables. 80 ;;; Internal variables.
68 81
69 ;; Don't warn about these undefined variables. 82 ;; Don't warn about these undefined variables.
70 83
135 (setq gnus-newsgroup-selected-overlay 148 (setq gnus-newsgroup-selected-overlay
136 (make-extent (gnus-point-at-bol) (gnus-point-at-eol))) 149 (make-extent (gnus-point-at-bol) (gnus-point-at-eol)))
137 (set-extent-face gnus-newsgroup-selected-overlay 150 (set-extent-face gnus-newsgroup-selected-overlay
138 gnus-summary-selected-face))) 151 gnus-summary-selected-face)))
139 152
140 (defvar gnus-xmas-force-redisplay nil 153 (defcustom gnus-xmas-force-redisplay nil
141 "If non-nil, force a redisplay before recentering the summary buffer. 154 "If non-nil, force a redisplay before recentering the summary buffer.
142 This is ugly, but it works around a bug in `window-displayed-height'.") 155 This is ugly, but it works around a bug in `window-displayed-height'."
156 :type 'boolean
157 :group 'gnus-xmas)
143 158
144 (defun gnus-xmas-switch-horizontal-scrollbar-off () 159 (defun gnus-xmas-switch-horizontal-scrollbar-off ()
145 (when (featurep 'scrollbar) 160 (when (featurep 'scrollbar)
146 (set-specifier scrollbar-height (cons (current-buffer) 0)))) 161 (set-specifier scrollbar-height (cons (current-buffer) 0))))
147 162
193 ;; ... but not newline and cr, of course. (cr is necessary for the 208 ;; ... but not newline and cr, of course. (cr is necessary for the
194 ;; selective display). 209 ;; selective display).
195 (aset table ?\n nil) 210 (aset table ?\n nil)
196 (aset table ?\r nil) 211 (aset table ?\r nil)
197 ;; We nix out any glyphs over 126 that are not set already. 212 ;; We nix out any glyphs over 126 that are not set already.
198 (let ((i 256)) 213 (when default-table
199 (while (>= (setq i (1- i)) 127) 214 (let ((i 256))
200 ;; Only modify if the default entry is nil. 215 (while (>= (setq i (1- i)) 127)
201 (when (or (not default-table) 216 ;; Only modify if the default entry is nil.
202 (not (aref default-table i))) 217 (unless (aref default-table i)
203 (aset table i [??])))) 218 (aset table i [??])))))
204 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier 219 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
205 (add-spec-to-specifier current-display-table table (current-buffer) nil))) 220 (add-spec-to-specifier current-display-table table (current-buffer) nil)))
206
207 (defun gnus-xmas-add-hook (hook function &optional append local)
208 (add-hook hook function))
209 221
210 (defun gnus-xmas-add-text-properties (start end props &optional object) 222 (defun gnus-xmas-add-text-properties (start end props &optional object)
211 (add-text-properties start end props object) 223 (add-text-properties start end props object)
212 (put-text-property start end 'start-closed nil object)) 224 (put-text-property start end 'start-closed nil object))
213 225
476 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message) 488 (fset 'gnus-group-startup-message 'gnus-xmas-group-startup-message)
477 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize) 489 (fset 'gnus-tree-minimize 'gnus-xmas-tree-minimize)
478 (fset 'gnus-appt-select-lowest-window 490 (fset 'gnus-appt-select-lowest-window
479 'gnus-xmas-appt-select-lowest-window) 491 'gnus-xmas-appt-select-lowest-window)
480 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names) 492 (fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
481 (fset 'gnus-add-hook 'gnus-xmas-add-hook)
482 (fset 'gnus-character-to-event 'character-to-event) 493 (fset 'gnus-character-to-event 'character-to-event)
483 (fset 'gnus-mode-line-buffer-identification 494 (fset 'gnus-mode-line-buffer-identification
484 'gnus-xmas-mode-line-buffer-identification) 495 'gnus-xmas-mode-line-buffer-identification)
485 (fset 'gnus-key-press-event-p 'key-press-event-p) 496 (fset 'gnus-key-press-event-p 'key-press-event-p)
486 (fset 'gnus-region-active-p 'region-active-p) 497 (fset 'gnus-region-active-p 'region-active-p)
594 (set-buffer-modified-p t))) 605 (set-buffer-modified-p t)))
595 606
596 607
597 ;;; The toolbar. 608 ;;; The toolbar.
598 609
599 (defvar gnus-use-toolbar (if (featurep 'toolbar) 610 (defcustom gnus-use-toolbar (if (featurep 'toolbar)
600 'default-toolbar 611 'default-toolbar
601 nil) 612 nil)
602 "*If nil, do not use a toolbar. 613 "*If nil, do not use a toolbar.
603 If it is non-nil, it must be a toolbar. The five legal values are 614 If it is non-nil, it must be a toolbar. The five legal values are
604 `default-toolbar', `top-toolbar', `bottom-toolbar', 615 `default-toolbar', `top-toolbar', `bottom-toolbar',
605 `right-toolbar', and `left-toolbar'.") 616 `right-toolbar', and `left-toolbar'."
617 :type '(choice (const default-toolbar)
618 (const top-toolbar) (const bottom-toolbar)
619 (const left-toolbar) (const right-toolbar)
620 (const :tag "no toolbar" nil))
621 :group 'gnus-xmas)
606 622
607 (defvar gnus-group-toolbar 623 (defvar gnus-group-toolbar
608 '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"] 624 '([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
609 [gnus-group-get-new-news-this-group 625 [gnus-group-get-new-news-this-group
610 gnus-group-get-new-news-this-group t "Get new news in this group"] 626 gnus-group-get-new-news-this-group t "Get new news in this group"]
710 (defun gnus-xmas-call-region (command &rest args) 726 (defun gnus-xmas-call-region (command &rest args)
711 (apply 727 (apply
712 'call-process-region (point-min) (point-max) command t '(t nil) nil 728 'call-process-region (point-min) (point-max) command t '(t nil) nil
713 args)) 729 args))
714 730
715 (unless (find-face 'gnus-x-face) 731 (defface gnus-x-face '((t (:foreground "black" :background "white")))
716 (copy-face 'default 'gnus-x-face) 732 "Face to show X face"
717 (set-face-foreground 'gnus-x-face "black") 733 :group 'gnus-xmas)
718 (set-face-background 'gnus-x-face "white"))
719 734
720 (defun gnus-xmas-article-display-xface (beg end) 735 (defun gnus-xmas-article-display-xface (beg end)
721 "Display any XFace headers in the current article." 736 "Display any XFace headers in the current article."
722 (save-excursion 737 (save-excursion
723 (let (xface-glyph) 738 (let (xface-glyph)