(defvar menu-bar-mode (featurep 'menubar))
(require 'messagexmas)
-(defvar gnus-xmas-glyph-directory nil
+(defgroup gnus-xmas nil
+ "XEmacsoid support for Gnus"
+ :group 'gnus)
+
+(defcustom gnus-xmas-glyph-directory nil
"*Directory where Gnus logos and icons are located.
If this variable is nil, Gnus will try to locate the directory
-automatically.")
+automatically."
+ :type '(choice (const :tag "autodetect" nil)
+ directory)
+ :group 'gnus-xmas)
(defvar gnus-xmas-logo-color-alist
'((flame "#cc3300" "#ff2200")
(september "#bf9900" "#ffcc00"))
"Color alist used for the Gnus logo.")
-(defvar gnus-xmas-logo-color-style 'flame
- "Color styles used for the Gnus logo.")
+(defcustom gnus-xmas-logo-color-style 'flame
+ "Color styles used for the Gnus logo."
+ :type '(choice (const flame) (const pine) (const moss)
+ (const irish) (const sky) (const tin)
+ (const velvet) (const grape) (const labia)
+ (const berry) (const neutral) (const september))
+ :group 'gnus-xmas)
(defvar gnus-xmas-logo-colors
(cdr (assq gnus-xmas-logo-color-style gnus-xmas-logo-color-alist))
"Colors used for the Gnus logo.")
-(defvar gnus-article-x-face-command
- (if (featurep 'xface)
+(defcustom gnus-article-x-face-command
+ (if (or (featurep 'xface)
+ (featurep 'xpm))
'gnus-xmas-article-display-xface
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")
"String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
-asynchronously. The compressed face will be piped to this command.")
+asynchronously. The compressed face will be piped to this command."
+ :type '(choice string function))
;;; Internal variables.
(if (stringp buffer)
nil
(map-extents (lambda (extent ignored)
- (remove-text-properties
- start end
- (list (extent-property extent 'text-prop) nil)
- buffer))
- buffer start end nil nil 'text-prop)
+ (remove-text-properties
+ start end
+ (list (extent-property extent 'text-prop) nil)
+ buffer)
+ nil)
+ buffer start end nil nil 'text-prop)
(gnus-add-text-properties start end props buffer)))
(defun gnus-xmas-highlight-selected-summary ()
(set-extent-face gnus-newsgroup-selected-overlay
gnus-summary-selected-face)))
-(defvar gnus-xmas-force-redisplay nil
+(defcustom gnus-xmas-force-redisplay nil
"If non-nil, force a redisplay before recentering the summary buffer.
-This is ugly, but it works around a bug in `window-displayed-height'.")
+This is ugly, but it works around a bug in `window-displayed-height'."
+ :type 'boolean
+ :group 'gnus-xmas)
(defun gnus-xmas-switch-horizontal-scrollbar-off ()
(when (featurep 'scrollbar)
(select-window selected))))))
(defun gnus-xmas-summary-set-display-table ()
- ;; Setup the display table -- like gnus-summary-setup-display-table,
+ ;; Setup the display table -- like `gnus-summary-setup-display-table',
;; but done in an XEmacsish way.
(let ((table (make-display-table))
- ;; Nix out all the control chars...
(i 32))
+ ;; Nix out all the control chars...
(while (>= (setq i (1- i)) 0)
(aset table i [??]))
;; ... but not newline and cr, of course. (cr is necessary for the
;; selective display).
(aset table ?\n nil)
(aset table ?\r nil)
- ;; We nix out any glyphs over 126 that are not set already.
- (let ((i 256))
+ ;; We nix out any glyphs over 126 below ctl-arrow.
+ (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
(while (>= (setq i (1- i)) 127)
- ;; Only modify if the entry is nil.
- (or (aref table i)
- (aset table i [??]))))
+ (aset table i [??])))
+ ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
(add-spec-to-specifier current-display-table table (current-buffer) nil)))
-(defun gnus-xmas-add-hook (hook function &optional append local)
- (add-hook hook function))
-
(defun gnus-xmas-add-text-properties (start end props &optional object)
(add-text-properties start end props object)
(put-text-property start end 'start-closed nil object))
(fset 'gnus-appt-select-lowest-window
'gnus-xmas-appt-select-lowest-window)
(fset 'gnus-mail-strip-quoted-names 'gnus-xmas-mail-strip-quoted-names)
- (fset 'gnus-add-hook 'gnus-xmas-add-hook)
(fset 'gnus-character-to-event 'character-to-event)
(fset 'gnus-mode-line-buffer-identification
'gnus-xmas-mode-line-buffer-identification)
(add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
(add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
- (add-hook 'gnus-summary-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off)
-
- (when (and (<= emacs-major-version 19)
- (<= emacs-minor-version 13))
- (setq gnus-article-x-face-too-ugly (when (eq (device-type) 'tty)
- "."))
- (fset 'gnus-highlight-selected-summary
- 'gnus-xmas-highlight-selected-summary)
- (fset 'gnus-group-remove-excess-properties
- 'gnus-xmas-group-remove-excess-properties)
- (fset 'gnus-topic-remove-excess-properties
- 'gnus-xmas-topic-remove-excess-properties)
- (fset 'gnus-mode-line-buffer-identification 'identity)
- (unless (boundp 'shell-command-switch)
- (setq shell-command-switch "-c"))))
+ (add-hook 'gnus-summary-mode-hook
+ 'gnus-xmas-switch-horizontal-scrollbar-off))
;;; XEmacs logo and toolbar.
;; Insert the message.
(setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
(erase-buffer)
- (let ((logo (and gnus-xmas-glyph-directory
- (concat
- (file-name-as-directory gnus-xmas-glyph-directory)
- "gnus."
- (if (featurep 'xpm) "xpm" "xbm"))))
- (xpm-color-symbols
- (and (featurep 'xpm)
- (append `(("thing" ,(car gnus-xmas-logo-colors))
- ("shadow" ,(cadr gnus-xmas-logo-colors)))
- xpm-color-symbols))))
- (if (and (featurep 'xpm)
- (not (equal (device-type) 'tty))
- logo
- (file-exists-p logo))
- (progn
- (setq logo (make-glyph logo))
- (insert " ")
- (set-extent-begin-glyph (make-extent (point) (point)) logo)
- (goto-char (point-min))
- (while (not (eobp))
- (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
- ? ))
- (forward-line 1))
- (goto-char (point-min))
- (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
- (wheight (window-height))
- (rest (- wheight pheight)))
- (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
-
- (insert
- (format " %s
+ (cond
+ ((and (console-on-window-system-p)
+ (or (featurep 'xpm)
+ (featurep 'xbm)))
+ (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
+ (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
+ (glyph (make-glyph
+ `(,@(if (featurep 'xpm)
+ (list
+ (vector 'xpm
+ ':file logo-xpm
+ ':color-symbols
+ `(("thing" . ,(car gnus-xmas-logo-colors))
+ ("shadow" . ,(cadr gnus-xmas-logo-colors))
+ ("background" . ,(face-background 'default))))))
+ ,(vector 'xbm :file logo-xbm)
+ ,(vector 'nothing)))))
+ (insert " ")
+ (set-extent-begin-glyph (make-extent (point) (point)) glyph)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
+ ?\ ))
+ (forward-line 1)))
+ (goto-char (point-min))
+ (let* ((pheight (+ 20 (count-lines (point-min) (point-max))))
+ (wheight (window-height))
+ (rest (- wheight pheight)))
+ (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
+ (t
+ (insert
+ (format " %s
_ ___ _ _
_ ___ __ ___ __ _ ___
__ _ ___ __ ___
__
"
- ""))
- ;; And then hack it.
- (gnus-indent-rigidly (point-min) (point-max)
- (/ (max (- (window-width) (or x 46)) 0) 2))
- (goto-char (point-min))
- (forward-line 1)
- (let* ((pheight (count-lines (point-min) (point-max)))
- (wheight (window-height))
- (rest (- wheight pheight)))
- (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n))))
- ;; Fontify some.
- (goto-char (point-min))
- (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)
+ ""))
+ ;; And then hack it.
+ (gnus-indent-rigidly (point-min) (point-max)
+ (/ (max (- (window-width) (or x 46)) 0) 2))
(goto-char (point-min))
- (setq modeline-buffer-identification
- (list (concat gnus-version ": *Group*")))
- (set-buffer-modified-p t)))
+ (forward-line 1)
+ (let* ((pheight (count-lines (point-min) (point-max)))
+ (wheight (window-height))
+ (rest (- wheight pheight)))
+ (insert (make-string (max 0 (* 2 (/ rest 3))) ?\n)))
+ ;; Paint it.
+ (put-text-property (point-min) (point-max) 'face 'gnus-splash-face)))
+ (setq modeline-buffer-identification
+ (list (concat gnus-version ": *Group*")))
+ (set-buffer-modified-p t))
;;; The toolbar.
-(defvar gnus-use-toolbar (if (featurep 'toolbar)
- 'default-toolbar
- nil)
+(defcustom gnus-use-toolbar (if (featurep 'toolbar)
+ 'default-toolbar
+ nil)
"*If nil, do not use a toolbar.
If it is non-nil, it must be a toolbar. The five legal values are
`default-toolbar', `top-toolbar', `bottom-toolbar',
-`right-toolbar', and `left-toolbar'.")
+`right-toolbar', and `left-toolbar'."
+ :type '(choice (const default-toolbar)
+ (const top-toolbar) (const bottom-toolbar)
+ (const left-toolbar) (const right-toolbar)
+ (const :tag "no toolbar" nil))
+ :group 'gnus-xmas)
(defvar gnus-group-toolbar
'([gnus-group-get-new-news gnus-group-get-new-news t "Get new news"]
'call-process-region (point-min) (point-max) command t '(t nil) nil
args))
-(unless (find-face 'gnus-x-face)
- (copy-face 'default 'gnus-x-face)
- (set-face-foreground 'gnus-x-face "black")
- (set-face-background 'gnus-x-face "white"))
+(defface gnus-x-face '((t (:foreground "black" :background "white")))
+ "Face to show X face"
+ :group 'gnus-xmas)
(defun gnus-xmas-article-display-xface (beg end)
"Display any XFace headers in the current article."
(save-excursion
- (let (xface-glyph)
- (if (featurep 'xface)
- (setq xface-glyph
- (make-glyph (vector 'xface :data
- (concat "X-Face: "
- (buffer-substring beg end)))))
- (let ((cur (current-buffer)))
- (save-excursion
- (gnus-set-work-buffer)
- (insert (format "%s" (buffer-substring beg end cur)))
- (gnus-xmas-call-region "uncompface")
- (goto-char (point-min))
- (insert "/* Width=48, Height=48 */\n")
- (gnus-xmas-call-region "icontopbm")
- (gnus-xmas-call-region "ppmtoxpm")
- (setq xface-glyph
- (make-glyph
- (vector 'xpm :data (buffer-string )))))))
+ (let ((xface-glyph
+ (cond ((featurep 'xface)
+ (make-glyph (vector 'xface :data
+ (concat "X-Face: "
+ (buffer-substring beg end)))))
+ ((featurep 'xpm)
+ (let ((cur (current-buffer)))
+ (save-excursion
+ (gnus-set-work-buffer)
+ (insert (format "%s" (buffer-substring beg end cur)))
+ (gnus-xmas-call-region "uncompface")
+ (goto-char (point-min))
+ (insert "/* Width=48, Height=48 */\n")
+ (gnus-xmas-call-region "icontopbm")
+ (gnus-xmas-call-region "ppmtoxpm")
+ (make-glyph
+ (vector 'xpm :data (buffer-string)))))
+ (t
+ (make-glyph [nothing]))))))
(set-glyph-face xface-glyph 'gnus-x-face)
(goto-char (point-min))
(re-search-forward "^From:" nil t)
(set-extent-begin-glyph
(make-extent (point) (1+ (point))) xface-glyph))))
-(defvar gnus-xmas-pointer-glyph
- (progn
- (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
- (make-pointer-glyph (concat gnus-xmas-glyph-directory "gnus-pointer."
- (if (featurep 'xpm) "xpm" "xbm")))))
+;;(defvar gnus-xmas-pointer-glyph
+;; (progn
+;; (setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory
+;; "gnus"))
+;; (let ((file-xpm (expand-file-name "gnus-pointer.xpm"
+;; gnus-xmas-glyph-directory))
+;; (file-xbm (expand-file-name "gnus-pointer.xbm"
+;; gnus-xmas-glyph-directory)))
+;; (make-pointer-glyph
+;; (list (vector 'xpm ':file file-xpm)
+;; (vector 'xbm ':file file-xbm))))))
(defvar gnus-xmas-modeline-left-extent
(let ((ext (copy-extent modeline-buffer-id-left-extent)))
- ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
+; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
ext))
(defvar gnus-xmas-modeline-right-extent
(let ((ext (copy-extent modeline-buffer-id-right-extent)))
- ;(set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
+; (set-extent-property ext 'pointer gnus-xmas-pointer-glyph)
ext))
(defvar gnus-xmas-modeline-glyph
(progn
(setq gnus-xmas-glyph-directory (message-xmas-find-glyph-directory "gnus"))
- (let* ((file (concat gnus-xmas-glyph-directory "gnus-pointer."
- (if (featurep 'xpm) "xpm" "xbm")))
- (glyph (make-glyph file)))
- (when (and (featurep 'x)
- (file-exists-p file))
- (set-glyph-face glyph 'modeline-buffer-id)
- (set-glyph-property glyph 'image (cons 'tty "Gnus:"))
- glyph))))
+ (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
+ gnus-xmas-glyph-directory))
+ (file-xbm (expand-file-name "gnus-pointer.xbm"
+ gnus-xmas-glyph-directory))
+ (glyph (make-glyph
+ ;; Gag gag gag.
+ `(
+ ,@(if (featurep 'xpm)
+ ;; Let's try a nifty XPM
+ (list (vector 'xpm ':file file-xpm)))
+ ;; Then a not-so-nifty XBM
+ ,(vector 'xbm ':file file-xbm)
+ ;; Then the simple string
+ ,(vector 'string ':data "Gnus:")))))
+ (set-glyph-face glyph 'modeline-buffer-id)
+ glyph)))
(defun gnus-xmas-mode-line-buffer-identification (line)
(let ((line (car line))
projects / gnus / blobdiff