+2003-06-23 Didier Verna <didier@xemacs.org>
+
+ * gnus-ems.el (gnus-put-image): New argument CATEGORY. Add it as a
+ text property.
+ (gnus-remove-image): New argument CATEGORY. Only remove if
+ category matches.
+ * gnus-xmas.el (gnus-xmas-put-image):
+ (gnus-xmas-remove-image): Ditto, with extents.
+ * gnus-art.el (gnus-delete-images): Pass CATEGORY argument to
+ gnus-[xmas-]remove-image.
+ (article-display-face): Don't always act as a toggle. Call
+ `gnus-put-image' with CATEGORY argument.
+ (article-display-x-face): Call `gnus-put-image' with CATEGORY
+ argument.
+ * smiley.el (smiley-region): Ditto.
+ * gnus-fun.el (gnus-display-x-face-in-from): Ditto.
+ * gnus-picon.el (gnus-picon-insert-glyph): Ditto.
+ (gnus-treat-mail-picon): Don't always act as a toggle.
+ * gnus-picon.el (gnus-treat-newsgroups-picon): Ditto.
+
2003-06-23 Didier Verna <didier@xemacs.org>
* gnus-art.el (article-display-face): Check for existence of the
:type 'sexp
:group 'gnus-article-hiding)
-;; Fixme: This isn't the right thing for mixed graphical and and
-;; non-graphical frames in a session.
+;; Fixme: This isn't the right thing for mixed graphical and non-graphical
+;; frames in a session.
(defcustom gnus-article-x-face-command
(if (featurep 'xemacs)
(if (or (gnus-image-type-available-p 'xface)
(defun article-display-face ()
"Display any Face headers in the header."
(interactive)
- (gnus-with-article-headers
- (if (memq 'face gnus-article-wash-types)
- (gnus-delete-images 'face)
- (let (face faces)
- (save-excursion
- (and (gnus-buffer-live-p gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer))
- (save-restriction
- (mail-narrow-to-head)
- (while (gnus-article-goto-header "Face")
- (push (mail-header-field-value) faces))))
- (while (setq face (pop faces))
- (let ((png (gnus-convert-face-to-png face))
- image)
- (when png
- (setq image (gnus-create-image png 'png t))
- (gnus-article-goto-header "from")
- (when (bobp)
- (insert "From: [no `from' set]\n")
- (forward-char -17))
- (gnus-add-wash-type 'face)
- (gnus-add-image 'face image)
- (gnus-put-image image))))))
- ))
+ (let ((wash-face-p buffer-read-only))
+ (gnus-with-article-headers
+ ;; When displaying parts, this function can be called several times on
+ ;; the same article, without any intended toggle semantic (as typing `W
+ ;; D d' would have). So face deletion must occur only when we come from
+ ;; an interactive command, that is when the *Article* buffer is
+ ;; read-only.
+ (if (and wash-face-p (memq 'face gnus-article-wash-types))
+ (gnus-delete-images 'face)
+ (let (face faces)
+ (save-excursion
+ (when (and wash-face-p
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward "^Face:[\t ]*" nil t)))
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ (set-buffer gnus-original-article-buffer))
+ (save-restriction
+ (mail-narrow-to-head)
+ (while (gnus-article-goto-header "Face")
+ (push (mail-header-field-value) faces))))
+ (while (setq face (pop faces))
+ (let ((png (gnus-convert-face-to-png face))
+ image)
+ (when png
+ (setq image (gnus-create-image png 'png t))
+ (gnus-article-goto-header "from")
+ (when (bobp)
+ (insert "From: [no `from' set]\n")
+ (forward-char -17))
+ (gnus-add-wash-type 'face)
+ (gnus-add-image 'face image)
+ (gnus-put-image image nil 'face))))))
+ )))
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
;; Delete the old process, if any.
(when (process-status "article-x-face")
(delete-process "article-x-face"))
- (if (memq 'xface gnus-article-wash-types)
+ ;; See the comment in `article-display-face'.
+ (if (and wash-face-p (memq 'xface gnus-article-wash-types))
;; We have already displayed X-Faces, so we remove them
;; instead.
(gnus-delete-images 'xface)
"Delete all images in CATEGORY."
(let ((entry (assq category gnus-article-image-alist)))
(dolist (image (cdr entry))
- (gnus-remove-image image))
+ (gnus-remove-image image category))
(setq gnus-article-image-alist (delq entry gnus-article-image-alist))
(gnus-delete-wash-type category)))
(setq props (plist-put props :background (face-background face))))
(apply 'create-image file type data-p props)))
-(defun gnus-put-image (glyph &optional string)
+(defun gnus-put-image (glyph &optional string category)
(insert-image glyph (or string " "))
+ (put-text-property (1- (point)) (point) 'gnus-image-category category)
(unless string
(put-text-property (1- (point)) (point)
'gnus-image-text-deletable t))
glyph)
-(defun gnus-remove-image (image)
+(defun gnus-remove-image (image &optional category)
(dolist (position (message-text-with-property 'display))
- (when (equal (get-text-property position 'display) image)
+ (when (and (equal (get-text-property position 'display) image)
+ (equal (get-text-property position 'gnus-image-category)
+ category))
(put-text-property position (1+ position) 'display nil)
(when (get-text-property position 'gnus-image-text-deletable)
(delete-region position (1+ position))))))
(concat "X-Face: " data)
'xface t :face 'gnus-x-face)
(gnus-create-image
- pbm 'pbm t :face 'gnus-x-face))))
+ pbm 'pbm t :face 'gnus-x-face)) nil 'xface))
(gnus-add-wash-type 'xface))))))
(defun gnus-grab-cam-x-face ()
(insert glyph)
(gnus-add-wash-type category)
(gnus-add-image category (car glyph))
- (gnus-put-image (car glyph) (cdr glyph))))
+ (gnus-put-image (car glyph) (cdr glyph) category)))
(defun gnus-picon-create-glyph (file)
(or (cdr (assoc file gnus-picon-glyph-alist))
;;; Commands:
+;; #### NOTE: the test for buffer-read-only is the same as in
+;; article-display-[x-]face. See the comment up there.
+
;;;###autoload
(defun gnus-treat-from-picon ()
"Display picons in the From header.
If picons are already displayed, remove them."
(interactive)
- (gnus-with-article-buffer
- (if (memq 'from-picon gnus-article-wash-types)
- (gnus-delete-images 'from-picon)
- (gnus-picon-transform-address "from" 'from-picon))))
+ (let ((wash-picon-p buffer-read-only))
+ (gnus-with-article-buffer
+ (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types))
+ (gnus-delete-images 'from-picon)
+ (gnus-picon-transform-address "from" 'from-picon)))
+ ))
;;;###autoload
(defun gnus-treat-mail-picon ()
"Display picons in the Cc and To headers.
If picons are already displayed, remove them."
(interactive)
- (gnus-with-article-buffer
- (if (memq 'mail-picon gnus-article-wash-types)
- (gnus-delete-images 'mail-picon)
- (gnus-picon-transform-address "cc" 'mail-picon)
- (gnus-picon-transform-address "to" 'mail-picon))))
+ (let ((wash-picon-p buffer-read-only))
+ (gnus-with-article-buffer
+ (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types))
+ (gnus-delete-images 'mail-picon)
+ (gnus-picon-transform-address "cc" 'mail-picon)
+ (gnus-picon-transform-address "to" 'mail-picon)))
+ ))
;;;###autoload
(defun gnus-treat-newsgroups-picon ()
"Display picons in the Newsgroups and Followup-To headers.
If picons are already displayed, remove them."
(interactive)
- (gnus-with-article-buffer
- (if (memq 'newsgroups-picon gnus-article-wash-types)
- (gnus-delete-images 'newsgroups-picon)
- (gnus-picon-transform-newsgroups "newsgroups")
- (gnus-picon-transform-newsgroups "followup-to"))))
+ (let ((wash-picon-p buffer-read-only))
+ (gnus-with-article-buffer
+ (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types))
+ (gnus-delete-images 'newsgroups-picon)
+ (gnus-picon-transform-newsgroups "newsgroups")
+ (gnus-picon-transform-newsgroups "followup-to")))
+ ))
(provide 'gnus-picon)
(set-glyph-face glyph face))
glyph))
-(defun gnus-xmas-put-image (glyph &optional string)
+(defun gnus-xmas-put-image (glyph &optional string category)
"Insert STRING, but display GLYPH.
Warning: Don't insert text immediately after the image."
(let ((begin (point))
(insert string)
(setq begin (1- begin)))
(setq extent (make-extent begin (point)))
- (set-extent-property extent 'gnus-image t)
+ (set-extent-property extent 'gnus-image category)
(set-extent-property extent 'duplicable t)
(if string
(set-extent-property extent 'invisible t))
(set-extent-property extent 'end-glyph glyph))
glyph)
-(defun gnus-xmas-remove-image (image)
+(defun gnus-xmas-remove-image (image &optional category)
(map-extents
(lambda (ext unused)
(when (equal (extent-end-glyph ext) image)
(set-extent-property ext 'invisible nil)
(set-extent-property ext 'end-glyph nil))
nil)
- nil nil nil nil nil 'gnus-image))
+ nil nil nil nil nil 'gnus-image category))
(defun gnus-xmas-completing-read (prompt table &optional
predicate require-match history)
(push image images)
(gnus-add-wash-type 'smiley)
(gnus-add-image 'smiley image)
- (gnus-put-image image string))))
+ (gnus-put-image image string 'smiley))))
images))))
;;;###autoload
projects / gnus / commitdiff