X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=4c0f60693739f54d48789bebff5ed2675e0bdbc6;hp=5b3489a72eeca2fd62c120963d6c3011e664cffd;hb=14778499f96b7e275731331eb0f32476901430f5;hpb=63be035adb3071702f15ba818aeccaff715e1134 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 5b3489a72..4c0f60693 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -44,6 +44,7 @@ (require 'wid-edit) (require 'mm-uu) (require 'message) +(require 'mouse) (autoload 'gnus-msg-mail "gnus-msg" nil t) (autoload 'gnus-button-mailto "gnus-msg") @@ -162,8 +163,7 @@ "*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." - :type '(choice :custom-show nil - regexp + :type '(choice regexp (repeat regexp)) :group 'gnus-article-hiding) @@ -1039,7 +1039,7 @@ Some of these headers are updated automatically. See (item :tag "ISO8601 format" :value 'iso8601) (item :tag "User-defined" :value 'user-defined))) -(defcustom gnus-article-update-date-headers 1 +(defcustom gnus-article-update-date-headers nil "A number that says how often to update the date header (in seconds). If nil, don't update it at all." :version "24.1" @@ -1231,15 +1231,21 @@ predicate. See Info node `(gnus)Customizing Articles'." (defcustom gnus-treat-hide-citation nil "Hide cited text. Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." +predicate. See Info node `(gnus)Customizing Articles'. + +See `gnus-article-highlight-citation' for variables used to +control what it hides." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) (defcustom gnus-treat-hide-citation-maybe nil - "Hide cited text. + "Hide cited text according to certain conditions. Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." +predicate. See Info node `(gnus)Customizing Articles'. + +See `gnus-cite-hide-percentage' and `gnus-cite-hide-absolute' for +how to control what it hides." :group 'gnus-article-treat :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) @@ -1253,6 +1259,24 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) +(gnus-define-group-parameter + list-identifier + :variable-document + "Alist of regexps and correspondent identifiers." + :variable-group gnus-article-washing + :parameter-type + '(choice :tag "Identifier" + :value nil + (symbol :tag "Item in `gnus-list-identifiers'" none) + regexp + (const :tag "None" nil)) + :parameter-document + "If non-nil, specify how to remove `identifiers' from articles' subject. + +Any symbol is used to look up a regular expression to match the +banner in `gnus-list-identifiers'. A string is used as a regular +expression to match the identifier directly.") + (make-obsolete-variable 'gnus-treat-strip-pgp nil "Gnus 5.10 (Emacs 22.1)") @@ -1535,7 +1559,7 @@ node `(gnus)Gravatars' for details." gnus-treat-from-picon gnus-treat-from-gravatar gnus-treat-mail-gravatar) - ;; If there's much decoration, the user might prefer a boundery. + ;; If there's much decoration, the user might prefer a boundary. 'head nil) "Draw a boundary at the end of the headers. @@ -1639,14 +1663,14 @@ regexp." (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist - '((gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) + '((gnus-treat-strip-cr gnus-article-remove-cr) + (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-highlight-signature gnus-article-highlight-signature) (gnus-treat-buttonize gnus-article-add-buttons) (gnus-treat-fill-article gnus-article-fill-cited-article) (gnus-treat-fill-long-lines gnus-article-fill-cited-long-lines) - (gnus-treat-strip-cr gnus-article-remove-cr) (gnus-treat-unsplit-urls gnus-article-unsplit-urls) (gnus-treat-display-x-face gnus-article-display-x-face) (gnus-treat-display-face gnus-article-display-face) @@ -1725,9 +1749,10 @@ Initialized from `text-mode-syntax-table.") (put 'gnus-with-article-headers 'edebug-form-spec '(body)) (defmacro gnus-with-article-buffer (&rest forms) - `(with-current-buffer gnus-article-buffer - (let ((inhibit-read-only t)) - ,@forms))) + `(when (buffer-live-p (get-buffer gnus-article-buffer)) + (with-current-buffer gnus-article-buffer + (let ((inhibit-read-only t)) + ,@forms)))) (put 'gnus-with-article-buffer 'lisp-indent-function 0) (put 'gnus-with-article-buffer 'edebug-form-spec '(body)) @@ -2248,6 +2273,8 @@ unfolded." (dolist (elem gnus-article-image-alist) (gnus-delete-images (car elem)))))) +(autoload 'w3m-toggle-inline-images "w3m") + (defun gnus-article-show-images () "Show any images that are in the HTML-rendered article buffer. This only works if the article in question is HTML." @@ -2255,11 +2282,14 @@ This only works if the article in question is HTML." (gnus-with-article-buffer (save-restriction (widen) - (dolist (region (gnus-find-text-property-region (point-min) (point-max) - 'image-displayer)) - (destructuring-bind (start end function) region - (funcall function (get-text-property start 'image-url) - start end)))))) + (if (eq mm-text-html-renderer 'w3m) + (let ((mm-inline-text-html-with-images nil)) + (w3m-toggle-inline-images)) + (dolist (region (gnus-find-text-property-region (point-min) (point-max) + 'image-displayer)) + (destructuring-bind (start end function) region + (funcall function (get-text-property start 'image-url) + start end))))))) (defun gnus-article-treat-fold-newsgroups () "Unfold folded message headers. @@ -2318,10 +2348,12 @@ long lines if and only if arg is positive." (let ((start (point))) (insert "X-Boundary: ") (gnus-add-text-properties start (point) '(invisible t intangible t)) - (insert (let (str) - (while (>= (window-width) (length str)) + (insert (let (str (max (window-width))) + (if (featurep 'xemacs) + (setq max (1- max))) + (while (>= max (length str)) (setq str (concat str gnus-body-boundary-delimiter))) - (substring str 0 (window-width))) + (substring str 0 max)) "\n") (gnus-put-text-property start (point) 'gnus-decoration 'header))))) @@ -2789,14 +2821,11 @@ Return file name." ((equal (concat "<" cid ">") (mm-handle-id handle)) (setq file (expand-file-name - (or (mail-content-type-get - (mm-handle-disposition handle) 'filename) - (mail-content-type-get - (setq type (mm-handle-type handle)) 'name) - (concat - (make-temp-name "cid") - (car (rassoc (car type) mailcap-mime-extensions)))) - directory)) + (or (mm-handle-filename handle) + (concat + (make-temp-name "cid") + (car (rassoc (car (mm-handle-type handle)) mailcap-mime-extensions)))) + directory)) (mm-save-part-to-file handle file) (throw 'found file)))))))) @@ -2813,10 +2842,7 @@ message header will be added to the bodies of the \"text/html\" parts." ((or (equal (car (setq type (mm-handle-type handle))) "text/html") (and (equal (car type) "message/external-body") (or header - (setq file (or (mail-content-type-get type 'name) - (mail-content-type-get - (mm-handle-disposition handle) - 'filename)))) + (setq file (mm-handle-filename handle))) (or (mm-handle-cache handle) (condition-case code (progn (mm-extern-cache-contents handle) t) @@ -3055,10 +3081,8 @@ images if any to the browser, and deletes them when exiting the group The `gnus-list-identifiers' variable specifies what to do." (interactive) (let ((inhibit-point-motion-hooks t) - (regexp (if (consp gnus-list-identifiers) - (mapconcat 'identity gnus-list-identifiers " *\\|") - gnus-list-identifiers)) - (inhibit-read-only t)) + (regexp (gnus-group-get-list-identifiers gnus-newsgroup-name)) + (inhibit-read-only t)) (when regexp (save-excursion (save-restriction @@ -3393,7 +3417,11 @@ lines forward." (setq ended t))))) (defun article-treat-date () - (article-date-ut gnus-article-date-headers t)) + (article-date-ut (if (gnus-buffer-live-p gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer + gnus-article-date-headers) + gnus-article-date-headers) + t)) (defun article-date-ut (&optional type highlight date-position) "Convert DATE date to TYPE in the current article. @@ -3407,32 +3435,43 @@ possible values." (visible-date (mail-fetch-field "Date")) pos date bface eface) (save-excursion - (save-restriction - (goto-char (point-min)) - (when (re-search-forward "^Date:" nil t) - (setq bface (get-text-property (point-at-bol) 'face) - eface (get-text-property (1- (point-at-eol)) 'face))) - (goto-char (point-min)) - ;; Delete any old Date headers. - (if date-position - (progn - (goto-char date-position) - (setq date (get-text-property (point) 'original-date)) - (delete-region (point) - (progn - (gnus-article-forward-header) - (point))) + (goto-char (point-min)) + (when (re-search-forward "^Date:" nil t) + (setq bface (get-text-property (point-at-bol) 'face) + eface (get-text-property (1- (point-at-eol)) 'face))) + ;; Delete any old Date headers. + (if date-position + (progn + (goto-char date-position) + (setq date (get-text-property (point) 'original-date)) + (delete-region (point) + (progn + (gnus-article-forward-header) + (point))) + (article-transform-date date type bface eface)) + (save-restriction + (widen) + (goto-char (point-min)) + (while (or (get-text-property (setq pos (point)) 'original-date) + (and (setq pos (next-single-property-change + (point) 'original-date)) + (goto-char pos))) + (narrow-to-region pos (if (search-forward "\n\n" nil t) + (1+ (match-beginning 0)) + (point-max))) + (goto-char (point-min)) + (while (re-search-forward "^Date:" nil t) + (setq date (get-text-property (match-beginning 0) 'original-date)) + (delete-region (point-at-bol) (progn + (gnus-article-forward-header) + (point)))) + (when (and (not date) + visible-date) + (setq date visible-date)) + (when date (article-transform-date date type bface eface)) - (while (re-search-forward "^Date:" nil t) - (setq date (get-text-property (match-beginning 0) 'original-date)) - (delete-region (point-at-bol) (progn - (gnus-article-forward-header) - (point)))) - (when (and (not date) - visible-date) - (setq date visible-date)) - (when date - (article-transform-date date type bface eface))))))) + (goto-char (point-max)) + (widen))))))) (defun article-transform-date (date type bface eface) (dolist (this-type (cond @@ -4400,6 +4439,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (gnus-run-hooks 'gnus-article-menu-hook))) (defvar bookmark-make-record-function) +(defvar shr-put-image-function) (defun gnus-article-mode () "Major mode for displaying an article. @@ -4443,6 +4483,8 @@ commands: ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space' ;; face. (set (make-local-variable 'nobreak-char-display) nil) + ;; Enable `gnus-article-remove-images' to delete images shr.el renders. + (set (make-local-variable 'shr-put-image-function) 'gnus-shr-put-image) (setq cursor-in-non-selected-windows nil) (gnus-set-default-directory) (buffer-disable-undo) @@ -4488,6 +4530,7 @@ commands: t))) (with-current-buffer name (set (make-local-variable 'gnus-article-edit-mode) nil) + (gnus-article-stop-animations) (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) (setq gnus-article-mime-handles nil)) @@ -4512,6 +4555,12 @@ commands: (gnus-start-date-timer gnus-article-update-date-headers)) (current-buffer))))) +(defun gnus-article-stop-animations () + (dolist (timer (and (boundp 'timer-list) + timer-list)) + (when (eq (elt timer 5) 'image-animate-timeout) + (cancel-timer timer)))) + ;; Set article window start at LINE, where LINE is the number of lines ;; from the head of the article. (defun gnus-article-set-window-start (&optional line) @@ -5023,14 +5072,11 @@ Deleting parts may malfunction or destroy the article; continue? ")) (let* ((data (get-text-property (point) 'gnus-data)) (id (get-text-property (point) 'gnus-part)) (handles gnus-article-mime-handles) - (none "(none)") (description (let ((desc (mm-handle-description data))) (when desc (mail-decode-encoded-word-string desc)))) - (filename - (or (mail-content-type-get (mm-handle-disposition data) 'filename) - none)) + (filename (or (mm-handle-filename data) "(none)")) (type (mm-handle-media-type data))) (unless data (error "No MIME part under point")) @@ -5148,10 +5194,7 @@ are decompressed." (unless handle (setq handle (get-text-property (point) 'gnus-data))) (when handle - (let ((filename (or (mail-content-type-get (mm-handle-type handle) - 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename))) + (let ((filename (mm-handle-filename handle)) contents dont-decode charset coding-system) (mm-with-unibyte-buffer (mm-insert-part handle) @@ -5241,12 +5284,7 @@ Compressed files like .gz and .bz2 are decompressed." (mm-with-unibyte-buffer (mm-insert-part handle) (setq contents - (or (mm-decompress-buffer - (or (mail-content-type-get (mm-handle-type handle) - 'name) - (mail-content-type-get (mm-handle-disposition handle) - 'filename)) - nil t) + (or (mm-decompress-buffer (mm-handle-filename handle) nil t) (buffer-string)))) (cond ((not arg) @@ -5380,8 +5418,8 @@ If no internal viewer is available, use an external viewer." (defun gnus-article-part-wrapper (n function &optional no-handle interactive) "Call FUNCTION on MIME part N. -Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument. -If INTERACTIVE, call FUNCTION interactivly." +Unless NO-HANDLE, call FUNCTION with N-th MIME handle as its only argument. +If INTERACTIVE, call FUNCTION interactively." (let (window frame) ;; Check whether the article is displayed. (unless (and (gnus-buffer-live-p gnus-article-buffer) @@ -5651,8 +5689,7 @@ all parts." (defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed) (let ((gnus-tmp-name - (or (mail-content-type-get (mm-handle-type handle) 'name) - (mail-content-type-get (mm-handle-disposition handle) 'filename) + (or (mm-handle-filename handle) (mail-content-type-get (mm-handle-type handle) 'url) "")) (gnus-tmp-type (mm-handle-media-type handle)) @@ -5680,7 +5717,8 @@ all parts." gnus-callback gnus-mm-display-part gnus-part ,gnus-tmp-id article-type annotation - gnus-data ,handle)) + gnus-data ,handle + rear-nonsticky t)) (setq e (if (bolp) ;; Exclude a newline. (1- (point)) @@ -5993,7 +6031,8 @@ If displaying \"text/html\" is discouraged \(see ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id - article-type multipart)) + article-type multipart + rear-nonsticky t)) (widget-convert-button 'link from (point) :action 'gnus-widget-press-button :button-keymap gnus-widget-button-keymap) @@ -6017,7 +6056,8 @@ If displaying \"text/html\" is discouraged \(see ,gnus-mouse-face-prop ,gnus-article-mouse-face face ,gnus-article-button-face gnus-part ,id - gnus-data ,handle)) + gnus-data ,handle + rear-nonsticky t)) (widget-convert-button 'link from (point) :action 'gnus-widget-press-button :button-keymap gnus-widget-button-keymap) @@ -6133,6 +6173,15 @@ Provided for backwards compatibility." (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) +(declare-function shr-put-image "shr" (data alt)) + +(defun gnus-shr-put-image (data alt) + "Put image DATA with a string ALT. Enable image to be deleted." + (let ((image (shr-put-image data (propertize (or alt "*") + 'gnus-image-category 'shr)))) + (when image + (gnus-add-image 'shr image)))) + ;;; Article savers. (defun gnus-output-to-file (file-name) @@ -6807,23 +6856,16 @@ If given a prefix, show the hidden text instead." (numberp article)) (let ((gnus-override-method gnus-override-method) (methods (and (stringp article) - gnus-refer-article-method)) + (with-current-buffer gnus-summary-buffer + (gnus-refer-article-methods)))) (backend (car (gnus-find-method-for-group gnus-newsgroup-name))) result (inhibit-read-only t)) - (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 - (with-current-buffer gnus-summary-buffer - gnus-current-select-method))) (erase-buffer) (gnus-kill-all-overlays) (let ((gnus-newsgroup-name group)) @@ -6835,7 +6877,10 @@ If given a prefix, show the hidden text instead." gnus-summary-buffer) (when gnus-keep-backlog (gnus-backlog-enter-article - group article (current-buffer)))) + group article (current-buffer))) + (when (and gnus-agent + (gnus-agent-group-covered-p group)) + (gnus-agent-store-article article group))) (setq result 'article)) (methods (setq gnus-override-method (pop methods)))