(error "Can't find glyph directory. \
Possibly the `etc' directory has not been installed.")))
-;;(format "%02x%02x%02x" 114 66 20) "724214"
-
-(defvar gnus-xmas-logo-color-alist
- '((flame "#cc3300" "#ff2200")
- (pine "#c0cc93" "#f8ffb8")
- (moss "#a1cc93" "#d2ffb8")
- (irish "#04cc90" "#05ff97")
- (sky "#049acc" "#05deff")
- (tin "#6886cc" "#82b6ff")
- (velvet "#7c68cc" "#8c82ff")
- (grape "#b264cc" "#cf7df")
- (labia "#cc64c2" "#fd7dff")
- (berry "#cc6485" "#ff7db5")
- (dino "#724214" "#1e3f03")
- (neutral "#b4b4b4" "#878787")
- (september "#bf9900" "#ffcc00"))
- "Color alist used for the Gnus logo.")
-
-(defcustom gnus-xmas-logo-color-style 'dino
- "*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)
- (const dino))
- :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.")
-
-(defcustom gnus-article-x-face-command
- (if (or (featurep 'xface)
- (featurep 'xpm))
- 'gnus-xmas-article-display-xface
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -")
- "*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."
- :type '(choice string function))
-
;;; Internal variables.
;; Don't warn about these undefined variables.
(if (stringp buffer)
nil
(map-extents (lambda (extent ignored)
- (remove-text-properties
- start end
- (list (extent-property extent 'text-prop) nil)
- buffer)
+ (remove-text-properties
+ start end
+ (list (extent-property extent 'text-prop) nil)
+ buffer)
nil)
- buffer start end nil nil 'text-prop)
+ buffer start end nil nil 'text-prop)
(gnus-add-text-properties start end props buffer)))
(defun gnus-xmas-highlight-selected-summary ()
(defun gnus-xmas-appt-select-lowest-window ()
(let* ((lowest-window (selected-window))
(bottom-edge (car (cdr (cdr (cdr (window-pixel-edges))))))
- (last-window (previous-window))
- (window-search t))
+ (last-window (previous-window))
+ (window-search t))
(while window-search
(let* ((this-window (next-window))
- (next-bottom-edge (car (cdr (cdr (cdr
- (window-pixel-edges
+ (next-bottom-edge (car (cdr (cdr (cdr
+ (window-pixel-edges
this-window)))))))
- (when (< bottom-edge next-bottom-edge)
+ (when (< bottom-edge next-bottom-edge)
(setq bottom-edge next-bottom-edge)
(setq lowest-window this-window))
- (select-window this-window)
- (when (eq last-window this-window)
+ (select-window this-window)
+ (when (eq last-window this-window)
(select-window lowest-window)
(setq window-search nil))))))
(defalias 'gnus-put-text-property 'gnus-xmas-put-text-property)
(defalias 'gnus-deactivate-mark 'ignore)
(defalias 'gnus-window-edges 'window-pixel-edges)
-
+
(if (and (<= emacs-major-version 19)
(< emacs-minor-version 14))
(defalias 'gnus-set-text-properties 'gnus-xmas-set-text-properties))
(defalias 'gnus-region-active-p 'region-active-p)
(defalias 'gnus-annotation-in-region-p 'gnus-xmas-annotation-in-region-p)
(defalias 'gnus-mime-button-menu 'gnus-xmas-mime-button-menu)
+ (defalias 'gnus-image-type-available-p 'gnus-xmas-image-type-available-p)
+ (defalias 'gnus-put-image 'gnus-xmas-put-image)
+ (defalias 'gnus-create-image 'gnus-xmas-create-image)
+ (defalias 'gnus-remove-image 'gnus-xmas-remove-image)
;; These ones are not defcutom'ed, sometimes not even defvar'ed. They
;; probably should. If that is done, the code below should then be moved
`[xpm
:file ,logo-xpm
:color-symbols
- (("thing" . ,(car gnus-xmas-logo-colors))
- ("shadow" . ,(cadr gnus-xmas-logo-colors))
+ (("thing" . ,(car gnus-logo-colors))
+ ("shadow" . ,(cadr gnus-logo-colors))
("background" . ,(face-background 'default)))])
((featurep 'xbm)
`[xbm :file ,logo-xbm])
(cons (current-buffer) bar)))))
(defun gnus-xmas-mail-strip-quoted-names (address)
- "Protect mail-strip-quoted-names from NIL input.
+ "Protect mail-strip-quoted-names from nil input.
XEmacs compatibility workaround."
(if (null address)
nil
"Face to show X face"
:group 'gnus-xmas)
-(defun gnus-xmas-article-display-xface (beg end &optional buffer)
- "Display any XFace headers in BUFFER."
+(defun gnus-xmas-article-display-xface (data)
+ "Display the XFace in DATA."
(save-excursion
(let ((xface-glyph
(cond
((featurep 'xface)
(make-glyph (vector 'xface :data
- (concat "X-Face: "
- (if buffer
- (with-current-buffer buffer
- (buffer-substring beg end))
- (buffer-substring beg end))))))
+ (concat "X-Face: " data))))
((featurep 'xpm)
- (let ((cur (or buffer (current-buffer))))
+ (let ((cur (current-buffer)))
(save-excursion
(gnus-set-work-buffer)
- (insert-buffer-substring cur beg end)
+ (insert data)
(let ((coding-system-for-read 'binary)
(coding-system-for-write 'binary))
(gnus-xmas-call-region "uncompface")
(make-glyph
(vector 'xpm :data (buffer-string)))))))
(t
- (make-glyph [nothing]))))
- (ext (make-extent (progn
- (goto-char (point-min))
- (re-search-forward "^From:" nil t)
- (point))
- (1+ (point)))))
- (set-glyph-face xface-glyph 'gnus-x-face)
- (set-extent-begin-glyph ext xface-glyph)
- (set-extent-property ext 'duplicable t))))
+ (make-glyph [nothing])))))
+ ;;(set-glyph-face xface-glyph 'gnus-x-face)
+
+ (gnus-article-goto-header "from")
+ (gnus-put-image xface-glyph " ")
+ (gnus-add-wash-type 'xface)
+ (gnus-add-image 'xface xface-glyph))))
(defvar gnus-xmas-modeline-left-extent
(let ((ext (copy-extent modeline-buffer-id-left-extent)))
(gnus-xmas-menu-add mailing-list
gnus-mailing-list-menu))
+(defun gnus-xmas-image-type-available-p (type)
+ (featurep type))
+
+(defun gnus-xmas-create-image (file)
+ (with-temp-buffer
+ (insert-file-contents file)
+ (mm-create-image-xemacs (car (last (split-string file "[.]"))))))
+
+(defun gnus-xmas-put-image (glyph &optional string)
+ (let ((begin (point))
+ extent)
+ (insert string)
+ (setq extent (make-extent begin (point)))
+ (set-extent-property extent 'gnus-image t)
+ (set-extent-property extent 'duplicable t)
+ (set-extent-property extent 'begin-glyph glyph)))
+
+(defun gnus-xmas-remove-image (image)
+ (map-extents
+ (lambda (ext unused)
+ (when (equal (extent-begin-glyph ext) image)
+ (set-extent-property ext 'begin-glyph nil))
+ nil)
+ nil nil nil nil nil 'gnus-image))
+
(provide 'gnus-xmas)
;;; gnus-xmas.el ends here
projects / elisp / gnus.git- / blobdiff