From 08a980a4007fe7543cdc47af072dfbd834319927 Mon Sep 17 00:00:00 2001 From: Lars Magne Ingebrigtsen Date: Tue, 9 Dec 2014 22:32:44 +0000 Subject: [PATCH] lisp/gnus/gnus-art.el: Refactored out gnus-article-mime-handles --- lisp/gnus/ChangeLog | 8 +- lisp/gnus/gnus-art.el | 198 +++++++++++++++++++++--------------------- 2 files changed, 104 insertions(+), 102 deletions(-) diff --git a/lisp/gnus/ChangeLog b/lisp/gnus/ChangeLog index 2f0641f139c..d8dd1d3b5fd 100644 --- a/lisp/gnus/ChangeLog +++ b/lisp/gnus/ChangeLog @@ -1,3 +1,9 @@ +2014-12-09 Lars Magne Ingebrigtsen + + * gnus-art.el (gnus-article-mime-handles): Refactored out into own + function for reuse. + (gnus-mime-buttonize-attachments-in-header): Adjusted. + 2014-12-07 Lars Magne Ingebrigtsen * message.el (message-change-subject): Really check whether the subject @@ -13,7 +19,7 @@ * gnus-cloud.el (gnus-cloud): Add :version tag. -2014-11-29 John Mastro (tiny change) +2014-11-29 John Mastro (tiny change) * auth-source.el (auth-source-macos-keychain-search-items): Return result of `auth-source-macos-keychain-result-append' (bug#19074). diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 62a60b20111..53da05e939b 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -6335,6 +6335,40 @@ Provided for backwards compatibility." (when image (gnus-add-image 'shr image)))) +(defun gnus-article-mime-handles (&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 (gnus-article-mime-handles + (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 (gnus-article-mime-handles + (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))) + (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 @@ -6342,108 +6376,70 @@ 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) + (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 (gnus-article-mime-handles)) + (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 - ;; 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)))))))))) + ;; 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. -- 2.39.2