Mercurial > hg > xemacs-beta

comparison lisp/gnus/gnus-xmas.el @ 163:0132846995bd r20-3b8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b8
author cvs
date Mon, 13 Aug 2007 09:43:35 +0200
parents 43dd3413c7c7
children 8eaf7971accc
comparison
equal deleted inserted replaced
162:4de2936b4e77 163:0132846995bd
67 (defvar gnus-xmas-logo-colors 67 (defvar gnus-xmas-logo-colors
68 (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))
69 "Colors used for the Gnus logo.") 69 "Colors used for the Gnus logo.")
70 70
71 (defcustom gnus-article-x-face-command 71 (defcustom gnus-article-x-face-command
72 (if (featurep 'xface) 72 (if (or (featurep 'xface)
73 (featurep 'xpm))
73 'gnus-xmas-article-display-xface 74 'gnus-xmas-article-display-xface
74 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -") 75 "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -")
75 "String or function to be executed to display an X-Face header. 76 "String or function to be executed to display an X-Face header.
76 If it is a string, the command will be executed in a sub-shell 77 If it is a string, the command will be executed in a sub-shell
77 asynchronously. The compressed face will be piped to this command." 78 asynchronously. The compressed face will be piped to this command."
131 "You should NEVER use this function. It is ideologically blasphemous. 132 "You should NEVER use this function. It is ideologically blasphemous.
132 It is provided only to ease porting of broken FSF Emacs programs." 133 It is provided only to ease porting of broken FSF Emacs programs."
133 (if (stringp buffer) 134 (if (stringp buffer)
134 nil 135 nil
135 (map-extents (lambda (extent ignored) 136 (map-extents (lambda (extent ignored)
136 (remove-text-properties 137 (remove-text-properties
137 start end 138 start end
138 (list (extent-property extent 'text-prop) nil) 139 (list (extent-property extent 'text-prop) nil)
139 buffer)) 140 buffer)
140 buffer start end nil nil 'text-prop) 141 nil)
142 buffer start end nil nil 'text-prop)
141 (gnus-add-text-properties start end props buffer))) 143 (gnus-add-text-properties start end props buffer)))
142 144
143 (defun gnus-xmas-highlight-selected-summary () 145 (defun gnus-xmas-highlight-selected-summary ()
144 ;; Highlight selected article in summary buffer 146 ;; Highlight selected article in summary buffer
145 (when gnus-summary-selected-face 147 (when gnus-summary-selected-face
209 (aset table ?\n nil) 211 (aset table ?\n nil)
210 (aset table ?\r nil) 212 (aset table ?\r nil)
211 ;; We nix out any glyphs over 126 below ctl-arrow. 213 ;; We nix out any glyphs over 126 below ctl-arrow.
212 (let ((i (if (integerp ctl-arrow) ctl-arrow 160))) 214 (let ((i (if (integerp ctl-arrow) ctl-arrow 160)))
213 (while (>= (setq i (1- i)) 127) 215 (while (>= (setq i (1- i)) 127)
214 (aset table i [??]))) 216 (unless (aref table i)
217 (aset table i [??]))))
215 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier 218 ;; Can't use `set-specifier' because of a bug in 19.14 and earlier
216 (add-spec-to-specifier current-display-table table (current-buffer) nil))) 219 (add-spec-to-specifier current-display-table table (current-buffer) nil)))
217 220
218 (defun gnus-xmas-add-text-properties (start end props &optional object) 221 (defun gnus-xmas-add-text-properties (start end props &optional object)
219 (add-text-properties start end props object) 222 (add-text-properties start end props object)
507 510
508 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar) 511 (add-hook 'gnus-group-mode-hook 'gnus-xmas-setup-group-toolbar)
509 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar) 512 (add-hook 'gnus-summary-mode-hook 'gnus-xmas-setup-summary-toolbar)
510 513
511 (add-hook 'gnus-summary-mode-hook 514 (add-hook 'gnus-summary-mode-hook
512 'gnus-xmas-switch-horizontal-scrollbar-off)) 515 'gnus-xmas-switch-horizontal-scrollbar-off)
516 (add-hook 'gnus-tree-mode-hook 'gnus-xmas-switch-horizontal-scrollbar-off))
513 517
514 518
515 ;;; XEmacs logo and toolbar. 519 ;;; XEmacs logo and toolbar.
516 520
517 (defun gnus-xmas-group-startup-message (&optional x y) 521 (defun gnus-xmas-group-startup-message (&optional x y)
524 (or (featurep 'xpm) 528 (or (featurep 'xpm)
525 (featurep 'xbm))) 529 (featurep 'xbm)))
526 (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory)) 530 (let* ((logo-xpm (expand-file-name "gnus.xpm" gnus-xmas-glyph-directory))
527 (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory)) 531 (logo-xbm (expand-file-name "gnus.xbm" gnus-xmas-glyph-directory))
528 (glyph (make-glyph 532 (glyph (make-glyph
529 (list 533 `(,@(if (featurep 'xpm)
530 (vector 'xpm 534 (list
531 ':file logo-xpm 535 (vector 'xpm
532 ':color-symbols 536 ':file logo-xpm
533 `(("thing" . ,(car gnus-xmas-logo-colors)) 537 ':color-symbols
534 ("shadow" . ,(cadr gnus-xmas-logo-colors)) 538 `(("thing" . ,(car gnus-xmas-logo-colors))
535 ("background" . ,(face-background 'default)))) 539 ("shadow" . ,(cadr gnus-xmas-logo-colors))
536 (vector 'xbm :file logo-xbm) 540 ("background" . ,(face-background 'default))))))
537 (vector 'nothing))))) 541 ,(vector 'xbm :file logo-xbm)
542 ,(vector 'nothing)))))
538 (insert " ") 543 (insert " ")
539 (set-extent-begin-glyph (make-extent (point) (point)) glyph) 544 (set-extent-begin-glyph (make-extent (point) (point)) glyph)
540 (goto-char (point-min)) 545 (goto-char (point-min))
541 (while (not (eobp)) 546 (while (not (eobp))
542 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2) 547 (insert (make-string (/ (max (- (window-width) (or x 35)) 0) 2)
715 720
716 (defun gnus-xmas-article-display-xface (beg end) 721 (defun gnus-xmas-article-display-xface (beg end)
717 "Display any XFace headers in the current article." 722 "Display any XFace headers in the current article."
718 (save-excursion 723 (save-excursion
719 (let ((xface-glyph 724 (let ((xface-glyph
720 (if (featurep 'xface) 725 (cond ((featurep 'xface)
721 (make-glyph (vector 'xface :data 726 (make-glyph (vector 'xface :data
722 (concat "X-Face: " 727 (concat "X-Face: "
723 (buffer-substring beg end)))) 728 (buffer-substring beg end)))))
724 (let ((cur (current-buffer))) 729 ((featurep 'xpm)
725 (save-excursion 730 (let ((cur (current-buffer)))
726 (gnus-set-work-buffer) 731 (save-excursion
727 (insert (format "%s" (buffer-substring beg end cur))) 732 (gnus-set-work-buffer)
728 (gnus-xmas-call-region "uncompface") 733 (insert (format "%s" (buffer-substring beg end cur)))
729 (goto-char (point-min)) 734 (gnus-xmas-call-region "uncompface")
730 (insert "/* Width=48, Height=48 */\n") 735 (goto-char (point-min))
731 (gnus-xmas-call-region "icontopbm") 736 (insert "/* Width=48, Height=48 */\n")
732 (gnus-xmas-call-region "ppmtoxpm") 737 (gnus-xmas-call-region "icontopbm")
733 (make-glyph 738 (gnus-xmas-call-region "ppmtoxpm")
734 (vector 'xpm :data (buffer-string)))))))) 739 (make-glyph
740 (vector 'xpm :data (buffer-string))))))
741 (t
742 (make-glyph [nothing])))))
735 (set-glyph-face xface-glyph 'gnus-x-face) 743 (set-glyph-face xface-glyph 'gnus-x-face)
736 (goto-char (point-min)) 744 (goto-char (point-min))
737 (re-search-forward "^From:" nil t) 745 (re-search-forward "^From:" nil t)
738 (set-extent-begin-glyph 746 (set-extent-begin-glyph
739 (make-extent (point) (1+ (point))) xface-glyph)))) 747 (make-extent (point) (1+ (point))) xface-glyph))))
766 (let* ((file-xpm (expand-file-name "gnus-pointer.xpm" 774 (let* ((file-xpm (expand-file-name "gnus-pointer.xpm"
767 gnus-xmas-glyph-directory)) 775 gnus-xmas-glyph-directory))
768 (file-xbm (expand-file-name "gnus-pointer.xbm" 776 (file-xbm (expand-file-name "gnus-pointer.xbm"
769 gnus-xmas-glyph-directory)) 777 gnus-xmas-glyph-directory))
770 (glyph (make-glyph 778 (glyph (make-glyph
771 (list 779 ;; Gag gag gag.
772 ;; Let's try a nifty XPM 780 `(
773 (vector 'xpm ':file file-xpm) 781 ,@(if (featurep 'xpm)
774 ;; Then a not-so-nifty XBM 782 ;; Let's try a nifty XPM
775 (vector 'xbm ':file file-xbm) 783 (list (vector 'xpm ':file file-xpm)))
776 ;; Then the simple string 784 ;; Then a not-so-nifty XBM
777 (vector 'string ':data "Gnus:"))))) 785 ,(vector 'xbm ':file file-xbm)
786 ;; Then the simple string
787 ,(vector 'string ':data "Gnus:")))))
778 (set-glyph-face glyph 'modeline-buffer-id) 788 (set-glyph-face glyph 'modeline-buffer-id)
779 glyph))) 789 glyph)))
780 790
781 (defun gnus-xmas-mode-line-buffer-identification (line) 791 (defun gnus-xmas-mode-line-buffer-identification (line)
782 (let ((line (car line)) 792 (let ((line (car line))