* [COMMIT] More image fixes
@ 2003-06-23 17:53 Didier Verna
2003-06-23 17:56 ` Didier Verna
0 siblings, 1 reply; 2+ messages in thread
From: Didier Verna @ 2003-06-23 17:53 UTC (permalink / raw)
NOTE: This patch has been committed. The version below is
informational only (whitespace differences have been removed).
Dear folks,
The following patch fixes different bugs in image handling, especially
one reported recently and one apparently unnoticed until now: images can be
shared by different categories, but removing one category actually removed all
images instances, even those belonging to another category.
One bug I just discovered is still there: with attached messages, everything
is correctly displayed first, but after removing the images and requesting
them again (WDd WDx etc), the ones in the attached message are not displayed
anymore.
lisp/ChangeLog addition:
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.
Gnus source patch:
Diff command: runsocks cvs -q diff -u -t -b -B -w
Files affected: lisp/smiley.el lisp/gnus-picon.el lisp/gnus-fun.el lisp/gnus-xmas.el lisp/gnus-ems.el lisp/gnus-art.el
Index: lisp/gnus-art.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/gnus-art.el,v
retrieving revision 6.352
diff -u -u -t -b -B -w -r6.352 gnus-art.el
--- lisp/gnus-art.el 23 Jun 2003 12:13:32 -0000 6.352
+++ lisp/gnus-art.el 23 Jun 2003 17:34:35 -0000
@@ -243,8 +243,8 @@
: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,12 +1976,22 @@
(defun article-display-face ()
"Display any Face headers in the header."
(interactive)
+ (let ((wash-face-p buffer-read-only))
(gnus-with-article-headers
- (if (memq 'face gnus-article-wash-types)
+ ;; 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
- (and (gnus-buffer-live-p gnus-original-article-buffer)
+ (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)
@@ -1998,8 +2008,8 @@
(forward-char -17))
(gnus-add-wash-type 'face)
(gnus-add-image 'face image)
- (gnus-put-image 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 @@
;; 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 @@
"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)))
Index: lisp/gnus-ems.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/gnus-ems.el,v
retrieving revision 6.26
diff -u -u -t -b -B -w -r6.26 gnus-ems.el
--- lisp/gnus-ems.el 2 May 2003 17:52:53 -0000 6.26
+++ lisp/gnus-ems.el 23 Jun 2003 17:34:35 -0000
@@ -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))))))
Index: lisp/gnus-xmas.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/gnus-xmas.el,v
retrieving revision 6.40
diff -u -u -t -b -B -w -r6.40 gnus-xmas.el
--- lisp/gnus-xmas.el 2 Jun 2003 22:52:57 -0000 6.40
+++ lisp/gnus-xmas.el 23 Jun 2003 17:34:35 -0000
@@ -834,7 +834,7 @@
(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 @@
(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)
Index: lisp/gnus-fun.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/gnus-fun.el,v
retrieving revision 6.47
diff -u -u -t -b -B -w -r6.47 gnus-fun.el
--- lisp/gnus-fun.el 13 May 2003 16:37:31 -0000 6.47
+++ lisp/gnus-fun.el 23 Jun 2003 17:34:35 -0000
@@ -192,7 +192,7 @@
(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 ()
Index: lisp/gnus-picon.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/gnus-picon.el,v
retrieving revision 6.25
diff -u -u -t -b -B -w -r6.25 gnus-picon.el
--- lisp/gnus-picon.el 8 May 2003 23:02:20 -0000 6.25
+++ lisp/gnus-picon.el 23 Jun 2003 17:34:35 -0000
@@ -139,7 +139,7 @@
(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 @@
;;; 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)
+ (let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
- (if (memq 'from-picon gnus-article-wash-types)
+ (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types))
(gnus-delete-images 'from-picon)
- (gnus-picon-transform-address "from" '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)
+ (let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
- (if (memq 'mail-picon gnus-article-wash-types)
+ (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))))
+ (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)
+ (let ((wash-picon-p buffer-read-only))
(gnus-with-article-buffer
- (if (memq 'newsgroups-picon gnus-article-wash-types)
+ (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"))))
+ (gnus-picon-transform-newsgroups "followup-to")))
+ ))
(provide 'gnus-picon)
Index: lisp/smiley.el
===================================================================
RCS file: /usr/local/cvsroot/gnus/lisp/smiley.el,v
retrieving revision 6.13
diff -u -u -t -b -B -w -r6.13 smiley.el
--- lisp/smiley.el 26 Mar 2003 20:48:26 -0000 6.13
+++ lisp/smiley.el 23 Jun 2003 17:34:35 -0000
@@ -132,7 +132,7 @@
(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
--
Didier Verna, didier@lrde.epita.fr, http://www.lrde.epita.fr/~didier
EPITA / LRDE, 14-16 rue Voltaire Tel.+33 (1) 44 08 01 85
94276 Le Kremlin-Bicêtre, France Fax.+33 (1) 53 14 59 22 didier@xemacs.org
^ permalink raw reply [flat|nested] 2+ messages in thread
* Re: [COMMIT] More image fixes
2003-06-23 17:53 [COMMIT] More image fixes Didier Verna
@ 2003-06-23 17:56 ` Didier Verna
0 siblings, 0 replies; 2+ messages in thread
From: Didier Verna @ 2003-06-23 17:56 UTC (permalink / raw)
I wrote:
> * 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.
BTW, somebody should check this part, because I don't use GNU Emacs.
Patch re-inserted below:
> Index: lisp/gnus-ems.el
> ===================================================================
> RCS file: /usr/local/cvsroot/gnus/lisp/gnus-ems.el,v
> retrieving revision 6.26
> diff -u -u -t -b -B -w -r6.26 gnus-ems.el
> --- lisp/gnus-ems.el 2 May 2003 17:52:53 -0000 6.26
> +++ lisp/gnus-ems.el 23 Jun 2003 17:34:35 -0000
> @@ -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))))))
--
Didier Verna, didier@lrde.epita.fr, http://www.lrde.epita.fr/~didier
EPITA / LRDE, 14-16 rue Voltaire Tel.+33 (1) 44 08 01 85
94276 Le Kremlin-Bicêtre, France Fax.+33 (1) 53 14 59 22 didier@xemacs.org
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2003-06-23 17:56 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2003-06-23 17:53 [COMMIT] More image fixes Didier Verna
2003-06-23 17:56 ` Didier Verna
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for NNTP newsgroup(s).