diff options
Diffstat (limited to 'lisp/gnus/gnus-art.el')
| -rw-r--r-- | lisp/gnus/gnus-art.el | 394 |
1 files changed, 308 insertions, 86 deletions
diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 29d70aa1a86..b08e523c440 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -24,9 +24,6 @@ ;;; Code: -;; For Emacs <22.2 and XEmacs. -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile (require 'cl)) (defvar tool-bar-map) @@ -4728,7 +4725,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." gnus-article-image-alist nil) (gnus-run-hooks 'gnus-tmp-internal-hook) (when gnus-display-mime-function - (funcall gnus-display-mime-function)))) + (funcall gnus-display-mime-function)) + ;; Add attachment buttons to the header. + (when gnus-mime-display-attachment-buttons-in-header + (gnus-mime-buttonize-attachments-in-header)))) ;;; ;;; Gnus Sticky Article Mode @@ -4987,7 +4987,6 @@ and `gnus-mime-delete-part', and not provided at run-time normally." (gnus-article-edit-article `(lambda () (buffer-disable-undo) - (erase-buffer) (let ((mail-parse-charset (or gnus-article-charset ',gnus-newsgroup-charset)) (mail-parse-ignored-charsets @@ -4995,7 +4994,14 @@ and `gnus-mime-delete-part', and not provided at run-time normally." ',gnus-newsgroup-ignored-charsets)) (mbl mml-buffer-list)) (setq mml-buffer-list nil) - (insert-buffer-substring gnus-original-article-buffer) + ;; A new text must be inserted before deleting existing ones + ;; at the end so as not to move existing markers of which + ;; the insertion type is t. + (delete-region + (point-min) + (prog1 + (goto-char (point-max)) + (insert-buffer-substring gnus-original-article-buffer))) (mime-to-mml ',handles) (setq gnus-article-mime-handles nil) (let ((mbl1 mml-buffer-list)) @@ -5300,12 +5306,26 @@ are decompressed." Compressed files like .gz and .bz2 are decompressed." (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) - (unless handle - (setq handle (get-text-property (point) 'gnus-data))) - (when handle - (let ((b (point)) - (inhibit-read-only t) - contents charset coding-system) + (let* ((inhibit-read-only t) + (b (point)) + (btn ;; position where the MIME button exists + (if handle + (if (eq handle (get-text-property b 'gnus-data)) + b + (article-goto-body) + (or (text-property-any (point) (point-max) 'gnus-data handle) + (text-property-any (point-min) (point) 'gnus-data handle))) + (setq handle (get-text-property b 'gnus-data)) + b)) + start contents charset coding-system) + (when handle + (when (= b (prog1 + btn + (setq start (next-single-property-change btn 'gnus-data + nil (point-max)) + btn (previous-single-property-change start + 'gnus-data)))) + (setq b btn)) (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) (mm-with-unibyte-buffer @@ -5331,9 +5351,48 @@ Compressed files like .gz and .bz2 are decompressed." (mm-read-coding-system "Charset: ")))) ((mm-handle-undisplayer handle) (mm-remove-part handle))) - (forward-line 2) - (mm-display-inline handle) - (goto-char b))))) + (goto-char start) + (unless (bolp) + ;; This is a header button. + (forward-line 1)) + (mm-display-inline handle)) + ;; Toggle the button appearance between `[button]...' and `[button]'. + (goto-char btn) + (let ((displayed-p (mm-handle-displayed-p handle))) + (gnus-insert-mime-button handle (get-text-property btn 'gnus-part) + (list displayed-p)) + (if (featurep 'emacs) + (delete-region + (point) + (next-single-property-change (point) 'gnus-data nil (point-max))) + (let* ((end (next-single-property-change (point) 'gnus-data)) + (annots (annotations-at (or end (point-max))))) + (delete-region (point) + (if end + (if annots (1+ end) end) + (point-max))) + (dolist (annot annots) + (set-extent-endpoints annot (point) (point))))) + (setq start (point)) + (if (search-backward "\n\n" nil t) + (progn + (goto-char start) + (unless (or displayed-p (eolp)) + ;; Add extra newline. + (insert (propertize (buffer-substring (1- start) start) + 'gnus-undeletable t)))) + ;; We're in the article header. + (delete-char -1) + (dolist (ovl (gnus-overlays-in btn (point))) + (gnus-overlay-put ovl 'gnus-button-attachment-extra t) + (gnus-overlay-put ovl 'face nil)) + (save-restriction + (message-narrow-to-field) + (let ((gnus-treatment-function-alist + '((gnus-treat-highlight-headers + gnus-article-highlight-headers)))) + (gnus-treat-article 'head))))) + (goto-char b)))) (defun gnus-mime-set-charset-parameters (handle charset) "Set CHARSET to parameters in HANDLE. @@ -5635,54 +5694,106 @@ all parts." "Display HANDLE and fix MIME button." (let ((id (get-text-property (point) 'gnus-part)) (point (point)) - (inhibit-read-only t)) - (forward-line 1) - (prog1 - (let ((window (selected-window)) - (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets - (if (gnus-buffer-live-p gnus-summary-buffer) - (with-current-buffer gnus-summary-buffer - gnus-newsgroup-ignored-charsets) - nil))) - (save-excursion - (unwind-protect - (let ((win (gnus-get-buffer-window (current-buffer) t)) - (beg (point))) - (when win - (select-window win)) - (goto-char point) - (forward-line) - (if (mm-handle-displayed-p handle) - ;; This will remove the part. - (mm-display-part handle) - (save-restriction - (narrow-to-region (point) - (if (eobp) (point) (1+ (point)))) - (gnus-bind-safe-url-regexp (mm-display-part handle)) - ;; We narrow to the part itself and - ;; then call the treatment functions. - (goto-char (point-min)) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (gnus-treat-article - nil id - (gnus-article-mime-total-parts) - (mm-handle-media-type handle))))) - (if (window-live-p window) - (select-window window))))) + (inhibit-read-only t) + (window (selected-window)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets) + nil)) + start retval) + (unwind-protect + (progn + (let ((win (gnus-get-buffer-window (current-buffer) t))) + (when win + (select-window win) + (goto-char point))) + (setq start (next-single-property-change point 'gnus-data + nil (point-max)) + point (previous-single-property-change start 'gnus-data)) + (if (mm-handle-displayed-p handle) + ;; This will remove the part. + (setq retval (mm-display-part handle)) + (let ((part (or (and (mm-inlinable-p handle) + (mm-inlined-p handle) + t) + (with-temp-buffer + (gnus-bind-safe-url-regexp + (setq retval (mm-display-part handle))) + (unless (zerop (buffer-size)) + (buffer-string)))))) + (goto-char start) + (unless (bolp) + ;; This is a header button. + (forward-line 1)) + (cond ((stringp part) + (save-restriction + (narrow-to-region (point) + (progn + (insert part) + (unless (bolp) (insert "\n")) + (point))) + (gnus-treat-article nil id + (gnus-article-mime-total-parts) + (mm-handle-media-type handle)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t)) + (delete-region ,(copy-marker (point-min) t) + ,(point-max-marker))))))) + (part + (mm-display-inline handle)))))) (goto-char point) - (gnus-delete-line) - (gnus-insert-mime-button - handle id (list (mm-handle-displayed-p handle))) - (goto-char point)))) + ;; Toggle the button appearance between `[button]...' and `[button]'. + (let ((displayed-p (mm-handle-displayed-p handle))) + (gnus-insert-mime-button handle id (list displayed-p)) + (if (featurep 'emacs) + (delete-region + (point) + (next-single-property-change (point) 'gnus-data nil (point-max))) + (let* ((end (next-single-property-change (point) 'gnus-data)) + (annots (annotations-at (or end (point-max))))) + (delete-region (point) + (if end + (if annots (1+ end) end) + (point-max))) + (dolist (annot annots) + (set-extent-endpoints annot (point) (point))))) + (setq start (point)) + (if (search-backward "\n\n" nil t) + (progn + (goto-char start) + (unless (or displayed-p (eolp)) + ;; Add extra newline. + (insert (propertize (buffer-substring (1- start) start) + 'gnus-undeletable t)))) + ;; We're in the article header. + (delete-char -1) + (dolist (ovl (gnus-overlays-in point (point))) + (gnus-overlay-put ovl 'gnus-button-attachment-extra t) + (gnus-overlay-put ovl 'face nil)) + (save-restriction + (message-narrow-to-field) + (let ((gnus-treatment-function-alist + '((gnus-treat-highlight-headers + gnus-article-highlight-headers)))) + (gnus-treat-article 'head))))) + (goto-char point) + (if (window-live-p window) + (select-window window))) + retval)) (defun gnus-article-goto-part (n) "Go to MIME part N." (when gnus-break-pages (widen)) + (article-goto-body) (prog1 - (let ((start (text-property-any (point-min) (point-max) 'gnus-part n)) + (let ((start (or (text-property-any (point) (point-max) 'gnus-part n) + ;; There may be header buttons. + (text-property-any (point-min) (point) 'gnus-part n))) part handle end next handles) (when start (goto-char start) @@ -5736,8 +5847,6 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) - (unless (bolp) - (insert "\n")) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5862,6 +5971,16 @@ If displaying \"text/html\" is discouraged \(see :group 'gnus-article-mime :type 'boolean) +(defcustom gnus-mime-display-attachment-buttons-in-header t + "Add attachment buttons in the end of the header of an article. +Since MIME attachments tend to be put at the end of an article, we may +overlook them if there is a huge body. This option offers you a copy +of all non-inlinable MIME parts as buttons shown in front of an article. +If nil, don't show those extra buttons." + :version "24.5" + :group 'gnus-article-mime + :type 'boolean) + (defun gnus-mime-display-part (handle) (cond ;; Maybe a broken MIME message. @@ -5884,14 +6003,6 @@ If displaying \"text/html\" is discouraged \(see ((and (equal (car handle) "multipart/related") (not (or gnus-mime-display-multipart-as-mixed gnus-mime-display-multipart-related-as-mixed))) - ;;;!!!We should find the start part, but we just default - ;;;!!!to the first part. - ;;(gnus-mime-display-part (cadr handle)) - ;;;!!! Most multipart/related is an HTML message plus images. - ;;;!!! Unfortunately we are unable to let W3 display those - ;;;!!! included images, so we just display it as a mixed multipart. - ;;(gnus-mime-display-mixed (cdr handle)) - ;;;!!! No, w3 can display everything just fine. (gnus-mime-display-part (cadr handle))) ((equal (car handle) "multipart/signed") (gnus-add-wash-type 'signed) @@ -5915,7 +6026,6 @@ If displaying \"text/html\" is discouraged \(see (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) (not-attachment t) - (move nil) display text) (catch 'ignored (progn @@ -5941,9 +6051,11 @@ If displaying \"text/html\" is discouraged \(see (setq display t) (when (equal (mm-handle-media-supertype handle) "text") (setq text t))) - (let ((id (1+ (length gnus-article-mime-handle-alist))) + (let ((id (car (rassq handle gnus-article-mime-handle-alist))) beg) - (push (cons id handle) gnus-article-mime-handle-alist) + (unless id + (setq id (1+ (length gnus-article-mime-handle-alist))) + (push (cons id handle) gnus-article-mime-handle-alist)) (when (and display (equal (mm-handle-media-supertype handle) "message")) (insert-char @@ -5955,31 +6067,28 @@ If displaying \"text/html\" is discouraged \(see (not (gnus-unbuttonized-mime-type-p type)) (eq id gnus-mime-buttonized-part-id)) (gnus-insert-mime-button - handle id (list (or display (and not-attachment text)))) - (gnus-article-insert-newline) - ;; Remember modify the number of forward lines. - (setq move t)) + handle id (list (or display (and not-attachment text))))) (setq beg (point)) (cond (display - (when move - (forward-line -1) - (setq beg (point))) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-excursion (condition-case () (set-buffer gnus-summary-buffer) (error)) gnus-newsgroup-ignored-charsets))) - (gnus-bind-safe-url-regexp (mm-display-part handle t))) - (goto-char (point-max))) + (gnus-bind-safe-url-regexp (mm-display-part handle t)))) ((and text not-attachment) - (when move - (forward-line -1) - (setq beg (point))) - (gnus-article-insert-newline) - (mm-display-inline handle) - (goto-char (point-max)))) + (mm-display-inline handle))) + (goto-char (point-max)) + (if (string-match "\\`image/" type) + (gnus-article-insert-newline) + (if (prog1 + (= (skip-chars-backward "\n") -1) + (forward-char 1)) + (gnus-article-insert-newline) + (put-text-property (point) (point-max) 'gnus-undeletable t)) + (goto-char (point-max))) ;; Do highlighting. (save-excursion (save-restriction @@ -6110,7 +6219,10 @@ If displaying \"text/html\" is discouraged \(see (goto-char (point-max)) (setcdr begend (point-marker))))) (when ibegend - (goto-char point)))) + (goto-char point))) + ;; Redraw attachment buttons in the header. + (when gnus-mime-display-attachment-buttons-in-header + (gnus-mime-buttonize-attachments-in-header))) (defconst gnus-article-wash-status-strings (let ((alist '((cite "c" "Possible hidden citation text" @@ -6216,6 +6328,116 @@ Provided for backwards compatibility." (when image (gnus-add-image 'shr image)))) +(defun gnus-mime-buttonize-attachments-in-header (&optional interactive) + "Show attachments as buttons in the end of the header of an article. +This function toggles the display when called interactively. Note that +buttons to be added to the header are only the ones that aren't inlined +in the body. Use `gnus-header-face-alist' to highlight buttons." + (interactive (list t)) + (gnus-with-article-buffer + (gmm-labels + ;; Function that returns a flattened version of + ;; `gnus-article-mime-handle-alist'. + ((flattened-alist + (&optional alist id all) + (if alist + (let ((i 1) newid flat) + (dolist (handle alist flat) + (setq newid (append id (list i)) + i (1+ i)) + (if (stringp (car handle)) + (setq flat (nconc flat (flattened-alist (cdr handle) + newid all))) + (delq (rassq handle all) all) + (setq flat (nconc flat (list (cons newid handle))))))) + (let ((flat (list nil))) + ;; Assume that elements of `gnus-article-mime-handle-alist' + ;; are in the decreasing order, but unnumbered subsidiaries + ;; in each element are in the increasing order. + (dolist (handle (reverse gnus-article-mime-handle-alist)) + (if (stringp (cadr handle)) + (setq flat (nconc flat (flattened-alist (cddr handle) + (list (car handle)) + flat))) + (delq (rassq (cdr handle) flat) flat) + (setq flat (nconc flat (list (cons (list (car handle)) + (cdr handle))))))) + (setq flat (cdr flat)) + (mapc (lambda (handle) + (if (cdar handle) + ;; This is a hidden (i.e. unnumbered) handle. + (progn + (setcar handle + (1+ (caar gnus-article-mime-handle-alist))) + (push handle gnus-article-mime-handle-alist)) + (setcar handle (caar handle)))) + flat) + flat)))) + (let ((case-fold-search t) buttons handle type st) + (save-excursion + (save-restriction + (widen) + (article-narrow-to-head) + ;; Header buttons exist? + (while (and (not buttons) + (re-search-forward "^attachments?:[\n ]+" nil t)) + (when (get-char-property (match-end 0) + 'gnus-button-attachment-extra) + (setq buttons (match-beginning 0)))) + (widen) + (when buttons + ;; Delete header buttons. + (delete-region buttons (if (re-search-forward "^[^ ]" nil t) + (match-beginning 0) + (point-max)))) + (unless (and interactive buttons) + ;; Find buttons. + (setq buttons nil) + (dolist (button (flattened-alist)) + (setq handle (cdr button) + type (mm-handle-media-type handle)) + (when (or (and (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-inhibit-images) + gnus-inhibit-images) + (string-match "\\`image/" type)) + (mm-inline-override-p handle) + (and (mm-handle-disposition handle) + (not (equal (car (mm-handle-disposition handle)) + "inline")) + (not (mm-attachment-override-p handle))) + (not (mm-automatic-display-p handle)) + (not (or (and (mm-inlinable-p handle) + (mm-inlined-p handle)) + (mm-automatic-external-display-p type)))) + (push button buttons))) + (when buttons + ;; Add header buttons. + (article-goto-body) + (forward-line -1) + (narrow-to-region (point) (point)) + (insert "Attachment" (if (cdr buttons) "s" "") ":") + (dolist (button (nreverse buttons)) + (setq st (point)) + (insert " ") + (mm-handle-set-undisplayer + (setq handle (copy-sequence (cdr button))) nil) + (gnus-insert-mime-button handle (car button)) + (skip-chars-backward "\t\n ") + (delete-region (point) (point-max)) + (when (> (current-column) (window-width)) + (goto-char st) + (insert "\n") + (end-of-line))) + (insert "\n") + (dolist (ovl (gnus-overlays-in (point-min) (point))) + (gnus-overlay-put ovl 'gnus-button-attachment-extra t) + (gnus-overlay-put ovl 'face nil)) + (let ((gnus-treatment-function-alist + '((gnus-treat-highlight-headers + gnus-article-highlight-headers)))) + (gnus-treat-article 'head)))))))))) + ;;; Article savers. (defun gnus-output-to-file (file-name) @@ -6584,7 +6806,7 @@ not have a face in `gnus-article-boring-faces'." (when (eq obuf (current-buffer)) (set-buffer in-buffer) t)) - (setq selected (gnus-summary-select-article)) + (setq selected (ignore-errors (gnus-summary-select-article))) (set-buffer obuf) (unless not-restore-window (set-window-configuration owin)) |