X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=2839a603a9a27d4378ee1ac09101bd9bfb6698d3;hp=2a36c43130c1efe9b27ee1960d25d8d198e56057;hb=81f7131c6375332dcc584797020db2e31f22d5d6;hpb=b1bd45c45d95b14ac041e82fdb8e23d3b0386564 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 2a36c4313..2839a603a 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,6 +1,6 @@ ;;; gnus-art.el --- article mode commands for Gnus -;; Copyright (C) 1996-2011 Free Software Foundation, Inc. +;; Copyright (C) 1996-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news @@ -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) @@ -268,11 +268,14 @@ This can also be a list of the above values." (if (or (gnus-image-type-available-p 'xface) (gnus-image-type-available-p 'pbm)) 'gnus-display-x-face-in-from - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -") + "{ echo \ +'/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\ +; uncompface; } | icontopbm | ee -") (if (gnus-image-type-available-p 'pbm) 'gnus-display-x-face-in-from - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \ -display -")) + "{ echo \ +'/* Format_version=1, Width=48, Height=48, Depth=1, Valid_bits_per_item=16 */'\ +; 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." @@ -535,7 +538,7 @@ that the symbol of the saver function, which is specified by ;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before. (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail - "A function to save articles in your favourite format. + "A function to save articles in your favorite format. The function will be called by way of the `gnus-summary-save-article' command, and friends such as `gnus-summary-save-article-rmail'. @@ -666,7 +669,7 @@ non-nil. If the match is a string, it is used as a regexp match on the article. If the match is a symbol, that symbol will be funcalled from the buffer of the article to be saved with the newsgroup as the -parameter. If it is a list, it will be evaled in the same buffer. +parameter. If it is a list, it will be evalled in the same buffer. If this form or function returns a string, this string will be used as a possible file name; and if it returns a non-nil list, that list will be @@ -1039,7 +1042,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 +1234,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 +1262,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 +1562,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 +1666,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 +1752,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 +2276,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 +2285,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 +2351,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))))) @@ -2750,10 +2785,11 @@ summary buffer." (or how (setq how gnus-article-browse-delete-temp)) (if (eq how 'ask) (let ((files (length gnus-article-browse-html-temp-list))) - (gnus-y-or-n-p (format - "Delete all %s temporary HTML file%s? " - files - (if (> files 1) "s" "")))) + (gnus-y-or-n-p + (if (= files 1) + "Delete the temporary HTML file? " + (format "Delete all %s temporary HTML files? " + files)))) how))) (dolist (file gnus-article-browse-html-temp-list) (cond ((file-directory-p file) @@ -2789,14 +2825,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 +2846,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) @@ -2853,6 +2883,14 @@ message header will be added to the bodies of the \"text/html\" parts." (with-current-buffer gnus-article-buffer gnus-article-mime-handles) cid-dir)) + (when (eq system-type 'cygwin) + (setq cid-file + (concat "/" (substring + (with-output-to-string + (call-process "cygpath" nil + standard-output + nil "-m" cid-file)) + 0 -1)))) (replace-match (concat "file://" cid-file) nil nil nil 1)))) (unless content (setq content (buffer-string)))) @@ -3055,10 +3093,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 @@ -3204,9 +3240,16 @@ always hide." Point is left at the beginning of the narrowed-to region." (narrow-to-region (goto-char (point-min)) - (if (search-forward "\n\n" nil 1) - (1- (point)) - (point-max))) + (cond + ;; Absolutely no headers displayed. + ((looking-at "\n") + (point)) + ;; Normal headers. + ((search-forward "\n\n" nil 1) + (1- (point))) + ;; Nothing but headers. + (t + (point-max)))) (goto-char (point-min))) (defun article-goto-body () @@ -3393,7 +3436,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 +3454,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 @@ -3463,7 +3521,7 @@ possible values." combined-lapsed)) (error "Unknown conversion type: %s" type)) (condition-case () - (let ((time (date-to-time date))) + (let ((time (ignore-errors (date-to-time date)))) (cond ;; Convert to the local timezone. ((eq type 'local) @@ -3515,6 +3573,7 @@ possible values." (segments 3) lapsed-string) (while (and + time (setq lapsed-string (concat " (" (article-lapsed-string time segments) ")")) (> (+ (length date-string) @@ -4399,6 +4458,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. @@ -4442,6 +4502,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) @@ -4454,7 +4516,9 @@ commands: (defun gnus-article-setup-buffer () "Initialize the article buffer." (let* ((name (if gnus-single-article-buffer "*Article*" - (concat "*Article " gnus-newsgroup-name "*"))) + (concat "*Article " + (gnus-group-decoded-name gnus-newsgroup-name) + "*"))) (original (progn (string-match "\\*Article" name) (concat " *Original Article" @@ -4487,6 +4551,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)) @@ -4511,6 +4576,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) @@ -5022,14 +5093,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")) @@ -5147,10 +5215,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) @@ -5240,12 +5305,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) @@ -5263,9 +5323,8 @@ Compressed files like .gz and .bz2 are decompressed." (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (mm-read-coding-system "Charset: ")))) - (t - (if (mm-handle-undisplayer handle) - (mm-remove-part handle)))) + ((mm-handle-undisplayer handle) + (mm-remove-part handle))) (forward-line 2) (mm-display-inline handle) (goto-char b))))) @@ -5379,8 +5438,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) @@ -5650,8 +5709,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)) @@ -5679,7 +5737,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)) @@ -5992,7 +6051,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) @@ -6016,7 +6076,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) @@ -6132,6 +6193,16 @@ Provided for backwards compatibility." (not gnus-inhibit-hiding)) (gnus-article-hide-headers))) +(declare-function shr-put-image "shr" (data alt &optional flags)) + +(defun gnus-shr-put-image (data alt &optional flags) + "Put image DATA with a string ALT. Enable image to be deleted." + (let ((image (shr-put-image data (propertize (or alt "*") + 'gnus-image-category 'shr) + flags))) + (when image + (gnus-add-image 'shr image)))) + ;;; Article savers. (defun gnus-output-to-file (file-name) @@ -6806,23 +6877,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)) @@ -6834,7 +6898,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)))