X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=89fc99f763cc9426da26559fe33a53b5837b8865;hb=f184970372ca060258c66979adbc7f1db73a9376;hp=7293ec8a6a472586d4a106965892e1debf55db7d;hpb=9aca1b0480abf42e7fd046b1627c7979d54d9f8c;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 7293ec8..89fc99f 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,5 @@ ;;; gnus-art.el --- article mode commands for Semi-gnus -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -28,26 +28,23 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile (require 'static)) -(require 'custom) +(require 'path-util) (require 'gnus) (require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) -(require 'browse-url) (require 'alist) (require 'mime-view) +(require 'wid-edit) +;; Avoid byte-compile warnings. (eval-when-compile - (require 'static) - ;; Avoid byte-compile warnings. - (defvar gnus-article-decoded-p) - (defvar gnus-article-mime-handles) (require 'mm-bodies) (require 'mail-parse) (require 'mm-decode) (require 'mm-view) - (require 'wid-edit) (require 'mm-uu) ) @@ -138,7 +135,8 @@ "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:" "^List-[A-Za-z]+:" "^X-Listprocessor-Version:" "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:" - "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:") + "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:" + "^X-Received:" "^Content-length:" "X-precedence:") "*All headers that start with this regexp will be hidden. This variable can also be a list of regexps of headers to be ignored. If `gnus-visible-headers' is non-nil, this variable will be ignored." @@ -148,7 +146,7 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." :group 'gnus-article-hiding) (defcustom gnus-visible-headers - "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" + "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:" "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." @@ -179,8 +177,8 @@ Possible values in this list are `empty', `newsgroups', `followup-to', (const :tag "Followup-to identical to newsgroups." followup-to) (const :tag "Reply-to identical to from." reply-to) (const :tag "Date less than four days old." date) - (const :tag "Very long To header." long-to) - (const :tag "Multiple To headers." many-to)) + (const :tag "Very long To and/or Cc header." long-to) + (const :tag "Multiple To and/or Cc headers." many-to)) :group 'gnus-article-hiding) (defcustom gnus-signature-separator '("^-- $" "^-- *$") @@ -192,7 +190,7 @@ the end of the buffer." :group 'gnus-article-signature) (defcustom gnus-signature-limit nil - "Provide a limit to what is considered a signature. + "Provide a limit to what is considered a signature. If it is a number, no signature may not be longer (in characters) than that number. If it is a floating point number, no signature may be longer (in lines) than that number. If it is a function, the function @@ -211,11 +209,29 @@ regexp. If it matches, the text in question is not a signature." :group 'gnus-article-hiding) (defcustom gnus-article-x-face-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -" + (cond + ;; Fixme: This isn't the right thing for mixed graphical and and + ;; non-graphical frames in a session. + ;; gnus-xmas.el overrides this for XEmacs. + ((and (fboundp 'image-type-available-p) + (image-type-available-p 'xbm)) + 'gnus-article-display-xface) + ((and (not (featurep 'xemacs)) + window-system + (module-installed-p 'x-face-mule)) + 'x-face-mule-gnus-article-display-x-face) + (gnus-article-compface-xbm + "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -") + (t + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ +display -")) "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." - :type 'string ;Leave function case to Lisp. + :type '(choice string + (function-item gnus-article-display-xface) + (function-item x-face-mule-gnus-article-display-x-face) + function) :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -223,9 +239,16 @@ asynchronously. The compressed face will be piped to this command." :type '(choice regexp (const nil)) :group 'gnus-article-washing) +(defcustom gnus-article-banner-alist nil + "Banner alist for stripping. +For example, + ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" + :type '(repeat (cons symbol regexp)) + :group 'gnus-article-washing) + (defcustom gnus-emphasis-alist (let ((format - "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") + "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)") (types '(("_" "_" underline) ("/" "/" italic) @@ -239,7 +262,7 @@ asynchronously. The compressed face will be piped to this command." ,@(mapcar (lambda (spec) (list - (format format (car spec) (cadr spec)) + (format format (car spec) (car (cdr spec))) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) types))) "*Alist that says how to fontify certain phrases. @@ -259,6 +282,14 @@ is the face used for highlighting." face)) :group 'gnus-article-emphasis) +(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n" + "A regexp to describe whitespace which should not be emphasized. +Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\". +The former avoids underlining of leading and trailing whitespace, +and the latter avoids underlining any whitespace at all." + :group 'gnus-article-emphasis + :type 'regexp) + (defface gnus-emphasis-bold '((t (:bold t))) "Face used for displaying strong emphasized text (*word*)." :group 'gnus-article-emphasis) @@ -276,7 +307,7 @@ is the face used for highlighting." :group 'gnus-article-emphasis) (defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) - "Face used for displaying underlined italic emphasized text (_*word*_)." + "Face used for displaying underlined italic emphasized text (_/word/_)." :group 'gnus-article-emphasis) (defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) @@ -483,7 +514,7 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." :group 'gnus-article-signature) (defface gnus-signature-face - '((((type x)) + '((t (:italic t))) "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight @@ -604,8 +635,8 @@ displayed by the first non-nil matching CONTENT face." ("\223" "``") ("\224" "\"") ("\225" "*") - ("\226" "---") - ("\227" "-") + ("\226" "-") + ("\227" "--") ("\231" "(TM)") ("\233" ">") ("\234" "oe") @@ -640,6 +671,38 @@ be added below it (otherwise)." :group 'gnus-article-headers :type 'boolean) +(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative + "Function called with a MIME handle as the argument. +This is meant for people who want to view first matched part. +For `undisplayed-alternative' (default), the first undisplayed +part or alternative part is used. For `undisplayed', the first +undisplayed part is used. For a function, the first part which +the function return `t' is used. For `nil', the first part is +used." + :group 'gnus-article-mime + :type '(choice + (item :tag "first" :value nil) + (item :tag "undisplayed" :value undisplayed) + (item :tag "undisplayed or alternative" + :value undisplayed-alternative) + (function))) + +(defcustom gnus-mime-action-alist + '(("save to file" . gnus-mime-save-part) + ("save and strip" . gnus-mime-save-part-and-strip) + ("display as text" . gnus-mime-inline-part) + ("view the part" . gnus-mime-view-part) + ("pipe to command" . gnus-mime-pipe-part) + ("toggle display" . gnus-article-press-button) + ("toggle display" . gnus-article-view-part-as-charset) + ("view as type" . gnus-mime-view-part-as-type) + ("internalize type" . gnus-mime-internalize-part) + ("externalize type" . gnus-mime-externalize-part)) + "An alist of actions that run on the MIME attachment." + :group 'gnus-article-mime + :type '(repeat (cons (string :tag "name") + (function)))) + ;;; ;;; The treatment variables ;;; @@ -675,7 +738,7 @@ See the manual for details." :type gnus-article-treat-custom) (put 'gnus-treat-highlight-signature 'highlight t) -(defcustom gnus-treat-buttonize t +(defcustom gnus-treat-buttonize 100000 "Add buttons. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -691,7 +754,7 @@ See the manual for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-buttonize-head 'highlight t) -(defcustom gnus-treat-emphasize t +(defcustom gnus-treat-emphasize nil "Emphasize text. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -741,6 +804,13 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-hide-citation-maybe nil + "Hide cited text. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + (defcustom gnus-treat-strip-list-identifiers 'head "Strip list identifiers from `gnus-list-identifiers`. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -865,8 +935,14 @@ See the manual for details." :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) -(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface)) - 'head nil) +(defcustom gnus-treat-display-xface + (and (or (and (fboundp 'image-type-available-p) + (image-type-available-p 'xbm) + (string-match "^0x" (shell-command-to-string "uncompface"))) + (and (featurep 'xemacs) (featurep 'xface)) + (eq 'x-face-mule-gnus-article-display-x-face + gnus-article-x-face-command)) + 'head) "Display X-Face headers. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -874,9 +950,16 @@ See the manual for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-display-xface 'highlight t) -(defcustom gnus-treat-display-smileys (if (and gnus-xemacs - (featurep 'xpm)) - t nil) +(defcustom gnus-treat-display-smileys + (if (or (and (featurep 'xemacs) + (featurep 'xpm)) + (and (fboundp 'image-type-available-p) + (image-type-available-p 'pbm)) + (and (not (featurep 'xemacs)) + window-system + (module-installed-p 'gnus-bitmap))) + t + nil) "Display smileys. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -884,7 +967,7 @@ See the manual for details." :type gnus-article-treat-custom) (put 'gnus-treat-display-smileys 'highlight t) -(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil) +(defcustom gnus-treat-display-picons (if (featurep 'xemacs) 'head nil) "Display picons. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -930,6 +1013,25 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-x-pgp-sig nil + "Verify X-PGP-Sig. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :group 'mime-security + :type gnus-article-treat-custom) + +(defvar gnus-article-encrypt-protocol-alist + '(("PGP" . mml2015-self-encrypt))) + +;; Set to nil if more than one protocol added to +;; gnus-article-encrypt-protocol-alist. +(defcustom gnus-article-encrypt-protocol "PGP" + "The protocol used for encrypt articles. +It is a string, such as \"PGP\". If nil, ask user." + :type 'string + :group 'mime-security) + ;;; Internal variables (defvar article-goto-body-goes-to-point-min-p nil) @@ -940,6 +1042,7 @@ See the manual for details." (defvar gnus-treatment-function-alist '((gnus-treat-decode-article-as-default-mime-charset gnus-article-decode-article-as-default-mime-charset) + (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) (gnus-treat-strip-banner gnus-article-strip-banner) (gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body) (gnus-treat-buttonize gnus-article-add-buttons) @@ -951,6 +1054,7 @@ See the manual for details." (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) (gnus-treat-hide-signature gnus-article-hide-signature) (gnus-treat-hide-citation gnus-article-hide-citation) + (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) (gnus-treat-strip-pgp gnus-article-hide-pgp) (gnus-treat-strip-pem gnus-article-hide-pem) @@ -972,7 +1076,8 @@ See the manual for details." gnus-article-strip-multiple-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) - (gnus-treat-display-smileys gnus-smiley-display) + (gnus-treat-display-smileys gnus-article-smiley-display) + (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) (gnus-treat-display-picons gnus-article-display-picons) (gnus-treat-play-sounds gnus-earcon-display))) @@ -1133,6 +1238,7 @@ Initialized from `text-mode-syntax-table.") (when (setq beg (text-property-any (point-min) (point-max) 'message-rank (+ 2 max))) ;; We delete or make invisible the unwanted headers. + (push 'headers gnus-article-wash-types) (if delete (progn (add-text-properties @@ -1201,11 +1307,15 @@ always hide." 4)) (gnus-article-hide-header "date")))) ((eq elem 'long-to) - (let ((to (message-fetch-field "to"))) + (let ((to (message-fetch-field "to")) + (cc (message-fetch-field "cc"))) (when (> (length to) 1024) - (gnus-article-hide-header "to")))) + (gnus-article-hide-header "to")) + (when (> (length cc) 1024) + (gnus-article-hide-header "cc")))) ((eq elem 'many-to) - (let ((to-count 0)) + (let ((to-count 0) + (cc-count 0)) (goto-char (point-min)) (while (re-search-forward "^to:" nil t) (setq to-count (1+ to-count))) @@ -1217,7 +1327,19 @@ always hide." (forward-line -1) (narrow-to-region (point) (point-max)) (gnus-article-hide-header "to")) - (setq to-count (1- to-count))))))))))))) + (setq to-count (1- to-count)))) + (goto-char (point-min)) + (while (re-search-forward "^cc:" nil t) + (setq cc-count (1+ cc-count))) + (when (> cc-count 1) + (while (> cc-count 0) + (goto-char (point-min)) + (save-restriction + (re-search-forward "^cc:" nil nil cc-count) + (forward-line -1) + (narrow-to-region (point) (point-max)) + (gnus-article-hide-header "cc")) + (setq cc-count (1- cc-count))))))))))))) (defun gnus-article-hide-header (header) (save-excursion @@ -1297,7 +1419,7 @@ if given a positive prefix, always hide." (narrow-to-region header-start header-end) (article-hide-headers) ;; Re-display X-Face image under XEmacs. - (when (and gnus-xemacs + (when (and (featurep 'xemacs) (gnus-functionp gnus-article-x-face-command)) (let ((func (cadr (assq 'gnus-treat-display-xface gnus-treatment-function-alist))) @@ -1388,23 +1510,29 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (let ((buffer-read-only nil)) (while (search-forward "\b" nil t) (let ((next (char-after)) - (previous (char-after (- (point) 2)))) + start end previous) + (backward-char 2) + (setq start (point) + previous (char-after)) + (forward-char 3) + (setq end (point)) + (backward-char) ;; We do the boldification/underlining by hiding the ;; overstrikes and putting the proper text property ;; on the letters. (cond ((eq next previous) - (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) - (put-text-property (point) (1+ (point)) 'face 'bold)) + (gnus-article-hide-text-type start (point) 'overstrike) + (put-text-property (point) end 'face 'bold)) ((eq next ?_) (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike) (put-text-property - (- (point) 2) (1- (point)) 'face 'underline)) + start (1- (point)) 'face 'underline)) ((eq previous ?_) - (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (gnus-article-hide-text-type start (point) 'overstrike) (put-text-property - (point) (1+ (point)) 'face 'underline))))))))) + (point) end 'face 'underline))))))))) (defun article-fill-long-lines () "Fill lines that are wider than the window width." @@ -1488,7 +1616,7 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (not (string-match gnus-article-x-face-too-ugly from)))) ;; Has to be present. - (re-search-forward "^X-Face: " nil t)) + (re-search-forward "^X-Face:[ \t]*" nil t)) ;; This used to try to do multiple faces (`while' instead of ;; `when' above), but (a) sending multiple EOFs to xv doesn't ;; work (b) it can crash some versions of Emacs (c) are @@ -1532,40 +1660,47 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." "Decode charset-encoded text in the article. If PROMPT (the prefix), prompt for a coding system to use." (interactive "P") + (let ((inhibit-point-motion-hooks t) (case-fold-search t) + buffer-read-only + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case nil + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets)) + ct cte ctl charset format) (save-excursion (save-restriction (article-narrow-to-head) - (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) - (ct (message-fetch-field "Content-Type" t)) - (cte (message-fetch-field "Content-Transfer-Encoding" t)) - (ctl (and ct (ignore-errors - (mail-header-parse-content-type ct)))) - (charset (cond - (prompt - (mm-read-coding-system "Charset to decode: ")) - (ctl - (mail-content-type-get ctl 'charset)))) - (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets - (save-excursion (condition-case nil - (set-buffer gnus-summary-buffer) - (error)) - gnus-newsgroup-ignored-charsets)) - buffer-read-only) - (if (and ctl (not (string-match "/" (car ctl)))) - (setq ctl nil)) - (goto-char (point-max)) - (widen) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (when (and (or (not ctl) - (equal (car ctl) "text/plain")) - (not (mm-uu-test))) - (mm-decode-body - charset (and cte (intern (downcase - (gnus-strip-whitespace cte)))) - (car ctl))))))) + (setq ct (message-fetch-field "Content-Type" t) + cte (message-fetch-field "Content-Transfer-Encoding" t) + ctl (and ct (ignore-errors + (mail-header-parse-content-type ct))) + charset (cond + (prompt + (mm-read-coding-system "Charset to decode: ")) + (ctl + (mail-content-type-get ctl 'charset))) + format (and ctl (mail-content-type-get ctl 'format))) + (when cte + (setq cte (mail-header-strip cte))) + (if (and ctl (not (string-match "/" (car ctl)))) + (setq ctl nil)) + (goto-char (point-max))) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (when (and (eq mail-parse-charset 'gnus-decoded) + (eq (mm-body-7-or-8) '8bit)) + ;; The text code could have been decoded. + (setq charset mail-parse-charset)) + (when (and (or (not ctl) + (equal (car ctl) "text/plain")) + (not format)) ;; article with format will decode later. + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ctl))))))) (defun article-decode-encoded-words () "Remove encoded-word encoding from headers." @@ -1582,21 +1717,101 @@ If FORCE, decode the article whether it is marked as quoted-printable or not." (interactive (list 'force)) (save-excursion - (let ((buffer-read-only nil) - (type (gnus-fetch-field "content-transfer-encoding")) - (charset gnus-newsgroup-charset)) + (let ((buffer-read-only nil) type charset) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (setq type + (gnus-fetch-field "content-transfer-encoding")) + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (if (stringp charset) + (setq charset (intern (downcase charset))))))) + (unless charset + (setq charset gnus-newsgroup-charset)) + (when (or force + (and type (let ((case-fold-search t)) + (string-match "quoted-printable" type)))) + (article-goto-body) + (quoted-printable-decode-region + (point) (point-max) (mm-charset-to-coding-system charset)))))) + +(defun article-de-base64-unreadable (&optional force) + "Translate a base64 article. +If FORCE, decode the article whether it is marked as base64 not." + (interactive (list 'force)) + (save-excursion + (let ((buffer-read-only nil) type charset) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (setq type + (gnus-fetch-field "content-transfer-encoding")) + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (if (stringp charset) + (setq charset (intern (downcase charset))))))) + (unless charset + (setq charset gnus-newsgroup-charset)) (when (or force - (and type (string-match "quoted-printable" (downcase type)))) + (and type (let ((case-fold-search t)) + (string-match "base64" type)))) (article-goto-body) (save-restriction (narrow-to-region (point) (point-max)) - (quoted-printable-decode-region (point-min) (point-max)) - (when charset - (mm-decode-body charset))))))) + (base64-decode-region (point-min) (point-max)) + (mm-decode-coding-region + (point-min) (point-max) (mm-charset-to-coding-system charset))))))) + +(eval-when-compile + (require 'rfc1843)) + +(defun article-decode-HZ () + "Translate a HZ-encoded article." + (interactive) + (require 'rfc1843) + (save-excursion + (let ((buffer-read-only nil)) + (rfc1843-decode-region (point-min) (point-max))))) + +(defun article-wash-html () + "Format an html article." + (interactive) + (save-excursion + (let ((buffer-read-only nil) + charset) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (let* ((ct (gnus-fetch-field "content-type")) + (ctl (and ct + (ignore-errors + (mail-header-parse-content-type ct))))) + (setq charset (and ctl + (mail-content-type-get ctl 'charset))) + (if (stringp charset) + (setq charset (intern (downcase charset))))))) + (unless charset + (setq charset gnus-newsgroup-charset)) + (article-goto-body) + (save-window-excursion + (save-restriction + (narrow-to-region (point) (point-max)) + (mm-setup-w3) + (let ((w3-strict-width (window-width)) + (url-standalone-mode t)) + (condition-case var + (w3-region (point-min) (point-max)) + (error)))))))) (defun article-hide-list-identifiers () - "Remove any list identifiers in `gnus-list-identifiers' from Subject -header in the current article." + "Remove list identifies from the Subject header. +The `gnus-list-identifiers' variable specifies what to do." (interactive) (save-excursion (save-restriction @@ -1608,9 +1823,14 @@ header in the current article." (when regexp (goto-char (point-min)) (when (re-search-forward - (concat "^Subject: +\\(Re: +\\)?\\(" regexp " *\\)") + (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp + " *\\)\\)+\\(Re: +\\)?\\)") nil t) - (delete-region (match-beginning 2) (match-end 0))))))))) + (let ((s (or (match-string 3) (match-string 5)))) + (delete-region (match-beginning 1) (match-end 1)) + (when s + (goto-char (match-beginning 1)) + (insert s)))))))))) (defun article-hide-pgp () "Remove any PGP headers and signatures in the current article." @@ -1624,9 +1844,9 @@ header in the current article." (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) (push 'pgp gnus-article-wash-types) (delete-region (match-beginning 0) (match-end 0)) - ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too - (when (looking-at "Hash:.*$") - (delete-region (point) (1+ (gnus-point-at-eol)))) + ;; Remove armor headers (rfc2440 6.2) + (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) + (point))) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) @@ -1681,7 +1901,7 @@ always hide." (save-excursion (save-restriction (let ((inhibit-point-motion-hooks t) - (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner)) + (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner)) (gnus-signature-limit nil) buffer-read-only beg end) (when banner @@ -1692,6 +1912,10 @@ always hide." (widen) (forward-line -1) (delete-region (point) (point-max)))) + ((symbolp banner) + (if (setq banner (cdr (assq banner gnus-article-banner-alist))) + (while (re-search-forward banner nil t) + (delete-region (match-beginning 0) (match-end 0))))) ((stringp banner) (while (re-search-forward banner nil t) (delete-region (match-beginning 0) (match-end 0)))))))))) @@ -1718,13 +1942,28 @@ always hide." If given a negative prefix, always show; if given a positive prefix, always hide." (interactive (gnus-article-hidden-arg)) - (unless (gnus-article-check-hidden-text 'signature arg) - (save-excursion - (save-restriction - (let ((buffer-read-only nil)) - (when (gnus-article-narrow-to-signature) - (gnus-article-hide-text-type - (point-min) (point-max) 'signature))))))) + (save-excursion + (save-restriction + (if (interactive-p) + (progn + (widen) + (article-goto-body)) + (goto-char (point-min))) + (unless (gnus-article-check-hidden-text 'signature arg) + (let ((buffer-read-only nil) + (button (point))) + (while (setq button (text-property-any button (point-max) + 'gnus-callback + 'gnus-signature-toggle)) + (setq button (text-property-not-all button (point-max) + 'gnus-callback + 'gnus-signature-toggle)) + (when (and button (not (eobp))) + (gnus-article-hide-text-type + (1+ button) + (next-single-property-change (1+ button) 'mime-view-entity + nil (point-max)) + 'signature)))))))) (defun article-strip-headers-in-body () "Strip offensive headers from bodies." @@ -1935,7 +2174,7 @@ If HIDE, hide the text instead." (defun article-date-ut (&optional type highlight header) "Convert DATE date to universal time in the current article. If TYPE is `local', convert to local time; if it is `lapsed', output -how much time has lapsed since DATE. For `lapsed', the value of +how much time has lapsed since DATE. For `lapsed', the value of `gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header should replace the \"Date:\" one, or should be added below it." (interactive (list 'ut t)) @@ -2030,9 +2269,9 @@ should replace the \"Date:\" one, or should be added below it." (concat "Date: " (current-time-string (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) (cond ((< ls 0) (list (1- ms) (+ ls 65536))) ((> ls 65535) (list (1+ ms) (- ls 65536))) (t (list ms ls))))) @@ -2051,9 +2290,13 @@ should replace the \"Date:\" one, or should be added below it." (format-time-string gnus-article-time-format time)))) ;; ISO 8601. ((eq type 'iso8601) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time))) + (let ((tz (car (current-time-zone time)))) + (concat + "Date: " + (format-time-string "%Y%m%dT%H%M%S" time) + (format "%s%02d%02d" + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))))) ;; Do an X-Sent lapsed format. ((eq type 'lapsed) ;; If the date is seriously mangled, the timezone functions are @@ -2164,17 +2407,33 @@ This format is defined by the `gnus-article-time-format' variable." "Show all hidden text in the article buffer." (interactive) (save-excursion + (widen) (let ((buffer-read-only nil)) - (gnus-article-unhide-text (point-min) (point-max))))) + (gnus-article-unhide-text (point-min) (point-max)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next)))) + +(defun article-show-all-headers () + "Show all hidden headers in the article buffer." + (interactive) + (save-excursion + (save-restriction + (widen) + (article-narrow-to-head) + (let ((buffer-read-only nil)) + (gnus-article-unhide-text (point-min) (point-max)))))) (defun article-emphasize (&optional arg) "Emphasize text according to `gnus-emphasis-alist'." (interactive (gnus-article-hidden-arg)) (unless (gnus-article-check-hidden-text 'emphasis arg) (save-excursion - (let ((alist (or (with-current-buffer gnus-summary-buffer - gnus-article-emphasis-alist) - gnus-emphasis-alist)) + (let ((alist (or + (condition-case nil + (with-current-buffer gnus-summary-buffer + gnus-article-emphasis-alist) + (error)) + gnus-emphasis-alist)) (buffer-read-only nil) (props (append '(article-type emphasis) gnus-hidden-properties)) @@ -2189,6 +2448,7 @@ This format is defined by the `gnus-article-time-format' variable." face (nth 3 elem)) (while (re-search-forward regexp nil t) (when (and (match-beginning visible) (match-beginning invisible)) + (push 'emphasis gnus-article-wash-types) (gnus-article-hide-text (match-beginning invisible) (match-end invisible) props) (gnus-article-unhide-text-type @@ -2203,18 +2463,18 @@ This format is defined by the `gnus-article-time-format' variable." (let ((name (and gnus-newsgroup-name (gnus-group-real-name gnus-newsgroup-name)))) (make-local-variable 'gnus-article-emphasis-alist) - (setq gnus-article-emphasis-alist - (nconc + (setq gnus-article-emphasis-alist + (nconc (let ((alist gnus-group-highlight-words-alist) elem highlight) (while (setq elem (pop alist)) (when (and name (string-match (car elem) name)) (setq alist nil - highlight (copy-list (cdr elem))))) + highlight (copy-sequence (cdr elem))))) highlight) - (copy-list highlight-words) + (copy-sequence highlight-words) (if gnus-newsgroup-name - (copy-list (gnus-group-find-parameter - gnus-newsgroup-name 'highlight-words t))) + (copy-sequence (gnus-group-find-parameter + gnus-newsgroup-name 'highlight-words t))) gnus-emphasis-alist))))) (defvar gnus-summary-article-menu) @@ -2256,76 +2516,78 @@ This format is defined by the `gnus-article-time-format' variable." (let ((default-name (funcall function group headers (symbol-value variable))) result) - (setq - result - (cond - ((eq filename 'default) - default-name) - ((eq filename t) - default-name) - (filename filename) - (t - (let* ((split-name (gnus-get-split-value gnus-split-methods)) - (prompt - (format prompt - (if (and gnus-number-of-articles-to-be-saved - (> gnus-number-of-articles-to-be-saved 1)) - (format "these %d articles" - gnus-number-of-articles-to-be-saved) - "this article"))) - (file - ;; Let the split methods have their say. - (cond - ;; No split name was found. - ((null split-name) - (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) ") ") - (file-name-directory default-name) - default-name)) - ;; A single group name is returned. - ((stringp split-name) - (setq default-name - (funcall function split-name headers - (symbol-value variable))) - (read-file-name - (concat prompt " (default " - (file-name-nondirectory default-name) ") ") - (file-name-directory default-name) - default-name)) - ;; A single split name was found - ((= 1 (length split-name)) - (let* ((name (expand-file-name - (car split-name) gnus-article-save-directory)) - (dir (cond ((file-directory-p name) - (file-name-as-directory name)) - ((file-exists-p name) name) - (t gnus-article-save-directory)))) - (read-file-name - (concat prompt " (default " name ") ") - dir name))) - ;; A list of splits was found. - (t - (setq split-name (nreverse split-name)) - (let (result) - (let ((file-name-history - (nconc split-name file-name-history))) - (setq result - (expand-file-name - (read-file-name - (concat prompt " (`M-p' for defaults) ") - gnus-article-save-directory - (car split-name)) - gnus-article-save-directory))) - (car (push result file-name-history))))))) - ;; Create the directory. - (gnus-make-directory (file-name-directory file)) - ;; If we have read a directory, we append the default file name. - (when (file-directory-p file) - (setq file (concat (file-name-as-directory file) - (file-name-nondirectory default-name)))) - ;; Possibly translate some characters. - (nnheader-translate-file-chars file))))) + (setq result + (expand-file-name + (cond + ((eq filename 'default) + default-name) + ((eq filename t) + default-name) + (filename filename) + (t + (let* ((split-name (gnus-get-split-value gnus-split-methods)) + (prompt + (format prompt + (if (and gnus-number-of-articles-to-be-saved + (> gnus-number-of-articles-to-be-saved 1)) + (format "these %d articles" + gnus-number-of-articles-to-be-saved) + "this article"))) + (file + ;; Let the split methods have their say. + (cond + ;; No split name was found. + ((null split-name) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single group name is returned. + ((stringp split-name) + (setq default-name + (funcall function split-name headers + (symbol-value variable))) + (read-file-name + (concat prompt " (default " + (file-name-nondirectory default-name) ") ") + (file-name-directory default-name) + default-name)) + ;; A single split name was found + ((= 1 (length split-name)) + (let* ((name (expand-file-name + (car split-name) + gnus-article-save-directory)) + (dir (cond ((file-directory-p name) + (file-name-as-directory name)) + ((file-exists-p name) name) + (t gnus-article-save-directory)))) + (read-file-name + (concat prompt " (default " name ") ") + dir name))) + ;; A list of splits was found. + (t + (setq split-name (nreverse split-name)) + (let (result) + (let ((file-name-history + (nconc split-name file-name-history))) + (setq result + (expand-file-name + (read-file-name + (concat prompt " (`M-p' for defaults) ") + gnus-article-save-directory + (car split-name)) + gnus-article-save-directory))) + (car (push result file-name-history))))))) + ;; Create the directory. + (gnus-make-directory (file-name-directory file)) + ;; If we have read a directory, we append the default file name. + (when (file-directory-p file) + (setq file (expand-file-name (file-name-nondirectory + default-name) + (file-name-as-directory file)))) + ;; Possibly translate some characters. + (nnheader-translate-file-chars file)))))) (gnus-make-directory (file-name-directory result)) (set variable result))) @@ -2483,17 +2745,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is default (or last-file default)))) -(defun gnus-Plain-save-name (newsgroup headers &optional last-file) - "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. -If variable `gnus-use-long-file-name' is non-nil, it is -~/News/News.group. Otherwise, it is like ~/News/news/group/news." - (or last-file - (expand-file-name - (if (gnus-use-long-file-name 'not-save) - (gnus-capitalize-newsgroup newsgroup) - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) - gnus-article-save-directory))) - (defun gnus-plain-save-name (newsgroup headers &optional last-file) "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE. If variable `gnus-use-long-file-name' is non-nil, it is @@ -2502,9 +2753,81 @@ If variable `gnus-use-long-file-name' is non-nil, it is (expand-file-name (if (gnus-use-long-file-name 'not-save) newsgroup - (concat (gnus-newsgroup-directory-form newsgroup) "/news")) + (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) gnus-article-save-directory))) +(autoload 'mm-uu-pgp-signed-test "mm-uu") + +(defun article-verify-x-pgp-sig () + "Verify X-PGP-Sig." + (interactive) + (let ((sig (with-current-buffer gnus-original-article-buffer + (gnus-fetch-field "X-PGP-Sig"))) + items info headers) + (when (and sig (mm-uu-pgp-signed-test)) + (with-temp-buffer + (insert-buffer gnus-original-article-buffer) + (setq items (split-string sig)) + (message-narrow-to-head) + (let ((inhibit-point-motion-hooks t) + (case-fold-search t)) + ;; Don't verify multiple headers. + (setq headers (mapconcat (lambda (header) + (concat header ": " + (mail-fetch-field header) "\n")) + (split-string (nth 1 items) ",") ""))) + (delete-region (point-min) (point-max)) + (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n") + (insert "X-Signed-Headers: " (nth 1 items) "\n") + (insert headers) + (widen) + (forward-line) + (while (not (eobp)) + (if (looking-at "^-") + (insert "- ")) + (forward-line)) + (insert "\n-----BEGIN PGP SIGNATURE-----\n") + (insert "Version: " (car items) "\n\n") + (insert (mapconcat 'identity (cddr items) "\n")) + (insert "\n-----END PGP SIGNATURE-----\n") + (let ((mm-security-handle (list (format "multipart/signed")))) + (mml2015-clean-buffer) + (let ((coding-system-for-write (or gnus-newsgroup-charset + 'iso-8859-1))) + (funcall (mml2015-clear-verify-function))) + (setq info + (or (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-details) + (mm-handle-multipart-ctl-parameter + mm-security-handle 'gnus-info))))) + (when info + (let (buffer-read-only bface eface) + (save-restriction + (message-narrow-to-head) + (goto-char (point-max)) + (forward-line -1) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (message-remove-header "X-Gnus-PGP-Verify") + (if (re-search-forward "^X-PGP-Sig:" nil t) + (forward-line) + (goto-char (point-max))) + (narrow-to-region (point) (point)) + (insert "X-Gnus-PGP-Verify: " info "\n") + (goto-char (point-min)) + (forward-line) + (while (not (eobp)) + (if (not (looking-at "^[ \t]")) + (insert " ")) + (forward-line)) + ;; Do highlighting. + (goto-char (point-min)) + (when (looking-at "\\([^:]+\\): *") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (put-text-property (match-end 0) (point-max) + 'face eface)))))))) + (eval-and-compile (mapcar (lambda (func) @@ -2514,18 +2837,18 @@ If variable `gnus-use-long-file-name' is non-nil, it is gfunc (cdr func)) (setq afunc func gfunc (intern (format "gnus-%s" func)))) - (fset gfunc - (if (not (fboundp afunc)) - nil - `(lambda (&optional interactive &rest args) - ,(documentation afunc t) - (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) - (if interactive - (call-interactively ',afunc) - (apply ',afunc args)))))))) + (defalias gfunc + (if (fboundp afunc) + `(lambda (&optional interactive &rest args) + ,(documentation afunc t) + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively ',afunc) + (apply ',afunc args)))))))) '(article-hide-headers + article-verify-x-pgp-sig article-hide-boring-headers article-toggle-headers article-treat-overstrike @@ -2534,6 +2857,9 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-remove-cr article-display-x-face article-de-quoted-unreadable + article-de-base64-unreadable + article-decode-HZ + article-wash-html article-hide-list-identifiers article-hide-pgp article-strip-banner @@ -2560,7 +2886,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-emphasize article-treat-dumbquotes article-normalize-headers - (article-show-all . gnus-article-show-all-headers)))) + (article-show-all-headers . gnus-article-show-all-headers) + (article-show-all . gnus-article-show-all)))) ;;; ;;; Gnus article mode @@ -2578,11 +2905,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "s" gnus-article-show-summary "\C-c\C-m" gnus-article-mail "?" gnus-article-describe-briefly - gnus-mouse-2 gnus-article-push-button - "\r" gnus-article-press-button - "\t" gnus-article-next-button - "\M-\t" gnus-article-prev-button - "e" gnus-article-edit + "e" gnus-summary-edit-article "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-i" gnus-info-find-node @@ -2637,7 +2960,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] - ["Remove carriage return" gnus-article-remove-cr t])) + ["Remove carriage return" gnus-article-remove-cr t] + ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency @@ -2680,7 +3004,9 @@ commands: (make-local-variable 'gnus-article-mime-handles) (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) - (make-local-variable 'gnus-article-washed-types) + (make-local-variable 'gnus-article-wash-types) + (make-local-variable 'gnus-article-charset) + (make-local-variable 'gnus-article-ignored-charsets) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) @@ -2709,12 +3035,12 @@ commands: ;; Init original article buffer. (save-excursion (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) + (set-buffer-multibyte nil) (setq major-mode 'gnus-original-article-mode) (make-local-variable 'gnus-original-article)) (if (get-buffer name) (save-excursion (set-buffer name) - (kill-all-local-variables) (buffer-disable-undo) (setq buffer-read-only t) (unless (eq major-mode 'gnus-article-mode) @@ -2760,12 +3086,7 @@ commands: (mime-display-message mime-message-structure gnus-article-buffer nil gnus-article-mode-map) (when all-headers - (gnus-article-hide-headers nil -1)) - ) - ;; `mime-display-message' changes current buffer to `gnus-article-buffer'. - (make-local-variable 'mime-button-mother-dispatcher) - (setq mime-button-mother-dispatcher - (function gnus-article-push-button)) + (gnus-article-hide-headers nil -1))) (run-hooks 'gnus-mime-article-prepare-hook)) (defun gnus-article-display-traditional-message () @@ -2846,8 +3167,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (message "Message marked for downloading")) (gnus-summary-mark-article article gnus-canceled-mark) (unless (memq article gnus-newsgroup-sparse) - (gnus-error 1 - "No such article (may have expired or been canceled)"))))) + (gnus-error 1 "No such article (may have expired or been canceled)"))))) (if (or (eq result 'pseudo) (eq result 'nneething)) (progn @@ -2898,6 +3218,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-set-global-variables) (setq gnus-have-all-headers (or all-headers gnus-show-all-headers)))) + (save-excursion + (gnus-configure-windows 'article)) (when (or (numberp article) (stringp article)) (gnus-article-prepare-display) @@ -2919,10 +3241,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." (goto-char (point-min)) (when (re-search-forward "^[^\t ]+:" nil t) (goto-char (match-beginning 0))) - (let* ((entity (if (eq 1 (point-min)) - (get-text-property 1 'mime-view-entity) - (get-text-property (point) 'mime-view-entity))) - last-entity child-entity next type) + (let ((entity (if (eq 1 (point-min)) + (get-text-property 1 'mime-view-entity) + (get-text-property (point) 'mime-view-entity))) + last-entity child-entity next type) (setq child-entity (mime-entity-children entity)) (if child-entity (setq last-entity (nth (1- (length child-entity)) @@ -2936,12 +3258,11 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-treat-article 'head) (put-text-property (point-min) (point-max) 'article-treated-header t) (goto-char (point-max))) - (while (and (not (eobp)) - entity - (setq next - (or (next-single-property-change (point) - 'mime-view-entity) - (point-max)))) + (while (and (not (eobp)) entity) + (setq next (set-marker + (make-marker) + (next-single-property-change (point) 'mime-view-entity + nil (point-max)))) (let ((types (mime-entity-content-type entity))) (while (eq 'multipart (mime-content-type-primary-type types)) (setq entity (car (mime-entity-children entity)) @@ -2963,9 +3284,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." (get-text-property next 'mime-view-entity))) (setq next (next-single-property-change next - 'mime-view-entity)))))) - (setq next (or (next-single-property-change next 'mime-view-entity) - (point-max))) + 'mime-view-entity + nil (point-max))))))) + (setq next (next-single-property-change next 'mime-view-entity + nil (point-max))) (save-restriction (narrow-to-region (point) next) (gnus-article-prepare-mime-display) @@ -2979,8 +3301,8 @@ If ALL-HEADERS is non-nil, no headers are hidden." (if (eq entity last-entity) 1 2) type) - (setq entity (get-text-property next 'mime-view-entity)) - (goto-char (point-max))))))) + (goto-char (point-max))) + (setq entity (get-text-property next 'mime-view-entity)))))) ;;;###autoload (defun gnus-article-prepare-display () @@ -2989,7 +3311,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-run-hooks 'gnus-tmp-internal-hook) (gnus-run-hooks 'gnus-article-prepare-hook) ;; Display message. - (let (mime-display-header-hook) + (let (mime-display-header-hook mime-display-text/plain-hook) (funcall (if gnus-show-mime (progn (setq mime-message-structure gnus-current-headers) @@ -3062,12 +3384,15 @@ value of the variable `gnus-show-mime' is non-nil." '((gnus-article-press-button "\r" "Toggle Display") (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-view-part-as-type "t" "View As Type...") + (gnus-mime-view-part-as-charset "C" "View As charset...") (gnus-mime-save-part "o" "Save...") + (gnus-mime-save-part-and-strip "\C-o" "Save and Strip") (gnus-mime-copy-part "c" "View As Text, In Other Buffer") (gnus-mime-inline-part "i" "View As Text, In This Buffer") (gnus-mime-internalize-part "E" "View Internally") (gnus-mime-externalize-part "e" "View Externally") - (gnus-mime-pipe-part "|" "Pipe To Command..."))) + (gnus-mime-pipe-part "|" "Pipe To Command...") + (gnus-mime-action-on-part "." "Take action on the part"))) (defun gnus-article-mime-part-status () (with-current-buffer gnus-article-buffer @@ -3076,22 +3401,21 @@ value of the variable `gnus-show-mime' is non-nil." (format " (%d parts)" (length (mime-entity-children entity))) "")))) -(defvar gnus-mime-button-map nil) -(unless gnus-mime-button-map - (setq gnus-mime-button-map (make-sparse-keymap)) - (set-keymap-parent gnus-mime-button-map gnus-article-mode-map) - (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button) - (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu) - (mapcar (lambda (c) - (define-key gnus-mime-button-map (cadr c) (car c))) - gnus-mime-button-commands)) +(defvar gnus-mime-button-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map gnus-article-mode-map) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map gnus-down-mouse-3 'gnus-mime-button-menu) + (dolist (c gnus-mime-button-commands) + (define-key map (cadr c) (car c))) + map)) (defun gnus-mime-button-menu (event) "Construct a context-sensitive menu of MIME commands." (interactive "e") - (save-excursion + (save-window-excursion (let ((pos (event-start event))) - (set-buffer (window-buffer (posn-window pos))) + (select-window (posn-window pos)) (goto-char (posn-point pos)) (gnus-article-check-buffer) (let ((response (x-popup-menu @@ -3100,7 +3424,7 @@ value of the variable `gnus-show-mime' is non-nil." (cons (caddr c) (car c))) gnus-mime-button-commands)))))) (if response - (funcall response)))))) + (call-interactively response)))))) (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." @@ -3110,11 +3434,73 @@ value of the variable `gnus-show-mime' is non-nil." (let ((handles (or handles gnus-article-mime-handles)) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) - gnus-newsgroup-ignored-charsets))) - (if (stringp (car handles)) - (gnus-mime-view-all-parts (cdr handles)) - (mapcar 'mm-display-part handles))))) + (with-current-buffer gnus-summary-buffer + gnus-newsgroup-ignored-charsets))) + (mm-remove-parts handles) + (goto-char (point-min)) + (or (search-forward "\n\n") (goto-char (point-max))) + (let (buffer-read-only) + (delete-region (point) (point-max))) + (mm-display-parts handles)))) + +(defun gnus-mime-save-part-and-strip () + "Save the MIME part under point then replace it with an external body." + (interactive) + (gnus-article-check-buffer) + (let* ((data (get-text-property (point) 'gnus-data)) + (file (mm-save-part data)) + param) + (when file + (with-current-buffer (mm-handle-buffer data) + (erase-buffer) + (insert "Content-Type: " (mm-handle-media-type data)) + (mml-insert-parameter-string (cdr (mm-handle-type data)) + '(charset)) + (insert "\n") + (insert "Content-ID: " (message-make-message-id) "\n") + (insert "Content-Transfer-Encoding: binary\n") + (insert "\n")) + (setcdr data + (cdr (mm-make-handle nil + `("message/external-body" + (access-type . "LOCAL-FILE") + (name . ,file))))) + (set-buffer gnus-summary-buffer) + (gnus-article-edit-article + `(lambda () + (erase-buffer) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets)) + (mbl mml-buffer-list)) + (setq mml-buffer-list nil) + (insert-buffer gnus-original-article-buffer) + (mime-to-mml gnus-article-mime-handles) + (setq gnus-article-mime-handles nil) + (make-local-hook 'kill-buffer-hook) + (let ((mbl1 mml-buffer-list)) + (setq mml-buffer-list mbl) + (set (make-local-variable 'mml-buffer-list) mbl1)) + (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t))) + `(lambda (no-highlight) + (let ((mail-parse-charset (or gnus-article-charset + ',gnus-newsgroup-charset)) + (message-options message-options) + (message-options-set-recipient) + (mail-parse-ignored-charsets + (or gnus-article-ignored-charsets + ',gnus-newsgroup-ignored-charsets))) + (mml-to-mime) + (mml-destroy-buffers) + (remove-hook 'kill-buffer-hook + 'mml-destroy-buffers t) + (kill-local-variable 'mml-buffer-list)) + (gnus-summary-edit-article-done + ,(or (mail-header-references gnus-current-headers) "") + ,(gnus-group-read-only-p) + ,gnus-summary-buffer no-highlight)))))) (defun gnus-mime-save-part () "Save the MIME part under point." @@ -3137,13 +3523,33 @@ value of the variable `gnus-show-mime' is non-nil." (let ((data (get-text-property (point) 'gnus-data))) (mm-interactively-view-part data))) -(defun gnus-mime-view-part-as-type () +(defun gnus-mime-view-part-as-type-internal () + (gnus-article-check-buffer) + (let* ((name (mail-content-type-get + (mm-handle-type (get-text-property (point) 'gnus-data)) + 'name)) + (def-type (and name (mm-default-file-encoding name)))) + (and def-type (cons def-type 0)))) + +(defun gnus-mime-view-part-as-type (mime-type) "Choose a MIME media type, and view the part as such." (interactive - (list (completing-read "View as MIME type: " mailcap-mime-types))) + (list (completing-read + "View as MIME type: " + (mapcar #'list (mailcap-mime-types)) + nil nil + (gnus-mime-view-part-as-type-internal)))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) - (gnus-mm-display-part handle))) + (gnus-mm-display-part + (mm-make-handle (mm-handle-buffer handle) + (cons mime-type (cdr (mm-handle-type handle))) + (mm-handle-encoding handle) + (mm-handle-undisplayer handle) + (mm-handle-disposition handle) + (mm-handle-description handle) + (mm-handle-cache handle) + (mm-handle-id handle))))) (defun gnus-mime-copy-part (&optional handle) "Put the the MIME part under point into a new buffer." @@ -3168,28 +3574,63 @@ value of the variable `gnus-show-mime' is non-nil." (setq buffer-file-name nil)) (goto-char (point-min)))) -(defun gnus-mime-inline-part (&optional handle) +(defun gnus-mime-inline-part (&optional handle arg) "Insert the MIME part under point into the current buffer." - (interactive) + (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - contents + contents charset (b (point)) buffer-read-only) - (if (mm-handle-undisplayer handle) + (if (and (not arg) (mm-handle-undisplayer handle)) (mm-remove-part handle) (setq contents (mm-get-part handle)) + (cond + ((not arg) + (setq charset (or (mail-content-type-get + (mm-handle-type handle) 'charset) + gnus-newsgroup-charset))) + ((numberp arg) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (setq charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (read-coding-system "Charset: "))))) (forward-line 2) - (mm-insert-inline handle contents) + (mm-insert-inline handle + (if (and charset + (setq charset (mm-charset-to-coding-system + charset)) + (not (eq charset 'ascii))) + (mm-decode-coding-string contents charset) + contents)) (goto-char b)))) +(defun gnus-mime-view-part-as-charset (&optional handle arg) + "Insert the MIME part under point into the current buffer." + (interactive (list nil current-prefix-arg)) + (gnus-article-check-buffer) + (let* ((handle (or handle (get-text-property (point) 'gnus-data))) + contents charset + (b (point)) + buffer-read-only) + (if (mm-handle-undisplayer handle) + (mm-remove-part handle)) + (let ((gnus-newsgroup-charset + (or (cdr (assq arg + gnus-summary-show-article-charset-alist)) + (read-coding-system "Charset: "))) + (gnus-newsgroup-ignored-charsets 'gnus-all)) + (gnus-article-press-button)))) + (defun gnus-mime-externalize-part (&optional handle) "View the MIME part under point with an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (mm-user-display-methods nil) - (mm-inline-large-images nil) + (mm-inlined-types nil) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) @@ -3199,11 +3640,12 @@ value of the variable `gnus-show-mime' is non-nil." (mm-display-part handle)))) (defun gnus-mime-internalize-part (&optional handle) - "View the MIME part under point with an internal viewer." + "View the MIME part under point with an internal viewer. +In no internal viewer is available, use an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) - (mm-user-display-methods '((".*" . inline))) + (mm-inlined-types '(".*")) (mm-inline-large-images t) (mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets @@ -3213,6 +3655,16 @@ value of the variable `gnus-show-mime' is non-nil." (mm-remove-part handle) (mm-display-part handle)))) +(defun gnus-mime-action-on-part (&optional action) + "Do something with the MIME attachment at \(point\)." + (interactive + (list (completing-read "Action: " gnus-mime-action-alist))) + (gnus-article-check-buffer) + (let ((action-pair (assoc action gnus-mime-action-alist))) + (if action-pair + (funcall (cdr action-pair))))) + + (defun gnus-article-part-wrapper (n function) (save-current-buffer (set-buffer gnus-article-buffer) @@ -3242,6 +3694,11 @@ value of the variable `gnus-show-mime' is non-nil." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-copy-part)) +(defun gnus-article-view-part-as-charset (n) + "Copy MIME part N, which is the numerical prefix." + (interactive "p") + (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset)) + (defun gnus-article-externalize-part (n) "View MIME part N externally, which is the numerical prefix." (interactive "p") @@ -3252,11 +3709,33 @@ value of the variable `gnus-show-mime' is non-nil." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-inline-part)) -(defun gnus-article-view-part (n) +(defun gnus-article-mime-match-handle-first (condition) + (if condition + (let ((alist gnus-article-mime-handle-alist) ihandle n) + (while (setq ihandle (pop alist)) + (if (and (cond + ((functionp condition) + (funcall condition (cdr ihandle))) + ((eq condition 'undisplayed) + (not (or (mm-handle-undisplayer (cdr ihandle)) + (equal (mm-handle-media-type (cdr ihandle)) + "multipart/alternative")))) + ((eq condition 'undisplayed-alternative) + (not (mm-handle-undisplayer (cdr ihandle)))) + (t t)) + (gnus-article-goto-part (car ihandle)) + (or (not n) (< (car ihandle) n))) + (setq n (car ihandle)))) + (or n 1)) + 1)) + +(defun gnus-article-view-part (&optional n) "View MIME part N, which is the numerical prefix." - (interactive "p") + (interactive "P") (save-current-buffer (set-buffer gnus-article-buffer) + (or (numberp n) (setq n (gnus-article-mime-match-handle-first + gnus-article-mime-match-handle-function))) (when (> n (length gnus-article-mime-handle-alist)) (error "No such part")) (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) @@ -3266,6 +3745,11 @@ value of the variable `gnus-show-mime' is non-nil." (when (eq (gnus-mm-display-part handle) 'internal) (gnus-set-window-start))))))) +(defsubst gnus-article-mime-total-parts () + (if (bufferp (car gnus-article-mime-handles)) + 1 ;; single part + (1- (length gnus-article-mime-handles)))) + (defun gnus-mm-display-part (handle) "Display HANDLE and fix MIME button." (let ((id (get-text-property (point) 'gnus-part)) @@ -3299,7 +3783,7 @@ value of the variable `gnus-show-mime' is non-nil." (narrow-to-region (point) (point-max)) (gnus-treat-article nil id - (1- (length gnus-article-mime-handles)) + (gnus-article-mime-total-parts) (mm-handle-media-type handle))))) (select-window window)))) (goto-char point) @@ -3320,6 +3804,8 @@ value of the variable `gnus-show-mime' is non-nil." 'name) (mail-content-type-get (mm-handle-disposition handle) 'filename) + (mail-content-type-get (mm-handle-type handle) + 'url) "")) (gnus-tmp-type (mm-handle-media-type handle)) (gnus-tmp-description @@ -3351,21 +3837,30 @@ value of the variable `gnus-show-mime' is non-nil." article-type annotation gnus-data ,handle)) (setq e (point)) - (widget-convert-button 'link b e - :mime-handle handle - :action 'gnus-widget-press-button - :button-keymap gnus-mime-button-map - :help-echo - (lambda (widget) - ;; Needed to properly clear the message - ;; due to a bug in wid-edit - (setq help-echo-owns-message t) - (format - "Click to %s the MIME part; %s for more options" - (if (mm-handle-displayed-p - (widget-get widget :mime-handle)) - "hide" "show") - (if gnus-xemacs "button3" "mouse-3")))))) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-button-map + :help-echo + (lambda (widget/window &optional overlay pos) + ;; Needed to properly clear the message due to a bug in + ;; wid-edit (XEmacs only). + (if (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) + (format + "%S: %s the MIME part; %S: more options" + (aref gnus-mouse-2 0) + ;; XEmacs will get a single widget arg; Emacs 21 will get + ;; window, overlay, position. + (if (mm-handle-displayed-p + (if overlay + (with-current-buffer (gnus-overlay-buffer overlay) + (widget-get (widget-at (gnus-overlay-start overlay)) + :mime-handle)) + (widget-get widget/window :mime-handle))) + "hide" "show") + (aref gnus-down-mouse-3 0)))))) (defun gnus-widget-press-button (elems el) (goto-char (widget-get elems :from)) @@ -3391,7 +3886,7 @@ value of the variable `gnus-show-mime' is non-nil." ;; Top-level call; we clean up. (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) - (setq gnus-article-mime-handle-alist nil)) ;; A trick. + (setq gnus-article-mime-handle-alist nil));; A trick. (setq gnus-article-mime-handles handles) ;; We allow users to glean info from the handles. (when gnus-article-mime-part-function @@ -3412,13 +3907,13 @@ value of the variable `gnus-show-mime' is non-nil." (narrow-to-region (point) (point-max)) (gnus-treat-article nil 1 1) (widen))) - (if (not ihandles) - ;; Highlight the headers. - (save-excursion - (save-restriction - (article-goto-body) - (narrow-to-region (point-min) (point)) - (gnus-treat-article 'head)))))))) + (unless ihandles + ;; Highlight the headers. + (save-excursion + (save-restriction + (article-goto-body) + (narrow-to-region (point-min) (point)) + (gnus-treat-article 'head)))))))) (defvar gnus-mime-display-multipart-as-mixed nil) @@ -3442,7 +3937,21 @@ value of the variable `gnus-show-mime' is non-nil." (not gnus-mime-display-multipart-as-mixed)) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. - (gnus-mime-display-part (cadr handle))) + ;;(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))) + ((equal (car handle) "multipart/signed") + (or (memq 'signed gnus-article-wash-types) + (push 'signed gnus-article-wash-types)) + (gnus-insert-mime-security-button handle) + (gnus-mime-display-mixed (cdr handle))) + ((equal (car handle) "multipart/encrypted") + (or (memq 'encrypted gnus-article-wash-types) + (push 'encrypted gnus-article-wash-types)) + (gnus-insert-mime-security-button handle) + (gnus-mime-display-mixed (cdr handle))) ;; Other multiparts are handled like multipart/mixed. (t (gnus-mime-display-mixed (cdr handle))))) @@ -3467,41 +3976,46 @@ value of the variable `gnus-show-mime' is non-nil." (when (string-match (pop ignored) type) (throw 'ignored nil))) (if (and (setq not-attachment - (or (not (mm-handle-disposition handle)) - (equal (car (mm-handle-disposition handle)) - "inline") - (mm-attachment-override-p handle))) + (and (not (mm-inline-override-p handle)) + (or (not (mm-handle-disposition handle)) + (equal (car (mm-handle-disposition handle)) + "inline") + (mm-attachment-override-p handle)))) (mm-automatic-display-p handle) (or (mm-inlined-p handle) (mm-automatic-external-display-p type))) (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 (1+ (length gnus-article-mime-handle-alist))) + beg) (push (cons id handle) gnus-article-mime-handle-alist) (when (or (not display) (not (gnus-unbuttonized-mime-type-p type))) - (gnus-article-insert-newline) + ;(gnus-article-insert-newline) (gnus-insert-mime-button handle id (list (or display (and not-attachment text)))) - (gnus-article-insert-newline) - (gnus-article-insert-newline) - (setq move t))) - (let ((beg (point))) + (gnus-article-insert-newline) + ;(gnus-article-insert-newline) + ;; Remember modify the number of forward lines. + (setq move t)) + (setq beg (point)) (cond (display (when move - (forward-line -2) + (forward-line -1) (setq beg (point))) (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets - (save-excursion (set-buffer gnus-summary-buffer) + (save-excursion (condition-case () + (set-buffer gnus-summary-buffer) + (error)) gnus-newsgroup-ignored-charsets))) (mm-display-part handle t)) (goto-char (point-max))) ((and text not-attachment) (when move - (forward-line -2) + (forward-line -1) (setq beg (point))) (gnus-article-insert-newline) (mm-insert-inline handle (mm-get-part handle)) @@ -3511,8 +4025,8 @@ value of the variable `gnus-show-mime' is non-nil." (save-restriction (narrow-to-region beg (point)) (gnus-treat-article - nil (length gnus-article-mime-handle-alist) - (1- (length gnus-article-mime-handles)) + nil id + (gnus-article-mime-total-parts) (mm-handle-media-type handle))))))))) (defun gnus-unbuttonized-mime-type-p (type) @@ -3550,6 +4064,7 @@ value of the variable `gnus-show-mime' is non-nil." (unless (setq not-pref (cadr (member preferred ihandles))) (setq not-pref (car ihandles))) (when (or ibegend + (not preferred) (not (gnus-unbuttonized-mime-type-p "multipart/alternative"))) (gnus-add-text-properties @@ -3614,7 +4129,7 @@ value of the variable `gnus-show-mime' is non-nil." (narrow-to-region (car begend) (point-max)) (gnus-treat-article nil (length gnus-article-mime-handle-alist) - (1- (length gnus-article-mime-handles)) + (gnus-article-mime-total-parts) (mm-handle-media-type handle)))))) (goto-char (point-max)) (setcdr begend (point-marker))))) @@ -3625,25 +4140,26 @@ value of the variable `gnus-show-mime' is non-nil." "Return a string which display status of article washing." (save-excursion (set-buffer gnus-article-buffer) - (let ((cite (gnus-article-hidden-text-p 'cite)) - (headers (gnus-article-hidden-text-p 'headers)) - (boring (gnus-article-hidden-text-p 'boring-headers)) - (pgp (gnus-article-hidden-text-p 'pgp)) - (pem (gnus-article-hidden-text-p 'pem)) - (signature (gnus-article-hidden-text-p 'signature)) - (overstrike (gnus-article-hidden-text-p 'overstrike)) - (emphasis (gnus-article-hidden-text-p 'emphasis)) - (mime gnus-show-mime)) + (let ((cite (memq 'cite gnus-article-wash-types)) + (headers (memq 'headers gnus-article-wash-types)) + (boring (memq 'boring-headers gnus-article-wash-types)) + (pgp (memq 'pgp gnus-article-wash-types)) + (pem (memq 'pem gnus-article-wash-types)) + (signed (memq 'signed gnus-article-wash-types)) + (encrypted (memq 'encrypted gnus-article-wash-types)) + (signature (memq 'signature gnus-article-wash-types)) + (overstrike (memq 'overstrike gnus-article-wash-types)) + (emphasis (memq 'emphasis gnus-article-wash-types))) (format "%c%c%c%c%c%c%c" (if cite ?c ? ) (if (or headers boring) ?h ? ) - (if (or pgp pem) ?p ? ) + (if (or pgp pem signed encrypted) ?p ? ) (if signature ?s ? ) (if overstrike ?o ? ) - (if mime ?m ? ) + (if gnus-show-mime ?m ? ) (if emphasis ?e ? ))))) -(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) +(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) (defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. @@ -3735,7 +4251,8 @@ Argument LINES specifies lines to be scrolled up." (forward-line 1) (setq start nil)) (unless (or (cond ((eq (1+ (buffer-size)) (point)) - (setq end-of-buffer t)) + (and (pos-visible-in-window-p) + (setq end-of-buffer t))) ((eobp) (setq end-of-page t))) (not lines)) @@ -3749,7 +4266,8 @@ Argument LINES specifies lines to be scrolled up." (t (if start (set-window-start (selected-window) start) - (scroll-up lines)) + (let (window-pixel-scroll-increment) + (scroll-up lines))) nil)))) (defun gnus-article-prev-page (&optional lines) @@ -3768,7 +4286,8 @@ Argument LINES specifies lines to be scrolled down." (gnus-narrow-to-page -1)) (t (condition-case nil - (scroll-down lines) + (let (window-pixel-scroll-increment) + (scroll-down lines)) (beginning-of-buffer (goto-char (point-min)))))))) @@ -3859,7 +4378,8 @@ Argument LINES specifies lines to be scrolled down." ;; We disable the pick minor mode commands. (let (gnus-pick-mode) (setq func (lookup-key (current-local-map) keys)))) - (if (not func) + (if (or (not func) + (numberp func)) (ding) (unless (member keys nosave-in-article) (set-buffer gnus-article-current-summary)) @@ -3939,8 +4459,7 @@ If given a prefix, show the hidden text instead." ;; We only request an article by message-id when we do not have the ;; headers for it, so we'll have to get those. (when (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) + (gnus-read-header article)) ;; If the article number is negative, that means that this article ;; doesn't belong in this newsgroup (possibly), so we find its @@ -3958,8 +4477,7 @@ If given a prefix, show the hidden text instead." ;; This is a sparse gap article. (setq do-update-line article) (setq article (mail-header-id header)) - (let ((gnus-override-method gnus-refer-article-method)) - (setq sparse-header (gnus-read-header article))) + (setq sparse-header (gnus-read-header article)) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -3974,11 +4492,11 @@ If given a prefix, show the hidden text instead." gnus-newsgroup-name))) (when (and (eq (car method) 'nneething) (vectorp header)) - (let ((dir (concat + (let ((dir (expand-file-name + (mail-header-subject header) (file-name-as-directory (or (cadr (assq 'nneething-address method)) - (nth 1 method))) - (mail-header-subject header)))) + (nth 1 method)))))) (when (file-directory-p dir) (setq article 'nneething) (gnus-group-enter-directory dir)))))))) @@ -4010,20 +4528,40 @@ If given a prefix, show the hidden text instead." (gnus-cache-request-article article group)) 'article) ;; Get the article and put into the article buffer. - ((or (stringp article) (numberp article)) - (let ((gnus-override-method - (and (stringp article) gnus-refer-article-method)) + ((or (stringp article) + (numberp article)) + (let ((gnus-override-method gnus-override-method) + (methods (and (stringp article) + gnus-refer-article-method)) + result (buffer-read-only nil)) - (erase-buffer) - (gnus-kill-all-overlays) - (gnus-check-group-server) - (when (gnus-request-article article group (current-buffer)) - (when (numberp article) - (gnus-async-prefetch-next group article gnus-summary-buffer) - (when gnus-keep-backlog - (gnus-backlog-enter-article - group article (current-buffer)))) - 'article))) + (if (or (not (listp methods)) + (and (symbolp (car methods)) + (assq (car methods) nnoo-definition-alist))) + (setq methods (list methods))) + (when (and (null gnus-override-method) + methods) + (setq gnus-override-method (pop methods))) + (while (not result) + (when (eq gnus-override-method 'current) + (setq gnus-override-method gnus-current-select-method)) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((gnus-newsgroup-name group)) + (gnus-check-group-server)) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article + gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + (setq result 'article)) + (if (not result) + (if methods + (setq gnus-override-method (pop methods)) + (setq result 'done)))) + (and (eq result 'article) 'article))) ;; It was a pseudo. (t article))) @@ -4039,6 +4577,7 @@ If given a prefix, show the hidden text instead." (if (get-buffer gnus-original-article-buffer) (set-buffer gnus-original-article-buffer) (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) + (set-buffer-multibyte nil) (buffer-disable-undo) (setq major-mode 'gnus-original-article-mode) (setq buffer-read-only t)) @@ -4146,27 +4685,6 @@ groups." (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." (interactive "P") - (save-excursion - (save-restriction - (widen) - (when (article-goto-body) - (let ((lines (count-lines (point) (point-max))) - (length (- (point-max) (point))) - (case-fold-search t) - (body (copy-marker (point)))) - (goto-char (point-min)) - (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward - "^x-content-length:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string length))) - (goto-char (point-min)) - (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t) - (delete-region (match-beginning 1) (match-end 1)) - (insert (number-to-string lines))))))) (let ((func gnus-article-edit-done-function) (buf (current-buffer)) (start (window-start))) @@ -4197,7 +4715,7 @@ groups." "Exit the article editing without updating." (interactive) ;; We remove all text props from the article buffer. - (let ((buf (format "%s" (buffer-string))) + (let ((buf (buffer-substring-no-properties (point-min) (point-max))) (curbuf (current-buffer)) (p (point)) (window-start (window-start))) @@ -4311,7 +4829,7 @@ after replacing with the original article." ;;; Internal Variables: -(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" +(defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)" "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) @@ -4330,9 +4848,9 @@ after replacing with the original article." ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... - ("]*\\)>" 0 t gnus-button-embedded-url 1) + ("]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. - (,gnus-button-url-regexp 0 t gnus-button-url 0)) + (,gnus-button-url-regexp 0 t browse-url 0)) "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where @@ -4360,9 +4878,9 @@ variable it the real callback function." ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 0 t gnus-button-mailto 0) - ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0) + ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0) + ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0) ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t gnus-button-message-id 3)) "*Alist of headers and regexps to match buttons in article heads. @@ -4518,21 +5036,28 @@ do the highlighting. See the documentation for those functions." It does this by highlighting everything after `gnus-signature-separator' using `gnus-signature-face'." (interactive) + (when gnus-signature-face + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (save-restriction + (when (gnus-article-narrow-to-signature) + (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) + 'face gnus-signature-face))))))) + +(defun gnus-article-buttonize-signature () + "Add button to the signature." + (interactive) (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) - (save-restriction - (when (and gnus-signature-face - (gnus-article-narrow-to-signature)) - (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) - 'face gnus-signature-face) - (widen) - (gnus-article-search-signature) - (let ((start (match-beginning 0)) - (end (set-marker (make-marker) (1+ (match-end 0))))) - (gnus-article-add-button start (1- end) 'gnus-signature-toggle - end))))))) + (when (gnus-article-search-signature) + (gnus-article-add-button (match-beginning 0) (match-end 0) + 'gnus-signature-toggle + (set-marker (make-marker) + (1+ (match-end 0)))))))) (defun gnus-button-in-region-p (b e prop) "Say whether PROP exists in the region." @@ -4634,7 +5159,11 @@ specified by `gnus-button-alist'." (nconc (and gnus-article-mouse-face (list gnus-mouse-face-prop gnus-article-mouse-face)) (list 'gnus-callback fun) - (and data (list 'gnus-data data))))) + (and data (list 'gnus-data data)))) + (widget-convert-button 'link from to :action 'gnus-widget-press-button + ;; Quote `:button-keymap' for Mule 2.3 + ;; but it won't work. + ':button-keymap gnus-widget-button-keymap)) ;;; Internal functions: @@ -4647,10 +5176,12 @@ specified by `gnus-button-alist'." (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t)) + (inhibit-point-motion-hooks t) + (limit (next-single-property-change end 'mime-view-entity + nil (point-max)))) (if (get-text-property end 'invisible) - (gnus-article-unhide-text end (point-max)) - (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) + (gnus-article-unhide-text end limit) + (gnus-article-hide-text end limit gnus-hidden-properties))))) (defun gnus-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. @@ -4784,29 +5315,19 @@ forbidden in URL encoding." (message-goto-subject))))) (defun gnus-button-mailto (address) - ;; Mail to ADDRESS. + "Mail to ADDRESS." (set-buffer (gnus-copy-article-buffer)) - (gnus-setup-message 'reply - (message-reply address))) - -(defun gnus-button-reply (address) - ;; Reply to ADDRESS. - (gnus-setup-message 'reply - (message-reply address))) + (message-reply address)) -(defun gnus-button-url (address) - "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. - (if (listp browse-url-browser-function) - (browse-url address) - (funcall browse-url-browser-function address))) +(defalias 'gnus-button-reply 'message-reply) (defun gnus-button-embedded-url (address) - "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. - (if (listp browse-url-browser-function) - (browse-url (gnus-strip-whitespace address)) - (funcall browse-url-browser-function (gnus-strip-whitespace address)))) + "Activate ADDRESS with `browse-url'." + (browse-url (gnus-strip-whitespace address))) + +(defun gnus-article-smiley-display () + "Display \"smileys\" as small graphical icons." + (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max))) ;;; Next/prev buttons in the article buffer. @@ -4901,8 +5422,8 @@ forbidden in URL encoding." '(mail-decode-encoded-word-region) "List of methods used to decode headers. -This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is -FUNCTION, FUNCTION will be apply to all newsgroups. If item is a +This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item +is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups whose names match REGEXP. @@ -4920,13 +5441,13 @@ For example: (eq gnus-newsgroup-name (car gnus-decode-header-methods-cache))) (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) - (mapc '(lambda (x) - (if (symbolp x) - (nconc gnus-decode-header-methods-cache (list x)) - (if (and gnus-newsgroup-name - (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-header-methods-cache - (list (cdr x)))))) + (mapcar (lambda (x) + (if (symbolp x) + (nconc gnus-decode-header-methods-cache (list x)) + (if (and gnus-newsgroup-name + (string-match (car x) gnus-newsgroup-name)) + (nconc gnus-decode-header-methods-cache + (list (cdr x)))))) gnus-decode-header-methods)) (let ((xlist gnus-decode-header-methods-cache)) (pop xlist) @@ -4954,16 +5475,26 @@ For example: (entity (static-unless (featurep 'xemacs) (when (eq 'head condition) (get-text-property (point-min) 'mime-view-entity)))) - val elem) + val elem buttonized) (gnus-run-hooks 'gnus-part-display-hook) (unless gnus-inhibit-treatment (while (setq elem (pop alist)) - (setq val (symbol-value (car elem))) + (setq val + (save-excursion + (if (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-summary-buffer)) + (symbol-value (car elem)))) (when (and (or (consp val) treated-type) (gnus-treat-predicate val) (or (not (get (car elem) 'highlight)) highlightp)) + (when (and (not buttonized) + (memq (car elem) + '(gnus-treat-hide-signature + gnus-treat-highlight-signature))) + (gnus-article-buttonize-signature) + (setq buttonized t)) (save-restriction (funcall (cadr elem))))) ;; FSF Emacsen does not inherit the existing text properties @@ -4974,11 +5505,13 @@ For example: 'mime-view-entity entity)))))) ;; Dynamic variables. -(defvar part-number) -(defvar total-parts) -(defvar type) -(defvar condition) -(defvar length) +(eval-when-compile + (defvar part-number) + (defvar total-parts) + (defvar type) + (defvar condition) + (defvar length)) + (defun gnus-treat-predicate (val) (cond ((null val) @@ -5016,6 +5549,151 @@ For example: (t (error "%S is not a valid value" val)))) +(defun gnus-article-encrypt-body (protocol &optional n) + "Encrypt the article body." + (interactive + (list + (or gnus-article-encrypt-protocol + (completing-read "Encrypt protocol: " + gnus-article-encrypt-protocol-alist + nil t)) + current-prefix-arg)) + (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) + (unless func + (error (format "Can't find the encrypt protocol %s" protocol))) + (if (equal gnus-newsgroup-name "nndraft:drafts") + (error "Can't encrypt the article in group nndraft:drafts.")) + (if (equal gnus-newsgroup-name "nndraft:queue") + (error "Don't encrypt the article in group nndraft:queue.")) + (gnus-summary-iterate n + (save-excursion + (set-buffer gnus-summary-buffer) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) + (summary-buffer gnus-summary-buffer) + references point) + (gnus-set-global-variables) + (when (gnus-group-read-only-p) + (error "The current newsgroup does not support article encrypt")) + (gnus-summary-show-article t) + (setq references + (or (mail-header-references gnus-current-headers) "")) + (set-buffer gnus-article-buffer) + (let* ((buffer-read-only nil) + (headers + (mapcar (lambda (field) + (and (save-restriction + (message-narrow-to-head) + (goto-char (point-min)) + (search-forward field nil t)) + (prog2 + (message-narrow-to-field) + (buffer-substring (point-min) (point-max)) + (delete-region (point-min) (point-max)) + (widen)))) + '("Content-Type:" "Content-Transfer-Encoding:" + "Content-Disposition:")))) + (message-narrow-to-head) + (message-remove-header "MIME-Version") + (goto-char (point-max)) + (setq point (point)) + (insert (apply 'concat headers)) + (widen) + (narrow-to-region point (point-max)) + (let ((message-options message-options)) + (message-options-set 'message-sender user-mail-address) + (message-options-set 'message-recipients user-mail-address) + (message-options-set 'message-sign-encrypt 'not) + (funcall func)) + (goto-char (point-min)) + (insert "MIME-Version: 1.0\n") + (widen) + (gnus-summary-edit-article-done + references nil summary-buffer t)) + (when gnus-keep-backlog + (gnus-backlog-remove-article + (car gnus-article-current) (cdr gnus-article-current))) + (save-excursion + (when (get-buffer gnus-original-article-buffer) + (set-buffer gnus-original-article-buffer) + (setq gnus-original-article nil))) + (when gnus-use-cache + (gnus-cache-update-article + (car gnus-article-current) (cdr gnus-article-current)))))))) + +(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]]%)%}\n" + "The following specs can be used: +%t The security MIME type +%i Additional info") + +(defvar gnus-mime-security-button-line-format-alist + '((?t gnus-tmp-type ?s) + (?i gnus-tmp-info ?s))) + +(defvar gnus-mime-security-button-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map gnus-article-mode-map) + (define-key map gnus-mouse-2 'gnus-article-push-button) + (define-key map "\r" 'gnus-article-press-button) + map)) + +(defvar gnus-mime-security-details-buffer nil) + +(defun gnus-mime-security-show-details (handle) + (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details))) + (if details + (progn + (if (gnus-buffer-live-p gnus-mime-security-details-buffer) + (with-current-buffer gnus-mime-security-details-buffer + (erase-buffer) + t) + (setq gnus-mime-security-details-buffer + (gnus-get-buffer-create "*MIME Security Details*"))) + (with-current-buffer gnus-mime-security-details-buffer + (insert details)) + (pop-to-buffer gnus-mime-security-details-buffer)) + (gnus-message 5 "No details.")))) + +(defun gnus-insert-mime-security-button (handle &optional displayed) + (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) + (gnus-tmp-type + (concat + (or (nth 2 (assoc protocol mm-verify-function-alist)) + (nth 2 (assoc protocol mm-decrypt-function-alist)) + "Unknown") + (if (equal (car handle) "multipart/signed") + " Signed" " Encrypted"))) + (gnus-tmp-info + (or (mm-handle-multipart-ctl-parameter handle 'gnus-info) + "Undecided")) + b e) + (unless (bolp) + (insert "\n")) + (setq b (point)) + (gnus-eval-format + gnus-mime-security-button-line-format + gnus-mime-security-button-line-format-alist + `(local-map ,gnus-mime-security-button-map + keymap ,gnus-mime-security-button-map + gnus-callback gnus-mime-security-show-details + article-type annotation + gnus-data ,handle)) + (setq e (point)) + (widget-convert-button + 'link b e + :mime-handle handle + :action 'gnus-widget-press-button + :button-keymap gnus-mime-security-button-map + :help-echo + (lambda (widget/window &optional overlay pos) + ;; Needed to properly clear the message due to a bug in + ;; wid-edit (XEmacs only). + (if (boundp 'help-echo-owns-message) + (setq help-echo-owns-message t)) + (format + "%S: show detail" + (aref gnus-mouse-2 0)))))) + ;;; @ for mime-view ;;; @@ -5037,14 +5715,6 @@ For example: (set-alist 'mime-preview-quitting-method-alist 'gnus-original-article-mode #'gnus-mime-preview-quitting-method) -(defun gnus-following-method (buf) - (set-buffer buf) - (message-followup) - (message-yank-original) - (kill-buffer buf) - (goto-char (point-min)) - ) - (set-alist 'mime-preview-following-method-alist 'gnus-original-article-mode #'gnus-following-method)