X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=5566b0ea324808aa6b09ca11ae30426912df7eda;hp=7e642aaa6fab9a7b29250c6ac1be4600d21c5b4d;hb=a9c30bf897ac1b3b6081260a6245c616f4be7a50;hpb=f036ee4b99935a15584186aad375afce769affe1 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 7e642aaa6..5566b0ea3 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,6 +1,6 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996-2013 Free Software Foundation, Inc. +;; Copyright (C) 1996-2014 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -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) @@ -1033,15 +1030,15 @@ Some of these headers are updated automatically. See `gnus-article-update-date-headers' for details." :version "24.1" :group 'gnus-article-headers - :type '(repeat - (item :tag "Universal time (UT)" :value 'ut) - (item :tag "Local time zone" :value 'local) - (item :tag "Readable English" :value 'english) - (item :tag "Elapsed time" :value 'lapsed) - (item :tag "Original and elapsed time" :value 'combined-lapsed) - (item :tag "Original date header" :value 'original) - (item :tag "ISO8601 format" :value 'iso8601) - (item :tag "User-defined" :value 'user-defined))) + :type '(set + (const :tag "Universal time (UT)" ut) + (const :tag "Local time zone" local) + (const :tag "Readable English" english) + (const :tag "Elapsed time" lapsed) + (const :tag "Original and elapsed time" combined-lapsed) + (const :tag "Original date header" original) + (const :tag "ISO8601 format" iso8601) + (const :tag "User-defined" user-defined))) (defcustom gnus-article-update-date-headers nil "A number that says how often to update the date header (in seconds). @@ -1652,7 +1649,7 @@ called with the group name as the parameter, and should return a regexp." :version "24.1" :group 'gnus-art - :type 'regexp) + :type '(choice regexp function)) ;;; Internal variables @@ -2666,7 +2663,7 @@ If READ-CHARSET, ask for a coding system." (string-match "quoted-printable" type)))) (article-goto-body) (quoted-printable-decode-region - (point) (point-max) (mm-charset-to-coding-system charset)))))) + (point) (point-max) (mm-charset-to-coding-system charset nil t)))))) (defun article-de-base64-unreadable (&optional force read-charset) "Translate a base64 article. @@ -2697,7 +2694,8 @@ If READ-CHARSET, ask for a coding system." (narrow-to-region (point) (point-max)) (base64-decode-region (point-min) (point-max)) (mm-decode-coding-region - (point-min) (point-max) (mm-charset-to-coding-system charset))))))) + (point-min) (point-max) + (mm-charset-to-coding-system charset nil t))))))) (eval-when-compile (require 'rfc1843)) @@ -2795,6 +2793,9 @@ Return file name." (dolist (handle handles) (cond ((not (listp handle))) + ;; Exclude broken handles that `gnus-summary-enter-digest-group' + ;; may create. + ((not (or (bufferp (car handle)) (stringp (car handle))))) ((equal (mm-handle-media-supertype handle) "multipart") (when (setq file (gnus-article-browse-html-save-cid-content cid handle directory)) @@ -2802,11 +2803,12 @@ Return file name." ((equal (concat "<" cid ">") (mm-handle-id handle)) (setq file (expand-file-name - (or (mm-handle-filename handle) - (concat - (make-temp-name "cid") - (car (rassoc (car (mm-handle-type handle)) mailcap-mime-extensions)))) - directory)) + (or (mm-handle-filename handle) + (concat + (make-temp-name "cid") + (car (rassoc (car (mm-handle-type handle)) + mailcap-mime-extensions)))) + directory)) (mm-save-part-to-file handle file) (throw 'found file)))))))) @@ -2892,6 +2894,13 @@ message header will be added to the bodies of the \"text/html\" parts." ((match-beginning 3) "&") (t "
\n")))) (goto-char (point-min)) + (while (re-search-forward "^[\t ]+" nil t) + (dotimes (i (prog1 + (current-column) + (delete-region (match-beginning 0) + (match-end 0)))) + (insert " "))) + (goto-char (point-min)) (insert "
\n") (goto-char (point-max)) (insert "
\n
\n") @@ -2909,7 +2918,7 @@ message header will be added to the bodies of the \"text/html\" parts." (cond ((= (length hcharset) 1) (setq hcharset (car hcharset) coding (mm-charset-to-coding-system - hcharset))) + hcharset nil t))) ((> (length hcharset) 1) (setq hcharset 'utf-8 coding hcharset))) @@ -2917,7 +2926,8 @@ message header will be added to the bodies of the \"text/html\" parts." (if charset (progn (setq body - (mm-charset-to-coding-system charset)) + (mm-charset-to-coding-system charset + nil t)) (if (eq coding body) (setq eheader (mm-encode-coding-string (buffer-string) coding) @@ -3431,15 +3441,13 @@ possible values." (visible-date (mail-fetch-field "Date")) pos date bface eface) (save-excursion - (goto-char (point-min)) - (when (re-search-forward "^Date:" nil t) - (setq bface (get-text-property (point-at-bol) 'face) - eface (get-text-property (1- (point-at-eol)) 'face))) - ;; Delete any old Date headers. (if date-position (progn (goto-char date-position) (setq date (get-text-property (point) 'original-date)) + (when (looking-at "[^:]+:[\t ]*") + (setq bface (get-text-property (match-beginning 0) 'face) + eface (get-text-property (match-end 0) 'face))) (delete-region (point) (progn (gnus-article-forward-header) @@ -3455,12 +3463,26 @@ possible values." (narrow-to-region pos (if (search-forward "\n\n" nil t) (1+ (match-beginning 0)) (point-max))) - (goto-char (point-min)) - (while (re-search-forward "^Date:" nil t) - (setq date (get-text-property (match-beginning 0) 'original-date)) - (delete-region (point-at-bol) (progn - (gnus-article-forward-header) - (point)))) + (while (setq pos (text-property-not-all pos (point-max) + 'gnus-date-type nil)) + (setq date (get-text-property pos 'original-date)) + (goto-char pos) + (when (looking-at "[^:]+:[\t ]*") + (setq bface (get-text-property (match-beginning 0) 'face) + eface (get-text-property (match-end 0) 'face))) + (delete-region pos (or (text-property-any pos (point-max) + 'gnus-date-type nil) + (point-max)))) + (unless date ;; the 1st time + (goto-char (point-min)) + (while (re-search-forward "^Date:[\t ]*" nil t) + (setq date (get-text-property (match-beginning 0) + 'original-date) + bface (get-text-property (match-beginning 0) 'face) + eface (get-text-property (match-end 0) 'face)) + (delete-region (point-at-bol) (progn + (gnus-article-forward-header) + (point))))) (when (and (not date) visible-date) (setq date visible-date)) @@ -3477,20 +3499,25 @@ possible values." (list type)) (t type))) - (insert (article-make-date-line date (or this-type 'ut)) "\n") - (forward-line -1) - (beginning-of-line) - (put-text-property (point) (1+ (point)) - 'original-date date) - (put-text-property (point) (1+ (point)) - 'gnus-date-type this-type) + (goto-char + (prog1 + (point) + (add-text-properties + (point) + (progn + (insert (article-make-date-line date (or this-type 'ut)) "\n") + (point)) + (list 'original-date date 'gnus-date-type this-type)))) ;; Do highlighting. - (when (looking-at "\\([^:]+\\): *\\(.*\\)$") - (put-text-property (match-beginning 1) (1+ (match-end 1)) - 'face bface) - (put-text-property (match-beginning 2) (match-end 2) - 'face eface)) - (forward-line 1))) + (when (looking-at + "\\([^:]+:\\)[\t ]*\\(\\(?:[^\t\n ]+[\t ]+\\)*[^\t\n ]+\\)?") + (put-text-property (match-beginning 1) (match-end 1) 'face bface) + (when (match-beginning 2) + (put-text-property (match-beginning 2) (match-end 2) 'face eface)) + (while (and (zerop (forward-line 1)) + (looking-at "[\t ]+\\(\\(?:[^\t\n ]+[\t ]+\\)*[^\t\n ]+\\)?")) + (when (match-beginning 1) + (put-text-property (match-beginning 1) (match-end 1) 'face eface)))))) (defun article-make-date-line (date type) "Return a DATE line of TYPE." @@ -3667,28 +3694,29 @@ function and want to see what the date was before converting." (walk-windows (lambda (w) (set-buffer (window-buffer w)) - (when (eq major-mode 'gnus-article-mode) + (when (derived-mode-p 'gnus-article-mode) (let ((old-line (count-lines (point-min) (point))) (old-column (- (point) (line-beginning-position))) - (window-start - (window-start (get-buffer-window (current-buffer))))) - (goto-char (point-min)) - (while (re-search-forward "^Date:" nil t) - (let ((type (get-text-property (match-beginning 0) - 'gnus-date-type))) - (when (memq type '(lapsed combined-lapsed user-format)) - (when (and window-start - (not (= window-start - (save-excursion - (forward-line 1) - (point))))) - (setq window-start nil)) - (save-excursion - (article-date-ut type t (match-beginning 0))) - (forward-line 1) - (when window-start - (set-window-start (get-buffer-window (current-buffer)) - (point)))))) + (window-start (window-start w)) + (pos (point-min)) + type next end) + (while (setq pos (text-property-not-all pos (point-max) + 'gnus-date-type nil)) + (setq next (or (next-single-property-change pos + 'gnus-date-type) + (point-max))) + (setq type (get-text-property pos 'gnus-date-type)) + (when (memq type '(lapsed combined-lapsed user-defined)) + (article-date-ut type t pos) + (setq end (or (next-single-property-change pos + 'gnus-date-type) + (point-max))) + (when window-start + (if (/= window-start next) + (setq window-start nil) + (set-window-start w end))) + (setq next end)) + (setq pos next)) (goto-char (point-min)) (when (> old-column 0) (setq old-line (1- old-line))) @@ -4362,9 +4390,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is (gnus-define-keys gnus-article-mode-map " " gnus-article-goto-next-page + [?\S-\ ] gnus-article-goto-prev-page "\177" gnus-article-goto-prev-page [delete] gnus-article-goto-prev-page - [backspace] gnus-article-goto-prev-page "\C-c^" gnus-article-refer-article "h" gnus-article-show-summary "s" gnus-article-show-summary @@ -4437,7 +4465,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (defvar bookmark-make-record-function) (defvar shr-put-image-function) -(defun gnus-article-mode () +(define-derived-mode gnus-article-mode fundamental-mode "Article" "Major mode for displaying an article. All normal editing commands are switched off. @@ -4452,13 +4480,8 @@ commands: \\[gnus-article-mail]\t Send a reply to the address near point \\[gnus-article-describe-briefly]\t Describe the current mode briefly \\[gnus-info-find-node]\t Go to the Gnus info node" - (interactive) - (kill-all-local-variables) (gnus-simplify-mode-line) - (setq mode-name "Article") - (setq major-mode 'gnus-article-mode) (make-local-variable 'minor-mode-alist) - (use-local-map gnus-article-mode-map) (when (gnus-visual-p 'article-menu 'menu) (gnus-article-make-menu-bar) (when gnus-summary-tool-bar-map @@ -4486,9 +4509,7 @@ commands: (buffer-disable-undo) (setq buffer-read-only t show-trailing-whitespace nil) - (set-syntax-table gnus-article-mode-syntax-table) - (mm-enable-multibyte) - (gnus-run-mode-hooks 'gnus-article-mode-hook)) + (mm-enable-multibyte)) (defun gnus-article-setup-buffer () "Initialize the article buffer." @@ -4526,20 +4547,22 @@ commands: nil) (error "Action aborted")) t))) - (with-current-buffer name - (set (make-local-variable 'gnus-article-edit-mode) nil) - (gnus-article-stop-animations) - (when gnus-article-mime-handles - (mm-destroy-parts gnus-article-mime-handles) - (setq gnus-article-mime-handles nil)) - ;; Set it to nil in article-buffer! - (setq gnus-article-mime-handle-alist nil) - (buffer-disable-undo) - (setq buffer-read-only t) - (unless (eq major-mode 'gnus-article-mode) - (gnus-article-mode)) - (setq truncate-lines gnus-article-truncate-lines) - (current-buffer)) + (let ((summary gnus-summary-buffer)) + (with-current-buffer name + (set (make-local-variable 'gnus-article-edit-mode) nil) + (gnus-article-stop-animations) + (when gnus-article-mime-handles + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handles nil)) + ;; Set it to nil in article-buffer! + (setq gnus-article-mime-handle-alist nil) + (buffer-disable-undo) + (setq buffer-read-only t) + (unless (derived-mode-p 'gnus-article-mode) + (gnus-article-mode)) + (set (make-local-variable 'gnus-summary-buffer) summary) + (setq truncate-lines gnus-article-truncate-lines) + (current-buffer))) (let ((summary gnus-summary-buffer)) (with-current-buffer (gnus-get-buffer-create name) (gnus-article-mode) @@ -4585,7 +4608,7 @@ If ARTICLE is an id, HEADER should be the article headers. If ALL-HEADERS is non-nil, no headers are hidden." (save-excursion ;; Make sure we start in a summary buffer. - (unless (eq major-mode 'gnus-summary-mode) + (unless (derived-mode-p 'gnus-summary-mode) (set-buffer gnus-summary-buffer)) (setq gnus-summary-buffer (current-buffer)) (let* ((gnus-article (if header (mail-header-number header) article)) @@ -4696,14 +4719,17 @@ If ALL-HEADERS is non-nil, no headers are hidden." (let ((gnus-article-buffer (current-buffer)) buffer-read-only (inhibit-read-only t)) - (unless (eq major-mode 'gnus-article-mode) + (unless (derived-mode-p 'gnus-article-mode) (gnus-article-mode)) (setq buffer-read-only nil gnus-article-wash-types nil 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 @@ -4758,7 +4784,7 @@ If a prefix ARG is given, ask for a name for this sticky article buffer." "*")) (if (and (gnus-buffer-live-p new-art-buf-name) (with-current-buffer new-art-buf-name - (eq major-mode 'gnus-sticky-article-mode))) + (derived-mode-p 'gnus-sticky-article-mode))) (switch-to-buffer new-art-buf-name) (setq new-art-buf-name (rename-buffer new-art-buf-name t))) (gnus-sticky-article-mode)) @@ -4774,7 +4800,7 @@ If none is given, assume the current buffer and kill it if it has (unless buffer (setq buffer (current-buffer))) (with-current-buffer buffer - (when (eq major-mode 'gnus-sticky-article-mode) + (when (derived-mode-p 'gnus-sticky-article-mode) (gnus-kill-buffer buffer)))) (defun gnus-kill-sticky-article-buffers (arg) @@ -4783,11 +4809,11 @@ If a prefix ARG is given, ask for confirmation." (interactive "P") (dolist (buf (gnus-buffers)) (with-current-buffer buf - (when (eq major-mode 'gnus-sticky-article-mode) - (if (not arg) - (gnus-kill-buffer buf) - (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? ")) - (gnus-kill-buffer buf))))))) + (when (derived-mode-p 'gnus-sticky-article-mode) + (if (not arg) + (gnus-kill-buffer buf) + (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? ")) + (gnus-kill-buffer buf))))))) ;;; ;;; Gnus MIME viewing functions @@ -4875,7 +4901,7 @@ General format specifiers can also be used. See Info node (defmacro gnus-bind-safe-url-regexp (&rest body) "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'." `(let ((mm-w3m-safe-url-regexp - (let ((group (if (and (eq major-mode 'gnus-article-mode) + (let ((group (if (and (derived-mode-p 'gnus-article-mode) (gnus-buffer-live-p gnus-article-current-summary)) (with-current-buffer gnus-article-current-summary @@ -5224,7 +5250,8 @@ are decompressed." (switch-to-buffer (generate-new-buffer filename)) (if (or coding-system (and charset - (setq coding-system (mm-charset-to-coding-system charset)) + (setq coding-system (mm-charset-to-coding-system + charset nil t)) (not (eq coding-system 'ascii)))) (progn (mm-enable-multibyte) @@ -5274,12 +5301,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 @@ -5305,9 +5346,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. @@ -5609,54 +5689,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) + ,(copy-marker (point-max) t))))))) + (part + (mm-display-inline 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) - (gnus-delete-line) - (gnus-insert-mime-button - handle id (list (mm-handle-displayed-p handle))) - (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) @@ -5710,8 +5842,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 @@ -5836,6 +5966,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. @@ -5858,14 +5998,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) @@ -5889,7 +6021,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 @@ -5915,9 +6046,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 @@ -5929,31 +6062,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 @@ -6084,7 +6214,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" @@ -6179,12 +6312,117 @@ Provided for backwards compatibility." (defun gnus-shr-put-image (data alt &optional flags) "Put image DATA with a string ALT. Enable image to be deleted." - (let ((image (shr-put-image data (propertize (or alt "*") - 'gnus-image-category 'shr) - flags))) + (let ((image (if flags + (shr-put-image data (propertize (or alt "*") + 'gnus-image-category 'shr) + flags) + ;; Old `shr-put-image' doesn't take the optional `flags' + ;; argument. + (shr-put-image data (propertize (or alt "*") + 'gnus-image-category 'shr))))) (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 st handle) + (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 (handle (flattened-alist)) + (when (and (not (stringp (cadr handle))) + (or (equal (car (mm-handle-disposition + (cdr handle))) + "attachment") + (not (and (mm-inlinable-p (cdr handle)) + (mm-inlined-p (cdr handle)))))) + (push handle 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) @@ -6454,7 +6692,7 @@ not have a face in `gnus-article-boring-faces'." (defun gnus-article-check-buffer () "Beep if not in an article buffer." - (unless (equal major-mode 'gnus-article-mode) + (unless (derived-mode-p 'gnus-article-mode) (error "Command invoked outside of a Gnus article buffer"))) (defun gnus-article-read-summary-keys (&optional arg key not-restore-window) @@ -6569,7 +6807,7 @@ not have a face in `gnus-article-boring-faces'." new-sum-point (window-live-p win) (with-current-buffer (window-buffer win) - (eq major-mode 'gnus-summary-mode))) + (derived-mode-p 'gnus-summary-mode))) (set-window-point win new-sum-point) (set-window-start win new-sum-start) (set-window-hscroll win new-sum-hscroll)))) @@ -6629,11 +6867,7 @@ KEY is a string or a vector." ;;`gnus-agent-mode' in gnus-agent.el will define it. (defvar gnus-agent-summary-mode) (defvar gnus-draft-mode) -;; Calling help-buffer will autoload help-mode. (defvar help-xref-stack-item) -;; Emacs 22 doesn't load it in the batch mode. -(eval-when-compile - (autoload 'help-buffer "help-mode")) (defun gnus-article-describe-bindings (&optional prefix) "Show a list of all defined keys, and their definitions. @@ -6684,6 +6918,9 @@ then we display only bindings that start with that prefix." (with-current-buffer ,(current-buffer) (gnus-article-describe-bindings prefix))) ,prefix))) + ;; Loading `help-mode' here is necessary if `describe-bindings' + ;; is replaced with something, e.g. `helm-descbinds'. + (require 'help-mode) (with-current-buffer (let (help-xref-following) (help-buffer)) (setq help-xref-stack-item item))))) @@ -6930,7 +7167,8 @@ If given a prefix, show the hidden text instead." (set-buffer buf)))))) (defun gnus-block-private-groups (group) - (if (gnus-news-group-p group) + (if (or (gnus-news-group-p group) + (gnus-member-of-valid 'global group)) ;; Block nothing in news groups. nil ;; Block everything anywhere else. @@ -7154,15 +7392,17 @@ groups." "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]*" + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" "\\|" - "[" chars punct "]+" "[" chars "]" + "[" chars punct "]+" "[" chars "]" "\\)")) (concat ;; XEmacs 21.4 doesn't support POSIX. "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+" "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)")) "\\)") "Regular expression that matches URLs." + :version "24.4" :group 'gnus-article-buttons :type 'regexp) @@ -7849,7 +8089,9 @@ url is put as the `gnus-button-url' overlay property on the button." (let (gnus-article-mouse-face widget-mouse-face) (while points (gnus-article-add-button (pop points) (pop points) - 'gnus-button-push beg))) + 'gnus-button-push + (list beg (assq 'gnus-button-url-regexp + gnus-button-alist))))) (let ((overlay (gnus-make-overlay start end))) (gnus-overlay-put overlay 'evaporate t) (gnus-overlay-put overlay 'gnus-button-url @@ -8394,6 +8636,8 @@ For example: (not (gnus-treat-predicate (car val)))) ((eq pred 'typep) (equal (car val) gnus-treat-type)) + ((functionp pred) + (funcall pred)) (t (error "%S is not a valid predicate" pred))))) ((eq val t)