X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=4ae78adbcfa6f1f94668cc3f2d76db4aa3dc2e6e;hb=bd5c2da9b674dbe4d52c456ce996481be2e8e687;hp=3e85863c8557974d21f7ad96dd01e5e318e92ed3;hpb=0503f98281ccd513fdf272dfaf6bc3060ce3d52c;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 3e85863c8..4ae78adbc 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -136,7 +136,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." @@ -205,7 +205,10 @@ regexp. If it matches, the text in question is not a signature." (if (and (fboundp 'image-type-available-p) (image-type-available-p 'xbm)) 'gnus-article-display-xface - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -") + (if gnus-article-compface-xbm + "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -" + "{ 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." @@ -480,7 +483,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 @@ -602,8 +605,8 @@ displayed by the first non-nil matching CONTENT face." ("\223" "``") ("\224" "\"") ("\225" "*") - ("\226" "---") - ("\227" "-") + ("\226" "-") + ("\227" "--") ("\231" "(TM)") ("\233" ">") ("\234" "oe") @@ -656,6 +659,7 @@ used." (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) @@ -768,6 +772,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. @@ -894,8 +905,9 @@ See the manual for details." (defcustom gnus-treat-display-xface (and (or (and (fboundp 'image-type-available-p) - (image-type-available-p 'xbm)) - (and gnus-xemacs (featurep 'xface))) + (image-type-available-p 'xbm) + (string-match "^0x" (shell-command-to-string "uncompface"))) + (and (featurep 'xemacs) (featurep 'xface))) 'head) "Display X-Face headers. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -904,9 +916,12 @@ 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))) + t nil) "Display smileys. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -914,7 +929,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." @@ -971,6 +986,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) @@ -1550,9 +1566,11 @@ or not." (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 "quoted-printable" type)))) (article-goto-body) - (quoted-printable-decode-region (point) (point-max) charset))))) + (quoted-printable-decode-region + (point) (point-max) (mm-charset-to-coding-system charset)))))) (defun article-de-base64-unreadable (&optional force) "Translate a base64 article. @@ -1575,13 +1593,14 @@ If FORCE, decode the article whether it is marked as base64 not." (unless charset (setq charset gnus-newsgroup-charset)) (when (or force - (and type (string-match "base64" (downcase type)))) + (and type (let ((case-fold-search t)) + (string-match "base64" type)))) (article-goto-body) (save-restriction (narrow-to-region (point) (point-max)) (base64-decode-region (point-min) (point-max)) - (if (mm-coding-system-p charset) - (mm-decode-coding-region (point-min) (point-max) charset))))))) + (mm-decode-coding-region + (point-min) (point-max) (mm-charset-to-coding-system charset))))))) (eval-when-compile (require 'rfc1843)) @@ -2287,75 +2306,77 @@ This format is defined by the `gnus-article-time-format' variable." (funcall function group headers (symbol-value variable))) result) (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)))))) + (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))) @@ -2681,6 +2702,8 @@ commands: (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) (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) @@ -2901,6 +2924,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-mime-view-part "v" "View Interactively...") (gnus-mime-view-part-as-type "t" "View As Type...") (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") @@ -2952,6 +2976,77 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-mime-view-all-parts (cdr handles)) (mapcar 'mm-display-part 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)) + (insert-buffer gnus-original-article-buffer) + (save-restriction + (message-narrow-to-head) + (message-remove-header "Content-Type") + (message-remove-header "MIME-Version") + (message-remove-header "Content-Transfer-Encoding") + (mail-decode-encoded-word-region (point-min) (point-max)) + (goto-char (point-max))) + (forward-char 1) + (delete-region (point) (point-max)) + (setq mml-buffer-list nil) + (if (stringp (car gnus-article-mime-handles)) + (mml-insert-mime gnus-article-mime-handles) + (mml-insert-mime gnus-article-mime-handles t)) + (mm-destroy-parts 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." (interactive) @@ -3046,9 +3141,13 @@ If ALL-HEADERS is non-nil, no headers are hidden." gnus-summary-show-article-charset-alist)) (read-coding-system "Charset: "))))) (forward-line 2) - (mm-insert-inline handle (if charset - (mm-decode-coding-string contents charset) - 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-externalize-part (&optional handle) @@ -3167,6 +3266,11 @@ In no internal viewer is available, use an external viewer." (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)) @@ -3200,7 +3304,7 @@ In no internal viewer is available, use an external viewer." (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) @@ -3221,6 +3325,8 @@ In no internal viewer is available, use an external viewer." '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 @@ -3354,6 +3460,14 @@ In no internal viewer is available, use an external viewer." ;;;!!!to the first part. (gnus-mime-display-part (cadr handle))) ;; Other multiparts are handled like multipart/mixed. + ((equal (car handle) "multipart/signed") + (or (memq 'signed gnus-article-wash-types) + (push 'signed gnus-article-wash-types)) + (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-mime-display-mixed (cdr handle))) (t (gnus-mime-display-mixed (cdr handle))))) @@ -3388,21 +3502,23 @@ In no internal viewer is available, use an external viewer." (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-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 @@ -3414,7 +3530,7 @@ In no internal viewer is available, use an external viewer." (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)) @@ -3424,8 +3540,8 @@ In no internal viewer is available, use an external viewer." (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) @@ -3527,7 +3643,7 @@ In no internal viewer is available, use an external viewer." (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))))) @@ -3543,13 +3659,15 @@ In no internal viewer is available, use an external viewer." (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" (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 emphasis ?e ? ))))) @@ -3751,7 +3869,7 @@ Argument LINES specifies lines to be scrolled down." (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) (push (or key last-command-event) unread-command-events) - (setq keys (if gnus-xemacs + (setq keys (if (featurep 'xemacs) (events-to-keys (read-key-sequence nil)) (read-key-sequence nil))))) @@ -3932,10 +4050,10 @@ If given a prefix, show the hidden text instead." gnus-refer-article-method)) result (buffer-read-only nil)) - (setq methods - (if (listp methods) - methods - (list methods))) + (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))) @@ -4073,27 +4191,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))) @@ -4594,16 +4691,14 @@ forbidden in URL encoding." (message-goto-subject)))) (defun gnus-button-mailto (address) - ;; Mail to ADDRESS. + "Mail to ADDRESS." (set-buffer (gnus-copy-article-buffer)) (message-reply address)) -(defun gnus-button-reply (address) - ;; Reply to ADDRESS. - (message-reply address)) +(defalias 'gnus-button-reply 'message-reply) (defun gnus-button-embedded-url (address) - "Browse ADDRESS." + "Activate ADDRESS with `browse-url'." (browse-url (gnus-strip-whitespace address))) ;;; Next/prev buttons in the article buffer. @@ -4743,11 +4838,13 @@ For example: (funcall (cadr elem))))))) ;; 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)