X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=b282afd961c7f4ac7aba06b1d8a9c1504b6d6a5b;hb=d84b26f66f1975b52a15ca2caf5f10da5103e42e;hp=96f3136c2b9e29b7f9216cf152ddeedf02b4084a;hpb=9e2d2f3c5084e290935304a372a38a3ded2e95b0;p=gnus diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 96f3136c2..b282afd96 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,13 +163,12 @@ "*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) (defcustom gnus-visible-headers - "^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:" + "^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:" "*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." @@ -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 @@ -683,7 +686,7 @@ beginning of a line." :type 'regexp :group 'gnus-article-various) -(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m" +(defcustom gnus-article-mode-line-format "Gnus: %g %S%m" "*The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description. @@ -691,6 +694,7 @@ The following additional specs are available: %w The article washing status. %m The number of MIME parts in the article." + :version "24.1" :type 'string :group 'gnus-article-various) @@ -1014,14 +1018,38 @@ on parts -- for instance, adding Vcard info to a database." :group 'gnus-article-mime :type '(repeat (cons :format "%v" (string :tag "MIME type") function))) -(defcustom gnus-article-date-lapsed-new-header nil - "Whether the X-Sent and Date headers can coexist. -When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will -either replace the old \"Date:\" header (if this variable is nil), or -be added below it (otherwise)." - :version "21.1" +(defcustom gnus-article-date-headers '(combined-lapsed) + "A list of Date header formats to display. +Valid formats are `ut' (universal time), `local' (local time +zone), `english' (readable English), `lapsed' (elapsed time), +`combined-lapsed' (both the original date and the elapsed time), +`original' (the original date header), `iso8601' (ISO8601 +format), and `user-defined' (a user-defined format defined by the +`gnus-article-time-format' variable). + +You have as many date headers as you want in the article buffer. +Some of these headers are updated automatically. See +`gnus-article-update-date-headers' for details." + :version "24.1" :group 'gnus-article-headers - :type 'boolean) + :type '(repeat + (item :tag "Universal time (UT)" :value 'ut) + (item :tag "Local time zone" :value 'local) + (item :tag "Readable English" :value 'english) + (item :tag "Elapsed time" :value 'lapsed) + (item :tag "Original and elapsed time" :value 'combined-lapsed) + (item :tag "Original date header" :value 'original) + (item :tag "ISO8601 format" :value 'iso8601) + (item :tag "User-defined" :value 'user-defined))) + +(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" + :group 'gnus-article-headers + :type '(choice + (item :tag "Don't update" :value nil) + integer)) (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative "Function called with a MIME handle as the argument. @@ -1126,6 +1154,15 @@ predicate. See Info node `(gnus)Customizing Articles'." :type gnus-article-treat-head-custom) (put 'gnus-treat-buttonize-head 'highlight t) +(defcustom gnus-treat-date 'head + "Display dates according to the `gnus-article-date-headers' variable. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles'." + :version "24.1" + :group 'gnus-article-treat + :link '(custom-manual "(gnus)Customizing Articles") + :type gnus-article-treat-head-custom) + (defcustom gnus-treat-emphasize 50000 "Emphasize text. Valid values are nil, t, `head', `first', `last', an integer or a @@ -1197,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) @@ -1219,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)") @@ -1257,65 +1318,6 @@ predicate. See Info node `(gnus)Customizing Articles'." :type gnus-article-treat-custom) (put 'gnus-treat-highlight-citation 'highlight t) -(defcustom gnus-treat-date-ut nil - "Display the Date in UT (GMT). -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - -(defcustom gnus-treat-date-local nil - "Display the Date in the local timezone. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - -(defcustom gnus-treat-date-english nil - "Display the Date in a format that can be read aloud in English. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :version "22.1" - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - -(defcustom gnus-treat-date-lapsed nil - "Display the Date header in a way that says how much time has elapsed. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - -(defcustom gnus-treat-date-original nil - "Display the date in the original timezone. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - -(defcustom gnus-treat-date-iso8601 nil - "Display the date in the ISO8601 format. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :version "21.1" - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - -(defcustom gnus-treat-date-user-defined nil - "Display the date in a user-defined format. -The format is defined by the `gnus-article-time-format' variable. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-head-custom) - (defcustom gnus-treat-strip-headers-in-body t "Strip the X-No-Archive header line from the beginning of the body. Valid values are nil, t, `head', `first', `last', an integer or a @@ -1560,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. @@ -1664,22 +1666,15 @@ 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-date-ut gnus-article-date-ut) - (gnus-treat-date-local gnus-article-date-local) - (gnus-treat-date-english gnus-article-date-english) - (gnus-treat-date-original gnus-article-date-original) - (gnus-treat-date-user-defined gnus-article-date-user) - (gnus-treat-date-iso8601 gnus-article-date-iso8601) - (gnus-treat-date-lapsed gnus-article-date-lapsed) (gnus-treat-display-x-face gnus-article-display-x-face) (gnus-treat-display-face gnus-article-display-face) (gnus-treat-hide-headers gnus-article-maybe-hide-headers) @@ -1691,6 +1686,7 @@ regexp." (gnus-treat-mail-picon gnus-treat-mail-picon) (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) (gnus-treat-strip-pem gnus-article-hide-pem) + (gnus-treat-date gnus-article-treat-date) (gnus-treat-from-gravatar gnus-treat-from-gravatar) (gnus-treat-mail-gravatar gnus-treat-mail-gravatar) (gnus-treat-highlight-headers gnus-article-highlight-headers) @@ -1756,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)) @@ -2279,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." @@ -2286,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. @@ -2349,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))))) @@ -2781,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) @@ -2820,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)))))))) @@ -2844,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) @@ -2884,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)))) @@ -3086,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 @@ -3235,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 () @@ -3423,87 +3435,93 @@ lines forward." (forward-line 1) (setq ended t))))) -(defun article-date-ut (&optional type highlight) - "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 -`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header -should replace the \"Date:\" one, or should be added below it." +(defun article-treat-date () + (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. +The default type is `ut'. See `gnus-article-date-headers' for +possible values." (interactive (list 'ut t)) - (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]") - (date-regexp (cond ((not gnus-article-date-lapsed-new-header) - tdate-regexp) - ((eq type 'lapsed) - "^X-Sent:[ \t]") - (article-lapsed-timer - "^Date:[ \t]") - (t - tdate-regexp))) - (case-fold-search t) + (let* ((case-fold-search t) (inhibit-read-only t) (inhibit-point-motion-hooks t) + (first t) + (visible-date (mail-fetch-field "Date")) pos date bface eface) (save-excursion - (save-restriction - (widen) - (goto-char (point-min)) - (while (or (setq date (get-text-property (setq pos (point)) - 'original-date)) - (when (setq pos (next-single-property-change - (point) 'original-date)) - (setq date (get-text-property pos 'original-date)) - t)) - (narrow-to-region - pos (if (setq pos (text-property-any pos (point-max) - 'original-date nil)) - (progn - (goto-char pos) - (if (or (bolp) (eobp)) - (point) - (1+ (point)))) - (point-max))) - (goto-char (point-min)) - (when (re-search-forward tdate-regexp nil t) - (setq bface (get-text-property (point-at-bol) 'face) - eface (get-text-property (1- (point-at-eol)) 'face))) + (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)) - (setq pos nil) - ;; Delete any old Date headers. - (while (re-search-forward date-regexp nil t) - (if pos - (delete-region (point-at-bol) (progn - (gnus-article-forward-header) - (point))) + (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) - (forward-char -1) - (point))) - (setq pos (point)))) - (when (and (not pos) - (re-search-forward tdate-regexp nil t)) - (forward-line 1)) - (gnus-goto-char pos) - (insert (article-make-date-line date (or type 'ut))) - (unless pos - (insert "\n") - (forward-line -1)) - ;; Do highlighting. - (beginning-of-line) - (when (looking-at "\\([^:]+\\): *\\(.*\\)$") - (put-text-property (match-beginning 1) (1+ (match-end 1)) - 'face bface) - (put-text-property (match-beginning 2) (match-end 2) - 'face eface)) - (put-text-property (point-min) (1- (point-max)) 'original-date date) - (goto-char (point-max)) - (widen)))))) + (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 + ((null type) + (list 'ut)) + ((atom type) + (list type)) + (t + type))) + (insert (article-make-date-line date (or this-type 'ut)) "\n") + (forward-line -1) + (beginning-of-line) + (put-text-property (point) (1+ (point)) + 'original-date date) + (put-text-property (point) (1+ (point)) + 'gnus-date-type this-type) + ;; Do highlighting. + (when (looking-at "\\([^:]+\\): *\\(.*\\)$") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (put-text-property (match-beginning 2) (match-end 2) + 'face eface)) + (forward-line 1))) (defun article-make-date-line (date type) "Return a DATE line of TYPE." - (unless (memq type '(local ut original user iso8601 lapsed english date-lapsed)) + (unless (memq type '(local ut original user-defined iso8601 lapsed english + 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) @@ -3528,7 +3546,7 @@ should replace the \"Date:\" one, or should be added below it." (substring date 0 (match-beginning 0)) date))) ;; Let the user define the format. - ((eq type 'user) + ((eq type 'user-defined) (let ((format (or (condition-case nil (with-current-buffer gnus-summary-buffer gnus-article-time-format) @@ -3546,12 +3564,26 @@ should replace the \"Date:\" one, or should be added below it." (format "%s%02d%02d" (if (> tz 0) "+" "-") (/ (abs tz) 3600) (/ (% (abs tz) 3600) 60))))) - ;; Do an X-Sent lapsed format. + ;; Do a lapsed format. ((eq type 'lapsed) - (concat "X-Sent: " (article-lapsed-string time))) + (concat "Date: " (article-lapsed-string time))) ;; A combined date/lapsed format. - ((eq type 'date-lapsed) - (concat "Date: " (article-lapsed-string time 3))) + ((eq type 'combined-lapsed) + (let ((date-string (article-make-date-line date 'original)) + (segments 3) + lapsed-string) + (while (and + time + (setq lapsed-string + (concat " (" (article-lapsed-string time segments) ")")) + (> (+ (length date-string) + (length lapsed-string)) + (+ fill-column 6)) + (> segments 0)) + (setq segments (1- segments))) + (if (> segments 0) + (concat date-string lapsed-string) + date-string))) ;; Display the date in proper English ((eq type 'english) (let ((dtime (decode-time time))) @@ -3591,12 +3623,11 @@ should replace the \"Date:\" one, or should be added below it." (setq max-segments (length article-time-units))) (cond ((null real-time) - "X-Sent: Unknown") + "Unknown") ((zerop sec) - "X-Sent: Now") + "Now") (t (concat - "X-Sent: " ;; This is a bit convoluted, but basically we go ;; through the time units for years, weeks, etc, ;; and divide things to see whether that results @@ -3646,26 +3677,54 @@ function and want to see what the date was before converting." (interactive (list t)) (article-date-ut 'lapsed highlight)) +(defun article-date-combined-lapsed (&optional highlight) + "Convert the current article date to time lapsed since it was sent." + (interactive (list t)) + (article-date-ut 'combined-lapsed highlight)) + (defun article-update-date-lapsed () "Function to be run from a timer to update the lapsed time line." (save-match-data - (let (deactivate-mark) - (save-excursion - (ignore-errors - (walk-windows - (lambda (w) - (set-buffer (window-buffer w)) - (when (eq major-mode 'gnus-article-mode) - (let ((mark (point-marker))) - (goto-char (point-min)) - (when (re-search-forward "^X-Sent:" nil t) - (article-date-lapsed t)) - (goto-char (marker-position mark)) - (move-marker mark nil)))) - nil 'visible)))))) + (let ((buffer (current-buffer))) + (ignore-errors + (walk-windows + (lambda (w) + (set-buffer (window-buffer w)) + (when (eq major-mode 'gnus-article-mode) + (let ((old-line (count-lines (point-min) (point))) + (old-column (- (point) (line-beginning-position))) + (window-start + (window-start (get-buffer-window (current-buffer))))) + (goto-char (point-min)) + (while (re-search-forward "^Date:" nil t) + (let ((type (get-text-property (match-beginning 0) + 'gnus-date-type))) + (when (memq type '(lapsed combined-lapsed user-format)) + (when (and window-start + (not (= window-start + (save-excursion + (forward-line 1) + (point))))) + (setq window-start nil)) + (save-excursion + (article-date-ut type t (match-beginning 0))) + (forward-line 1) + (when window-start + (set-window-start (get-buffer-window (current-buffer)) + (point)))))) + (goto-char (point-min)) + (when (> old-column 0) + (setq old-line (1- old-line))) + (forward-line old-line) + (end-of-line) + (when (> (current-column) old-column) + (beginning-of-line) + (forward-char old-column))))) + nil 'visible)) + (set-buffer buffer)))) (defun gnus-start-date-timer (&optional n) - "Start a timer to update the X-Sent header in the article buffers. + "Start a timer to update the Date headers in the article buffers. The numerical prefix says how frequently (in seconds) the function is to run." (interactive "p") @@ -3676,7 +3735,7 @@ is to run." (run-at-time 1 n 'article-update-date-lapsed))) (defun gnus-stop-date-timer () - "Stop the X-Sent timer." + "Stop the Date timer." (interactive) (when article-lapsed-timer (nnheader-cancel-timer article-lapsed-timer) @@ -4301,12 +4360,14 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-date-english article-date-iso8601 article-date-original + article-treat-date article-date-ut article-decode-mime-words article-decode-charset article-decode-encoded-words article-date-user article-date-lapsed + article-date-combined-lapsed article-emphasize article-treat-dumbquotes article-treat-non-ascii @@ -4397,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. @@ -4440,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) @@ -4452,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" @@ -4485,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)) @@ -4503,8 +4570,18 @@ commands: (setq gnus-summary-buffer (gnus-summary-buffer-name gnus-newsgroup-name)) (gnus-summary-set-local-parameters gnus-newsgroup-name) + (when article-lapsed-timer + (gnus-stop-date-timer)) + (when gnus-article-update-date-headers + (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) @@ -4628,6 +4705,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (forward-line -1)) (set-window-point (get-buffer-window (current-buffer)) (point)) (gnus-configure-windows 'article) + (gnus-run-hooks 'gnus-article-prepare-hook) t)))))) ;;;###autoload @@ -4645,8 +4723,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." gnus-article-image-alist nil) (gnus-run-hooks 'gnus-tmp-internal-hook) (when gnus-display-mime-function - (funcall gnus-display-mime-function)) - (gnus-run-hooks 'gnus-article-prepare-hook))) + (funcall gnus-display-mime-function)))) ;;; ;;; Gnus Sticky Article Mode @@ -4871,8 +4948,6 @@ General format specifiers can also be used. See Info node (when (zerop parts) (error "No such part")) (pop-to-buffer gnus-article-buffer) - ;; FIXME: why is it necessary? - (sit-for 0) (or n (setq n (if (= parts 1) 1 @@ -5018,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")) @@ -5143,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) @@ -5236,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) @@ -5375,8 +5439,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) @@ -5646,8 +5710,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)) @@ -5675,7 +5738,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)) @@ -5988,7 +6052,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) @@ -6012,7 +6077,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) @@ -6128,6 +6194,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) @@ -6315,7 +6390,8 @@ specifies." (defun gnus-article-next-page-1 (lines) (condition-case () - (let ((scroll-in-place nil)) + (let ((scroll-in-place nil) + (auto-window-vscroll nil)) (scroll-up lines)) (end-of-buffer ;; Long lines may cause an end-of-buffer error. @@ -6801,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)) @@ -6829,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))) @@ -7335,9 +7407,6 @@ as a symbol to FUN." (defvar gnus-button-handle-describe-prefix "^\\(C-h\\|?\\)") -;; FIXME: Maybe we should merge some of the functions that do quite similar -;; stuff? - (defun gnus-button-handle-describe-function (url) "Call `describe-function' when pushing the corresponding URL button." (describe-function