X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-xmas.el;h=17eeee7be945aee15a7c8af476084c7b298af36a;hp=6a26ca6c779172541dc89552d8c5e02379347820;hb=a3e52de2271f1336cb7e3c31c14bd122f4db609e;hpb=61d56bb2d28fd4989b51fcb5935880dbda7cf812 diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index 6a26ca6c7..17eeee7be 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -29,10 +29,17 @@ (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") @@ -49,20 +56,27 @@ automatically.") (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. @@ -120,11 +134,12 @@ It is provided only to ease porting of broken FSF Emacs programs." (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 () @@ -137,9 +152,11 @@ It is provided only to ease porting of broken FSF Emacs programs." (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) @@ -182,28 +199,24 @@ displayed, no centering will be performed." (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)) @@ -475,7 +488,6 @@ call it with the value of the `gnus-data' text property." (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) @@ -498,21 +510,8 @@ call it with the value of the `gnus-data' text property." (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. @@ -522,37 +521,38 @@ call it with the value of the `gnus-data' text property." ;; 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 _ ___ _ _ _ ___ __ ___ __ _ ___ __ _ ___ __ ___ @@ -572,34 +572,37 @@ call it with the value of the `gnus-data' text property." __ " - "")) - ;; 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"] @@ -709,65 +712,79 @@ XEmacs compatibility workaround." '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))