From 299c947dde266c2d2cec625b91c662a3c9f71dad Mon Sep 17 00:00:00 2001 From: Didier Verna Date: Mon, 23 Jun 2003 17:54:51 +0000 Subject: [PATCH 1/1] lisp/ChangeLog addition: 2003-06-23 Didier Verna * 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. --- lisp/ChangeLog | 20 ++++++++++++++ lisp/gnus-art.el | 67 +++++++++++++++++++++++++++------------------- lisp/gnus-ems.el | 9 ++++--- lisp/gnus-fun.el | 2 +- lisp/gnus-picon.el | 39 ++++++++++++++++----------- lisp/gnus-xmas.el | 8 +++--- lisp/smiley.el | 2 +- 7 files changed, 95 insertions(+), 52 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 1233ebc3e..ab1ccaee8 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,23 @@ +2003-06-23 Didier Verna + + * 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 * gnus-art.el (article-display-face): Check for existence of the diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 4f8268a8b..3455ab274 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -243,8 +243,8 @@ regexp. If it matches, the text in question is not a signature." :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) @@ -1976,30 +1976,40 @@ unfolded." (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." @@ -2009,7 +2019,8 @@ unfolded." ;; 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) @@ -4851,7 +4862,7 @@ is the string to use when it is inactive.") "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))) diff --git a/lisp/gnus-ems.el b/lisp/gnus-ems.el index a9ab259b4..14d91b18b 100644 --- a/lisp/gnus-ems.el +++ b/lisp/gnus-ems.el @@ -219,16 +219,19 @@ (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)))))) diff --git a/lisp/gnus-fun.el b/lisp/gnus-fun.el index a174779cb..ca5cdea29 100644 --- a/lisp/gnus-fun.el +++ b/lisp/gnus-fun.el @@ -192,7 +192,7 @@ colors of the displayed X-Faces." (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 () diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index 9844b0753..a3fd19478 100644 --- a/lisp/gnus-picon.el +++ b/lisp/gnus-picon.el @@ -139,7 +139,7 @@ GLYPH can be either a glyph or a string." (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)) @@ -231,37 +231,46 @@ GLYPH can be either a glyph or a string." ;;; 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) diff --git a/lisp/gnus-xmas.el b/lisp/gnus-xmas.el index d5e46f849..d69b297fa 100644 --- a/lisp/gnus-xmas.el +++ b/lisp/gnus-xmas.el @@ -834,7 +834,7 @@ XEmacs compatibility workaround." (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)) @@ -845,21 +845,21 @@ Warning: Don't insert text immediately after the image." (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) diff --git a/lisp/smiley.el b/lisp/smiley.el index a85a17001..8c1282d0b 100644 --- a/lisp/smiley.el +++ b/lisp/smiley.el @@ -132,7 +132,7 @@ A list of images is returned." (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 -- 2.25.1