X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=bc784f7eabb2fdd8878fd1afbc84aa7659fa4dd8;hb=0563df167689ba46e219f7915c6f5b321da614ce;hp=fef33f3bed88bbffceb341c53c02f8a90ca9a888;hpb=361fe574ceb300e11ab838842c0f3c675c07b10b;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index fef33f3..bc784f7 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,6 @@ ;;; gnus-art.el --- article mode commands for Semi-gnus -;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 +;; Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -48,6 +49,10 @@ (require 'mm-uu) ) +(autoload 'gnus-msg-mail "gnus-msg" nil t) +(autoload 'gnus-button-mailto "gnus-msg") +(autoload 'gnus-button-reply "gnus-msg" nil t) + (defgroup gnus-article nil "Article display." :link '(custom-manual "(gnus)The Article Buffer") @@ -174,9 +179,10 @@ this list." (defcustom gnus-boring-article-headers '(empty followup-to reply-to) "Headers that are only to be displayed if they have interesting data. Possible values in this list are `empty', `newsgroups', `followup-to', -`reply-to', `date', `long-to', and `many-to'." +`to-address', `reply-to', `date', `long-to', and `many-to'." :type '(set (const :tag "Headers with no content." empty) (const :tag "Newsgroups with only one group." newsgroups) + (const :tag "To identical to to-address." to-address) (const :tag "Followup-to identical to newsgroups." followup-to) (const :tag "Reply-to identical to from." reply-to) (const :tag "Date less than four days old." date) @@ -211,16 +217,17 @@ regexp. If it matches, the text in question is not a signature." :type 'sexp :group 'gnus-article-hiding) +;; Fixme: This isn't the right thing for mixed graphical and and +;; non-graphical frames in a session. +;; gnus-xmas.el overrides this for XEmacs. (defcustom gnus-article-x-face-command (cond - ;; Fixme: This isn't the right thing for mixed graphical and and - ;; non-graphical frames in a session. - ;; gnus-xmas.el overrides this for XEmacs. + ((and (fboundp 'image-type-available-p) + (module-installed-p 'x-face-e21)) + 'x-face-decode-message-header) ((and (fboundp 'image-type-available-p) (image-type-available-p 'xbm)) - (if (module-installed-p 'x-face-e21) - 'x-face-decode-message-header - 'gnus-article-display-xface)) + 'gnus-article-display-xface) ((and (not (featurep 'xemacs)) window-system (module-installed-p 'x-face-mule)) @@ -240,6 +247,7 @@ asynchronously. The compressed face will be piped to this command." (function-item gnus-article-display-xface) (function-item x-face-mule-gnus-article-display-x-face) function) + ;;:version "21.1" :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -249,25 +257,25 @@ asynchronously. The compressed face will be piped to this command." (defcustom gnus-article-banner-alist nil "Banner alist for stripping. -For example, - ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" +For example, + ((egroups . \"^[ \\t\\n]*-------------------+\\\\( \\\\(e\\\\|Yahoo! \\\\)Groups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))" :version "21.1" :type '(repeat (cons symbol regexp)) :group 'gnus-article-washing) -(gnus-define-group-parameter +(gnus-define-group-parameter banner :variable-document "Alist of regexps (to match group names) and banner." :variable-group gnus-article-washing - :parameter-type + :parameter-type '(choice :tag "Banner" :value nil (const :tag "Remove signature" signature) (symbol :tag "Item in `gnus-article-banner-alist'" none) regexp (const :tag "None" nil)) - :parameter-document + :parameter-document "If non-nil, specify how to remove `banners' from articles. Symbol `signature' means to remove signatures delimited by @@ -506,6 +514,13 @@ The following additional specs are available: :type 'hook :group 'gnus-article-various) +(when (featurep 'xemacs) + ;; Extracted from gnus-xmas-define in order to preserve user settings + (when (fboundp 'turn-off-scroll-in-place) + (add-hook 'gnus-article-mode-hook 'turn-off-scroll-in-place)) + ;; Extracted from gnus-xmas-redefine in order to preserve user settings + (add-hook 'gnus-article-mode-hook 'gnus-xmas-article-menu-add)) + (defcustom gnus-article-menu-hook nil "*Hook run after the creation of the article mode menu." :type 'hook @@ -712,17 +727,17 @@ be added below it (otherwise)." (defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative "Function called with a MIME handle as the argument. This is meant for people who want to view first matched part. -For `undisplayed-alternative' (default), the first undisplayed -part or alternative part is used. For `undisplayed', the first -undisplayed part is used. For a function, the first part which +For `undisplayed-alternative' (default), the first undisplayed +part or alternative part is used. For `undisplayed', the first +undisplayed part is used. For a function, the first part which the function return `t' is used. For `nil', the first part is used." :version "21.1" :group 'gnus-article-mime - :type '(choice + :type '(choice (item :tag "first" :value nil) (item :tag "undisplayed" :value undisplayed) - (item :tag "undisplayed or alternative" + (item :tag "undisplayed or alternative" :value undisplayed-alternative) (function))) @@ -827,6 +842,13 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-leading-whitespace nil + "Remove leading whitespace in headers. +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-hide-headers 'head "Hide headers. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -1022,6 +1044,7 @@ See the manual for details." Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." :group 'gnus-article-treat + ;;:version "21.1" :type gnus-article-treat-head-custom) (put 'gnus-treat-display-xface 'highlight t) @@ -1032,13 +1055,14 @@ See the manual for details." (image-type-available-p 'pbm)) (and (not (featurep 'xemacs)) window-system - (module-installed-p 'gnus-bitmap))) + (module-installed-p 'smiley-mule))) t nil) "Display smileys. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." :group 'gnus-article-treat + ;;:version "21.1" :type gnus-article-treat-custom) (put 'gnus-treat-display-smileys 'highlight t) @@ -1123,7 +1147,7 @@ It is a string, such as \"PGP\". If nil, ask user." (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist - '((gnus-treat-decode-article-as-default-mime-charset + `((gnus-treat-decode-article-as-default-mime-charset gnus-article-decode-article-as-default-mime-charset) (gnus-treat-x-pgp-sig gnus-article-verify-x-pgp-sig) (gnus-treat-strip-banner gnus-article-strip-banner) @@ -1146,6 +1170,7 @@ It is a string, such as \"PGP\". If nil, ask user." (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-leading-whitespace gnus-article-remove-leading-whitespace) (gnus-treat-strip-pgp gnus-article-hide-pgp) (gnus-treat-strip-pem gnus-article-hide-pem) (gnus-treat-highlight-headers gnus-article-highlight-headers) @@ -1160,7 +1185,10 @@ It is a string, such as \"PGP\". If nil, ask user." gnus-article-strip-multiple-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) - (gnus-treat-display-smileys gnus-article-smiley-display) + (gnus-treat-display-smileys ,(if (or (featurep 'xemacs) + (>= emacs-major-version 21)) + 'gnus-smiley-display + 'gnus-article-smiley-display)) (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences) (gnus-treat-display-picons gnus-article-display-picons) (gnus-treat-play-sounds gnus-earcon-display))) @@ -1172,7 +1200,7 @@ It is a string, such as \"PGP\". If nil, ask user." (defvar gnus-article-mode-syntax-table (let ((table (copy-syntax-table text-mode-syntax-table))) ;; This causes the citation match run O(2^n). - ;; (modify-syntax-entry ?- "w" table) + ;; (modify-syntax-entry ?- "w" table) (modify-syntax-entry ?> ")" table) (modify-syntax-entry ?< "(" table) table) @@ -1275,8 +1303,7 @@ Initialized from `text-mode-syntax-table.") (unless gnus-inhibit-hiding (save-excursion (save-restriction - (let ((buffer-read-only nil) - (inhibit-read-only t) + (let ((inhibit-read-only t) (case-fold-search t) (max (1+ (length gnus-sorted-header-list))) (ignored (when (not gnus-visible-headers) @@ -1366,15 +1393,30 @@ always hide." 'boring-headers))) ;; Hide boring Newsgroups header. ((eq elem 'newsgroups) - (when (equal (gnus-fetch-field "newsgroups") - (gnus-group-real-name - (if (boundp 'gnus-newsgroup-name) - gnus-newsgroup-name - ""))) + (when (gnus-string-equal + (gnus-fetch-field "newsgroups") + (gnus-group-real-name + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name + ""))) (gnus-article-hide-header "newsgroups"))) + ((eq elem 'to-address) + (let ((to (message-fetch-field "to")) + (to-address + (gnus-parameter-to-address + (if (boundp 'gnus-newsgroup-name) + gnus-newsgroup-name "")))) + (when (and to to-address + (ignore-errors + (gnus-string-equal + ;; only one address in To + (nth 1 (mail-extract-address-components to)) + to-address))) + (gnus-article-hide-header "to")))) ((eq elem 'followup-to) - (when (equal (message-fetch-field "followup-to") - (message-fetch-field "newsgroups")) + (when (gnus-string-equal + (message-fetch-field "followup-to") + (message-fetch-field "newsgroups")) (gnus-article-hide-header "followup-to"))) ((eq elem 'reply-to) (let ((from (message-fetch-field "from")) @@ -1382,9 +1424,9 @@ always hide." (when (and from reply-to (ignore-errors - (equal - (nth 1 (funcall gnus-extract-address-components from)) - (nth 1 (funcall gnus-extract-address-components reply-to))))) + (gnus-string-equal + (nth 1 (mail-extract-address-components from)) + (nth 1 (mail-extract-address-components reply-to))))) (gnus-article-hide-header "reply-to")))) ((eq elem 'date) (let ((date (message-fetch-field "date"))) @@ -1451,8 +1493,7 @@ if given a positive prefix, always hide." (header-end (point-min)) header-start field-end field-start (inhibit-point-motion-hooks t) - (inhibit-read-only t) - buffer-read-only) + (inhibit-read-only t)) (save-restriction (widen) (while (and (setq header-start @@ -1691,10 +1732,46 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (when (process-status "article-x-face") (delete-process "article-x-face")) (let ((inhibit-point-motion-hooks t) + x-faces (case-fold-search t) from last) (save-restriction (article-narrow-to-head) + (when (and buffer-read-only ;; When type `W f' + (progn + (goto-char (point-min)) + (not (re-search-forward "^X-Face:[\t ]*" nil t))) + (gnus-buffer-live-p gnus-original-article-buffer)) + (with-current-buffer gnus-original-article-buffer + (save-restriction + (article-narrow-to-head) + (while (re-search-forward "^X-Face:" nil t) + (setq x-faces + (concat + (or x-faces "") + (buffer-substring + (match-beginning 0) + (1- (re-search-forward + "^\\($\\|[^ \t]\\)" nil t)))))))) + (if x-faces + (let (point start bface eface buffer-read-only) + (goto-char (point-max)) + (forward-line -1) + (setq bface (get-text-property (gnus-point-at-bol) 'face) + eface (get-text-property (1- (gnus-point-at-eol)) 'face)) + (goto-char (point-max)) + (setq point (point)) + (insert x-faces) + (goto-char point) + (while (looking-at "\\([^:]+\\): *") + (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'face bface) + (setq start (match-end 0)) + (forward-line 1) + (while (looking-at "[\t ]") + (forward-line 1)) + (put-text-property start (point) + 'face eface))))) (goto-char (point-min)) (setq from (message-fetch-field "from")) (goto-char (point-min)) @@ -1707,7 +1784,7 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (not (string-match gnus-article-x-face-too-ugly from)))) ;; Has to be present. - (re-search-forward "^X-Face:[ \t]*" nil t)) + (re-search-forward "^X-Face:[\t ]*" nil t)) ;; This used to try to do multiple faces (`while' instead of ;; `when' above), but (a) sending multiple EOFs to xv doesn't ;; work (b) it can crash some versions of Emacs (c) are @@ -1742,7 +1819,7 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (let ((inhibit-point-motion-hooks t) buffer-read-only (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) (mail-decode-encoded-word-region (point-min) (point-max))))) @@ -1754,7 +1831,7 @@ If PROMPT (the prefix), prompt for a coding system to use." (let ((inhibit-point-motion-hooks t) (case-fold-search t) buffer-read-only (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (condition-case nil (set-buffer gnus-summary-buffer) (error)) @@ -1775,7 +1852,7 @@ If PROMPT (the prefix), prompt for a coding system to use." format (and ctl (mail-content-type-get ctl 'format))) (when cte (setq cte (mail-header-strip cte))) - (if (and ctl (not (string-match "/" (car ctl)))) + (if (and ctl (not (string-match "/" (car ctl)))) (setq ctl nil)) (goto-char (point-max))) (forward-line 1) @@ -1814,14 +1891,14 @@ or not." (setq type (gnus-fetch-field "content-transfer-encoding")) (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct + (ctl (and ct (ignore-errors (mail-header-parse-content-type ct))))) (setq charset (and ctl (mail-content-type-get ctl 'charset))) (if (stringp charset) (setq charset (intern (downcase charset))))))) - (unless charset + (unless charset (setq charset gnus-newsgroup-charset)) (when (or force (and type (let ((case-fold-search t)) @@ -1841,14 +1918,14 @@ If FORCE, decode the article whether it is marked as base64 not." (setq type (gnus-fetch-field "content-transfer-encoding")) (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct + (ctl (and ct (ignore-errors (mail-header-parse-content-type ct))))) (setq charset (and ctl (mail-content-type-get ctl 'charset))) (if (stringp charset) (setq charset (intern (downcase charset))))))) - (unless charset + (unless charset (setq charset gnus-newsgroup-charset)) (when (or force (and type (let ((case-fold-search t)) @@ -1880,14 +1957,14 @@ If FORCE, decode the article whether it is marked as base64 not." (if (gnus-buffer-live-p gnus-original-article-buffer) (with-current-buffer gnus-original-article-buffer (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct + (ctl (and ct (ignore-errors (mail-header-parse-content-type ct))))) (setq charset (and ctl (mail-content-type-get ctl 'charset))) (if (stringp charset) (setq charset (intern (downcase charset))))))) - (unless charset + (unless charset (setq charset gnus-newsgroup-charset)) (article-goto-body) (save-window-excursion @@ -1904,24 +1981,24 @@ If FORCE, decode the article whether it is marked as base64 not." "Remove list identifies from the Subject header. The `gnus-list-identifiers' variable specifies what to do." (interactive) - (save-excursion - (save-restriction - (let ((inhibit-point-motion-hooks t) - buffer-read-only) - (article-narrow-to-head) - (let ((regexp (if (stringp gnus-list-identifiers) gnus-list-identifiers - (mapconcat 'identity gnus-list-identifiers " *\\|")))) - (when regexp - (goto-char (point-min)) - (when (re-search-forward - (concat "^Subject: +\\(\\(\\(Re: +\\)?\\(" regexp - " *\\)\\)+\\(Re: +\\)?\\)") - nil t) - (let ((s (or (match-string 3) (match-string 5)))) - (delete-region (match-beginning 1) (match-end 1)) - (when s - (goto-char (match-beginning 1)) - (insert s)))))))))) + (let ((inhibit-point-motion-hooks t) + (regexp (if (consp gnus-list-identifiers) + (mapconcat 'identity gnus-list-identifiers " *\\|") + gnus-list-identifiers)) + buffer-read-only) + (when regexp + (save-excursion + (save-restriction + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward + (concat "^Subject: +\\(R[Ee]: +\\)*\\(" regexp " *\\)") + nil t) + (delete-region (match-beginning 2) (match-end 0)) + (beginning-of-line)) + (when (re-search-forward + "^Subject: +\\(\\(R[Ee]: +\\)+\\)R[Ee]: +" nil t) + (delete-region (match-beginning 1) (match-end 1)))))))) (defun article-hide-pgp () "Remove any PGP headers and signatures in the current article." @@ -2242,9 +2319,9 @@ means show, 0 means toggle." Originally it is hide instead of DUMMY." (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) - (gnus-remove-text-properties-when + (gnus-remove-text-properties-when 'article-type type - (point-min) (point-max) + (point-min) (point-max) (cons 'article-type (cons type gnus-hidden-properties))))) @@ -2337,117 +2414,116 @@ should replace the \"Date:\" one, or should be added below it." (defun article-make-date-line (date type) "Return a DATE line of TYPE." - (let ((time (condition-case () - (date-to-time date) - (error '(0 0))))) - (cond - ;; Convert to the local timezone. We have to slap a - ;; `condition-case' round the calls to the timezone - ;; functions since they aren't particularly resistant to - ;; buggy dates. - ((eq type 'local) - (let ((tz (car (current-time-zone time)))) - (format "Date: %s %s%02d%02d" (current-time-string time) - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60)))) - ;; Convert to Universal Time. - ((eq type 'ut) - (concat "Date: " - (current-time-string - (let* ((e (parse-time-string date)) - (tm (apply 'encode-time e)) - (ms (car tm)) - (ls (- (cadr tm) (car (current-time-zone time))))) - (cond ((< ls 0) (list (1- ms) (+ ls 65536))) - ((> ls 65535) (list (1+ ms) (- ls 65536))) - (t (list ms ls))))) - " UT")) - ;; Get the original date from the article. - ((eq type 'original) - (concat "Date: " (if (string-match "\n+$" date) - (substring date 0 (match-beginning 0)) - date))) - ;; Let the user define the format. - ((eq type 'user) - (if (gnus-functionp gnus-article-time-format) - (funcall gnus-article-time-format time) - (concat - "Date: " - (format-time-string gnus-article-time-format time)))) - ;; ISO 8601. - ((eq type 'iso8601) - (let ((tz (car (current-time-zone time)))) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time) - (format "%s%02d%02d" - (if (> tz 0) "+" "-") (/ (abs tz) 3600) - (/ (% (abs tz) 3600) 60))))) - ;; Do an X-Sent lapsed format. - ((eq type 'lapsed) - ;; If the date is seriously mangled, the timezone functions are - ;; liable to bug out, so we ignore all errors. - (let* ((now (current-time)) - (real-time (subtract-time now time)) - (real-sec (and real-time - (+ (* (float (car real-time)) 65536) - (cadr real-time)))) - (sec (and real-time (abs real-sec))) - num prev) + (unless (memq type '(local ut original user iso8601 lapsed english)) + (error "Unknown conversion type: %s" type)) + (condition-case () + (let ((time (date-to-time date))) (cond - ((null real-time) - "X-Sent: Unknown") - ((zerop sec) - "X-Sent: 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 - ;; in positive answers. - (mapconcat - (lambda (unit) - (if (zerop (setq num (ffloor (/ sec (cdr unit))))) - ;; The (remaining) seconds are too few to - ;; be divided into this time unit. - "" - ;; It's big enough, so we output it. - (setq sec (- sec (* num (cdr unit)))) - (prog1 - (concat (if prev ", " "") (int-to-string - (floor num)) - " " (symbol-name (car unit)) - (if (> num 1) "s" "")) - (setq prev t)))) - article-time-units "") - ;; If dates are odd, then it might appear like the - ;; article was sent in the future. - (if (> real-sec 0) - " ago" - " in the future")))))) - ;; Display the date in proper English - ((eq type 'english) - (let ((dtime (decode-time time))) - (concat - "Date: the " - (number-to-string (nth 3 dtime)) - (let ((digit (% (nth 3 dtime) 10))) - (cond - ((= digit 1) "st") - ((= digit 2) "nd") - ((= digit 3) "rd") - (t "th"))) - " of " - (nth (1- (nth 4 dtime)) gnus-english-month-names) - " " - (number-to-string (nth 5 dtime)) - " at " - (format "%02d" (nth 2 dtime)) - ":" - (format "%02d" (nth 1 dtime))))) - (t - (error "Unknown conversion type: %s" type))))) + ;; Convert to the local timezone. + ((eq type 'local) + (let ((tz (car (current-time-zone time)))) + (format "Date: %s %s%02d%02d" (current-time-string time) + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60)))) + ;; Convert to Universal Time. + ((eq type 'ut) + (concat "Date: " + (current-time-string + (let* ((e (parse-time-string date)) + (tm (apply 'encode-time e)) + (ms (car tm)) + (ls (- (cadr tm) (car (current-time-zone time))))) + (cond ((< ls 0) (list (1- ms) (+ ls 65536))) + ((> ls 65535) (list (1+ ms) (- ls 65536))) + (t (list ms ls))))) + " UT")) + ;; Get the original date from the article. + ((eq type 'original) + (concat "Date: " (if (string-match "\n+$" date) + (substring date 0 (match-beginning 0)) + date))) + ;; Let the user define the format. + ((eq type 'user) + (if (gnus-functionp gnus-article-time-format) + (funcall gnus-article-time-format time) + (concat + "Date: " + (format-time-string gnus-article-time-format time)))) + ;; ISO 8601. + ((eq type 'iso8601) + (let ((tz (car (current-time-zone time)))) + (concat + "Date: " + (format-time-string "%Y%m%dT%H%M%S" time) + (format "%s%02d%02d" + (if (> tz 0) "+" "-") (/ (abs tz) 3600) + (/ (% (abs tz) 3600) 60))))) + ;; Do an X-Sent lapsed format. + ((eq type 'lapsed) + ;; If the date is seriously mangled, the timezone functions are + ;; liable to bug out, so we ignore all errors. + (let* ((now (current-time)) + (real-time (subtract-time now time)) + (real-sec (and real-time + (+ (* (float (car real-time)) 65536) + (cadr real-time)))) + (sec (and real-time (abs real-sec))) + num prev) + (cond + ((null real-time) + "X-Sent: Unknown") + ((zerop sec) + "X-Sent: 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 + ;; in positive answers. + (mapconcat + (lambda (unit) + (if (zerop (setq num (ffloor (/ sec (cdr unit))))) + ;; The (remaining) seconds are too few to + ;; be divided into this time unit. + "" + ;; It's big enough, so we output it. + (setq sec (- sec (* num (cdr unit)))) + (prog1 + (concat (if prev ", " "") (int-to-string + (floor num)) + " " (symbol-name (car unit)) + (if (> num 1) "s" "")) + (setq prev t)))) + article-time-units "") + ;; If dates are odd, then it might appear like the + ;; article was sent in the future. + (if (> real-sec 0) + " ago" + " in the future")))))) + ;; Display the date in proper English + ((eq type 'english) + (let ((dtime (decode-time time))) + (concat + "Date: the " + (number-to-string (nth 3 dtime)) + (let ((digit (% (nth 3 dtime) 10))) + (cond + ((memq (nth 3 dtime) '(11 12 13)) "th") + ((= digit 1) "st") + ((= digit 2) "nd") + ((= digit 3) "rd") + (t "th"))) + " of " + (nth (1- (nth 4 dtime)) gnus-english-month-names) + " " + (number-to-string (nth 5 dtime)) + " at " + (format "%02d" (nth 2 dtime)) + ":" + (format "%02d" (nth 1 dtime))))))) + (error + (format "Date: %s (from Oort)" date)))) (defun article-date-local (&optional highlight) "Convert the current article date to the local timezone." @@ -2534,15 +2610,26 @@ This format is defined by the `gnus-article-time-format' variable." (let ((buffer-read-only nil)) (gnus-article-unhide-text (point-min) (point-max)))))) +(defun article-remove-leading-whitespace () + "Remove excessive whitespace from all headers." + (interactive) + (save-excursion + (save-restriction + (let ((buffer-read-only nil)) + (article-narrow-to-head) + (goto-char (point-min)) + (while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t) + (delete-region (match-beginning 1) (match-end 1))))))) + (defun article-emphasize (&optional arg) "Emphasize text according to `gnus-emphasis-alist'." (interactive (gnus-article-hidden-arg)) (unless (gnus-article-check-hidden-text 'emphasis arg) (save-excursion - (let ((alist (or + (let ((alist (or (condition-case nil - (with-current-buffer gnus-summary-buffer - gnus-article-emphasis-alist) + (with-current-buffer gnus-summary-buffer + gnus-article-emphasis-alist) (error)) gnus-emphasis-alist)) (buffer-read-only nil) @@ -2588,8 +2675,9 @@ This format is defined by the `gnus-article-time-format' variable." gnus-newsgroup-name 'highlight-words t))) gnus-emphasis-alist))))) -(defvar gnus-summary-article-menu) -(defvar gnus-summary-post-menu) +(eval-when-compile + (defvar gnus-summary-article-menu) + (defvar gnus-summary-post-menu)) ;;; Saving functions. @@ -2794,7 +2882,8 @@ The directory to save in defaults to `gnus-article-save-directory'." (cond ((and (eq command 'default) gnus-last-shell-command) gnus-last-shell-command) - (command command) + ((stringp command) + command) (t (read-string (format "Shell command on %s: " @@ -2805,7 +2894,9 @@ The directory to save in defaults to `gnus-article-save-directory'." "this article")) gnus-last-shell-command)))) (when (string-equal command "") - (setq command gnus-last-shell-command)) + (if gnus-last-shell-command + (setq command gnus-last-shell-command) + (error "A command is required."))) (gnus-eval-in-buffer-window gnus-article-buffer (save-restriction (widen) @@ -2867,6 +2958,15 @@ If variable `gnus-use-long-file-name' is non-nil, it is (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))) gnus-article-save-directory))) +(defun gnus-sender-save-name (newsgroup headers &optional last-file) + "Generate file name from sender." + (let ((from (mail-header-from headers))) + (expand-file-name + (if (and from (string-match "\\([^ <]+\\)@" from)) + (match-string 1 from) + "nobody") + gnus-article-save-directory))) + (defun article-verify-x-pgp-sig () "Verify X-PGP-Sig." (interactive) @@ -2874,7 +2974,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (let ((sig (with-current-buffer gnus-original-article-buffer (gnus-fetch-field "X-PGP-Sig"))) items info headers) - (when (and sig + (when (and sig mml2015-use (mml2015-clear-verify-function)) (with-temp-buffer @@ -2885,7 +2985,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (case-fold-search t)) ;; Don't verify multiple headers. (setq headers (mapconcat (lambda (header) - (concat header ": " + (concat header ": " (mail-fetch-field header) "\n")) (split-string (nth 1 items) ",") ""))) (delete-region (point-min) (point-max)) @@ -2907,10 +3007,10 @@ If variable `gnus-use-long-file-name' is non-nil, it is (let ((coding-system-for-write (or gnus-newsgroup-charset 'iso-8859-1))) (funcall (mml2015-clear-verify-function))) - (setq info - (or (mm-handle-multipart-ctl-parameter + (setq info + (or (mm-handle-multipart-ctl-parameter mm-security-handle 'gnus-details) - (mm-handle-multipart-ctl-parameter + (mm-handle-multipart-ctl-parameter mm-security-handle 'gnus-info))))) (when info (let (buffer-read-only bface eface) @@ -2967,6 +3067,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-fill-long-lines article-capitalize-sentences article-remove-cr + article-remove-leading-whitespace article-display-x-face article-de-quoted-unreadable article-de-base64-unreadable @@ -3033,32 +3134,24 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\M-g" gnus-article-read-summary-keys) ;; Define almost undefined keys to `gnus-article-read-summary-keys'. -(mapcar - (lambda (key) - (unless (lookup-key gnus-article-mode-map key) - (define-key gnus-article-mode-map key - 'gnus-article-read-summary-keys))) - (delq nil - (append - (mapcar - (lambda (elt) - (let ((key (car elt))) - (and (> (length key) 0) - (not (eq 'menu-bar (aref key 0))) - (symbolp (lookup-key gnus-summary-mode-map key)) - key))) - (accessible-keymaps gnus-summary-mode-map)) - (let ((c 127) - keys) - (while (>= c 32) - (push (char-to-string c) keys) - (decf c)) - keys)))) - -(eval-when-compile - (defvar gnus-article-commands-menu)) +(let (keys) + (let ((key 32)) + (while (<= key 127) + (push (char-to-string key) keys) + (incf key)) + (dolist (elem (accessible-keymaps gnus-summary-mode-map)) + (setq key (car elem)) + (when (and (> (length key) 0) + (not (eq 'menu-bar (aref key 0))) + (symbolp (lookup-key gnus-summary-mode-map key))) + (push key keys)))) + (dolist (key keys) + (unless (lookup-key gnus-article-mode-map key) + (define-key gnus-article-mode-map key 'gnus-article-read-summary-keys)))) (defun gnus-article-make-menu-bar () + (unless (boundp 'gnus-article-commands-menu) + (gnus-summary-make-menu-bar)) (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define @@ -3080,20 +3173,14 @@ If variable `gnus-use-long-file-name' is non-nil, it is ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] ["Remove carriage return" gnus-article-remove-cr t] + ["Remove leading whitespace" gnus-article-remove-leading-whitespace t] ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency - (when (boundp 'gnus-summary-post-menu) - (define-key gnus-article-mode-map [menu-bar post] - (cons "Post" gnus-summary-post-menu))) + ;; Note "Post" menu is defined in gnus-sum.el for consistency - (gnus-run-hooks 'gnus-article-menu-hook)) - ;; Add the menu. - (when (boundp 'gnus-article-commands-menu) - (easy-menu-add gnus-article-commands-menu gnus-article-mode-map)) - (when (boundp 'gnus-summary-post-menu) - (easy-menu-add gnus-summary-post-menu gnus-article-mode-map))) + (gnus-run-hooks 'gnus-article-menu-hook))) ;; Fixme: do something for the Emacs tool bar in Article mode a la ;; Summary. @@ -3114,8 +3201,6 @@ commands: \\[gnus-article-describe-briefly]\t Describe the current mode briefly \\[gnus-info-find-node]\t Go to the Gnus info node" (interactive) - (when (gnus-visual-p 'article-menu 'menu) - (gnus-article-make-menu-bar)) (gnus-simplify-mode-line) (setq mode-name "Article") (setq major-mode 'gnus-article-mode) @@ -3123,6 +3208,8 @@ commands: (unless (assq 'gnus-show-mime minor-mode-alist) (push (list 'gnus-show-mime " MIME") minor-mode-alist)) (use-local-map gnus-article-mode-map) + (when (gnus-visual-p 'article-menu 'menu) + (gnus-article-make-menu-bar)) (gnus-update-format-specifications nil 'article-mode) (set (make-local-variable 'page-delimiter) gnus-page-delimiter) (make-local-variable 'gnus-page-broken) @@ -3272,7 +3359,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." result) (save-excursion (gnus-article-setup-buffer) - (set-buffer gnus-original-article-buffer) + (set-buffer gnus-article-buffer) ;; Deactivate active regions. (when (and (boundp 'transient-mark-mode) transient-mark-mode) @@ -3434,29 +3521,36 @@ If ALL-HEADERS is non-nil, no headers are hidden." ;;;###autoload (defun gnus-article-prepare-display () "Make the current buffer look like a nice article." - (setq gnus-article-wash-types nil) - (gnus-run-hooks 'gnus-tmp-internal-hook) - (gnus-run-hooks 'gnus-article-prepare-hook) + (let ((gnus-article-buffer (current-buffer)) + buffer-read-only) + (unless (eq major-mode 'gnus-article-mode) + (gnus-article-mode)) + (setq buffer-read-only nil + gnus-button-marker-list nil + gnus-article-wash-types nil) + (save-restriction + (widen) + (static-if (featurep 'xemacs) + (map-extents (lambda (extent maparg) (delete-extent extent))) + (let ((lists (overlay-lists))) + (dolist (overlay (nconc (car lists) (cdr lists))) + (delete-overlay overlay))))) + (gnus-run-hooks 'gnus-tmp-internal-hook)) + (set-buffer gnus-original-article-buffer) ;; Display message. - (let (mime-display-header-hook mime-display-text/plain-hook) - (funcall (if gnus-show-mime - (progn - (setq mime-message-structure gnus-current-headers) - (mime-buffer-entity-set-buffer-internal - mime-message-structure - gnus-original-article-buffer) - (mime-entity-set-representation-type-internal - mime-message-structure 'mime-buffer-entity) - (luna-send mime-message-structure - 'initialize-instance - mime-message-structure) - gnus-article-display-method-for-mime) - gnus-article-display-method-for-traditional))) - ;; Associate this article with the current summary buffer. - (setq gnus-article-current-summary gnus-summary-buffer) + (setq mime-message-structure gnus-current-headers) + (mime-buffer-entity-set-buffer-internal mime-message-structure + gnus-original-article-buffer) + (mime-entity-set-representation-type-internal mime-message-structure + 'mime-buffer-entity) + (luna-send mime-message-structure 'initialize-instance + mime-message-structure) + (if gnus-show-mime + (let (mime-display-header-hook mime-display-text/plain-hook) + (funcall gnus-article-display-method-for-mime)) + (funcall gnus-article-display-method-for-traditional)) ;; Call the treatment functions. - (let ((inhibit-read-only t) - buffer-read-only) + (let ((inhibit-read-only t)) (save-restriction (widen) (if gnus-show-mime @@ -3472,17 +3566,17 @@ If ALL-HEADERS is non-nil, no headers are hidden." (narrow-to-region (point) (point-max)) (gnus-treat-article nil)) (put-text-property (point-min) (point-max) 'read-only nil))) - ;; Perform the article display hooks. Incidentally, this hook is - ;; an obsolete variable by now. - (gnus-run-hooks 'gnus-article-display-hook)) + (gnus-run-hooks 'gnus-article-prepare-hook)) (defun gnus-article-decode-article-as-default-mime-charset () "Decode an article as `default-mime-charset'. It won't work if the value of the variable `gnus-show-mime' is non-nil." (unless gnus-show-mime + (set (make-local-variable 'default-mime-charset) + (with-current-buffer gnus-summary-buffer + default-mime-charset)) (decode-mime-charset-region (point-min) (point-max) - (with-current-buffer gnus-summary-buffer - default-mime-charset)))) + default-mime-charset))) ;;; ;;; Gnus MIME viewing functions @@ -3523,9 +3617,14 @@ value of the variable `gnus-show-mime' is non-nil." (defun gnus-article-mime-part-status () (with-current-buffer gnus-article-buffer - (let ((entity (get-text-property (point-min) 'mime-view-entity))) - (if (and entity (mime-entity-children entity)) - (format " (%d parts)" (length (mime-entity-children entity))) + (let ((entity (get-text-property (point-min) 'mime-view-entity)) + children) + (if (and entity + (setq children (mime-entity-children entity)) + (setq children (length children))) + (if (eq 1 children) + " (1 part)" + (format " (%d parts)" children)) "")))) (defvar gnus-mime-button-map @@ -3562,7 +3661,7 @@ value of the variable `gnus-show-mime' is non-nil." (set-buffer gnus-article-buffer) (let ((handles (or handles gnus-article-mime-handles)) (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (with-current-buffer gnus-summary-buffer gnus-newsgroup-ignored-charsets))) (when handles @@ -3577,9 +3676,11 @@ value of the variable `gnus-show-mime' is non-nil." "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 (and data (mm-save-part data))) - param) + (let* ((data (get-text-property (point) 'gnus-data)) + file param) + (if (mm-multiple-handles gnus-article-mime-handles) + (error "This function is not implemented.")) + (setq file (and data (mm-save-part data))) (when file (with-current-buffer (mm-handle-buffer data) (erase-buffer) @@ -3591,17 +3692,17 @@ value of the variable `gnus-show-mime' is non-nil." (insert "Content-Transfer-Encoding: binary\n") (insert "\n")) (setcdr data - (cdr (mm-make-handle nil + (cdr (mm-make-handle nil `("message/external-body" (access-type . "LOCAL-FILE") (name . ,file))))) (set-buffer gnus-summary-buffer) (gnus-article-edit-article - `(lambda () + `(lambda () (erase-buffer) - (let ((mail-parse-charset (or gnus-article-charset + (let ((mail-parse-charset (or gnus-article-charset ',gnus-newsgroup-charset)) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (or gnus-article-ignored-charsets ',gnus-newsgroup-ignored-charsets)) (mbl mml-buffer-list)) @@ -3619,17 +3720,17 @@ value of the variable `gnus-show-mime' is non-nil." ',gnus-newsgroup-charset)) (message-options message-options) (message-options-set-recipient) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (or gnus-article-ignored-charsets ',gnus-newsgroup-ignored-charsets))) (mml-to-mime) (mml-destroy-buffers) - (remove-hook 'kill-buffer-hook + (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-group-read-only-p) ,gnus-summary-buffer no-highlight)))))) (defun gnus-mime-save-part () @@ -3654,6 +3755,9 @@ value of the variable `gnus-show-mime' is non-nil." (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (when data + (setq gnus-article-mime-handles + (mm-merge-handles + gnus-article-mime-handles (setq data (copy-sequence data)))) (mm-interactively-view-part data)))) (defun gnus-mime-view-part-as-type-internal () @@ -3664,34 +3768,38 @@ value of the variable `gnus-show-mime' is non-nil." (def-type (and name (mm-default-file-encoding name)))) (and def-type (cons def-type 0)))) -(defun gnus-mime-view-part-as-type (mime-type) +(defun gnus-mime-view-part-as-type (&optional mime-type) "Choose a MIME media type, and view the part as such." - (interactive - (list (completing-read - "View as MIME type: " - (mapcar #'list (mailcap-mime-types)) - nil nil - (gnus-mime-view-part-as-type-internal)))) + (interactive) + (unless mime-type + (setq mime-type (completing-read + "View as MIME type: " + (mapcar #'list (mailcap-mime-types)) + nil nil + (gnus-mime-view-part-as-type-internal)))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) (when handle - (gnus-mm-display-part - (mm-make-handle (mm-handle-buffer handle) - (cons mime-type (cdr (mm-handle-type handle))) - (mm-handle-encoding handle) - (mm-handle-undisplayer handle) - (mm-handle-disposition handle) - (mm-handle-description handle) - (mm-handle-cache handle) - (mm-handle-id handle)))))) - + (setq handle + (mm-make-handle (mm-handle-buffer handle) + (cons mime-type (cdr (mm-handle-type handle))) + (mm-handle-encoding handle) + (mm-handle-undisplayer handle) + (mm-handle-disposition handle) + (mm-handle-description handle) + (mm-handle-cache handle) + (mm-handle-id handle))) + (setq gnus-article-mime-handles + (mm-merge-handles gnus-article-mime-handles handle)) + (gnus-mm-display-part handle)))) + (defun gnus-mime-copy-part (&optional handle) "Put the the MIME part under point into a new buffer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (contents (and handle (mm-get-part handle))) - (base (and handle + (base (and handle (file-name-nondirectory (or (mail-content-type-get (mm-handle-type handle) 'name) @@ -3731,13 +3839,13 @@ value of the variable `gnus-show-mime' is non-nil." (if (mm-handle-undisplayer handle) (mm-remove-part handle)) (setq charset - (or (cdr (assq arg + (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (read-coding-system "Charset: "))))) (forward-line 2) (mm-insert-inline handle - (if (and charset - (setq charset (mm-charset-to-coding-system + (if (and charset + (setq charset (mm-charset-to-coding-system charset)) (not (eq charset 'ascii))) (mm-decode-coding-string contents charset) @@ -3745,7 +3853,8 @@ value of the variable `gnus-show-mime' is non-nil." (goto-char b))))) (defun gnus-mime-view-part-as-charset (&optional handle arg) - "Insert the MIME part under point into the current buffer." + "Insert the MIME part under point into the current buffer using the +specified charset." (interactive (list nil current-prefix-arg)) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) @@ -3756,7 +3865,7 @@ value of the variable `gnus-show-mime' is non-nil." (if (mm-handle-undisplayer handle) (mm-remove-part handle)) (let ((gnus-newsgroup-charset - (or (cdr (assq arg + (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (read-coding-system "Charset: "))) (gnus-newsgroup-ignored-charsets 'gnus-all)) @@ -3770,7 +3879,7 @@ value of the variable `gnus-show-mime' is non-nil." (mm-user-display-methods nil) (mm-inlined-types nil) (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) (when handle @@ -3780,14 +3889,14 @@ value of the variable `gnus-show-mime' is non-nil." (defun gnus-mime-internalize-part (&optional handle) "View the MIME part under point with an internal viewer. -In no internal viewer is available, use an external viewer." +If no internal viewer is available, use an external viewer." (interactive) (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (mm-inlined-types '(".*")) (mm-inline-large-images t) (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) (when handle @@ -3852,10 +3961,10 @@ In no internal viewer is available, use an external viewer." (if condition (let ((alist gnus-article-mime-handle-alist) ihandle n) (while (setq ihandle (pop alist)) - (if (and (cond + (if (and (cond ((functionp condition) (funcall condition (cdr ihandle))) - ((eq condition 'undisplayed) + ((eq condition 'undisplayed) (not (or (mm-handle-undisplayer (cdr ihandle)) (equal (mm-handle-media-type (cdr ihandle)) "multipart/alternative")))) @@ -3873,7 +3982,7 @@ In no internal viewer is available, use an external viewer." (interactive "P") (save-current-buffer (set-buffer gnus-article-buffer) - (or (numberp n) (setq n (gnus-article-mime-match-handle-first + (or (numberp n) (setq n (gnus-article-mime-match-handle-first gnus-article-mime-match-handle-function))) (when (> n (length gnus-article-mime-handle-alist)) (error "No such part")) @@ -3898,7 +4007,7 @@ In no internal viewer is available, use an external viewer." (prog1 (let ((window (selected-window)) (mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) (save-excursion @@ -3971,7 +4080,7 @@ In no internal viewer is available, use an external viewer." gnus-mime-button-line-format gnus-mime-button-line-format-alist `(keymap ,gnus-mime-button-map ,@(if (>= (string-to-number emacs-version) 21) - nil + nil (list 'local-map gnus-mime-button-map)) gnus-callback gnus-mm-display-part gnus-part ,gnus-tmp-id @@ -4057,6 +4166,8 @@ In no internal viewer is available, use an external viewer." (gnus-treat-article 'head)))))))) (defvar gnus-mime-display-multipart-as-mixed nil) +(defvar gnus-mime-display-multipart-alternative-as-mixed nil) +(defvar gnus-mime-display-multipart-related-as-mixed nil) (defun gnus-mime-display-part (handle) (cond @@ -4069,18 +4180,20 @@ In no internal viewer is available, use an external viewer." handle)) ;; multipart/alternative ((and (equal (car handle) "multipart/alternative") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-alternative-as-mixed))) (let ((id (1+ (length gnus-article-mime-handle-alist)))) (push (cons id handle) gnus-article-mime-handle-alist) (gnus-mime-display-alternative (cdr handle) nil nil id))) ;; multipart/related ((and (equal (car handle) "multipart/related") - (not gnus-mime-display-multipart-as-mixed)) + (not (or gnus-mime-display-multipart-as-mixed + gnus-mime-display-multipart-related-as-mixed))) ;;;!!!We should find the start part, but we just default ;;;!!!to the first part. ;;(gnus-mime-display-part (cadr handle)) ;;;!!! Most multipart/related is an HTML message plus images. - ;;;!!! Unfortunately we are unable to let W3 display those + ;;;!!! Unfortunately we are unable to let W3 display those ;;;!!! included images, so we just display it as a mixed multipart. ;;(gnus-mime-display-mixed (cdr handle)) ;;;!!! No, w3 can display everything just fine. @@ -4136,8 +4249,8 @@ In no internal viewer is available, use an external viewer." ;(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) + (gnus-article-insert-newline) + ;(gnus-article-insert-newline) ;; Remember modify the number of forward lines. (setq move t)) (setq beg (point)) @@ -4147,7 +4260,7 @@ In no internal viewer is available, use an external viewer." (forward-line -1) (setq beg (point))) (let ((mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (condition-case () (set-buffer gnus-summary-buffer) (error)) @@ -4166,7 +4279,7 @@ In no internal viewer is available, use an external viewer." (save-restriction (narrow-to-region beg (point)) (gnus-treat-article - nil id + nil id (gnus-article-mime-total-parts) (mm-handle-media-type handle))))))))) @@ -4264,7 +4377,7 @@ In no internal viewer is available, use an external viewer." (if (stringp (car preferred)) (gnus-display-mime preferred) (let ((mail-parse-charset gnus-newsgroup-charset) - (mail-parse-ignored-charsets + (mail-parse-ignored-charsets (save-excursion (set-buffer gnus-summary-buffer) gnus-newsgroup-ignored-charsets))) (mm-display-part preferred) @@ -4574,10 +4687,16 @@ Argument LINES specifies lines to be scrolled down." (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (elt key 0) unread-command-events) - (setq key (if (featurep 'xemacs) - (events-to-keys (read-key-sequence "Describe key: ")) - (read-key-sequence "Describe key: ")))) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + key)) + (setq key (read-key-sequence "Describe key: ")))) (describe-key key)) (describe-key key))) @@ -4589,10 +4708,16 @@ Argument LINES specifies lines to be scrolled down." (save-excursion (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) - (push (elt key 0) unread-command-events) - (setq key (if (featurep 'xemacs) - (events-to-keys (read-key-sequence "Describe key: ")) - (read-key-sequence "Describe key: ")))) + (if (featurep 'xemacs) + (progn + (push (elt key 0) unread-command-events) + (setq key (events-to-keys + (read-key-sequence "Describe key: ")))) + (setq unread-command-events + (mapcar + (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) + key)) + (setq key (read-key-sequence "Describe key: ")))) (describe-key-briefly key insert)) (describe-key-briefly key insert))) @@ -4708,7 +4833,7 @@ If given a prefix, show the hidden text instead." ((or (stringp article) (numberp article)) (let ((gnus-override-method gnus-override-method) - (methods (and (stringp article) + (methods (and (stringp article) gnus-refer-article-method)) result (buffer-read-only nil)) @@ -4728,7 +4853,7 @@ If given a prefix, show the hidden text instead." (gnus-check-group-server)) (when (gnus-request-article article group (current-buffer)) (when (numberp article) - (gnus-async-prefetch-next group article + (gnus-async-prefetch-next group article gnus-summary-buffer) (when gnus-keep-backlog (gnus-backlog-enter-article @@ -4852,12 +4977,13 @@ groups." (set-buffer gnus-article-buffer) (gnus-article-edit-mode) (funcall start-func) + (set-buffer-modified-p nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) (when gnus-article-edit-article-setup-function (funcall gnus-article-edit-article-setup-function)) - (gnus-message 6 "C-c C-c to end edits"))) + (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit"))) (defun gnus-article-edit-done (&optional arg) "Update the article edits and exit." @@ -4867,7 +4993,20 @@ groups." (start (window-start))) (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) - (gnus-article-edit-exit) + ;; We remove all text props from the article buffer. + (let ((content + (buffer-substring-no-properties (point-min) (point-max))) + (p (point))) + (erase-buffer) + (insert content) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer buf) + (set-window-start (get-buffer-window (current-buffer)) start) + (goto-char p)))) (save-excursion (set-buffer buf) (let ((buffer-read-only nil)) @@ -4891,21 +5030,22 @@ groups." (defun gnus-article-edit-exit () "Exit the article editing without updating." (interactive) - ;; We remove all text props from the article buffer. - (let ((buf (buffer-substring-no-properties (point-min) (point-max))) - (curbuf (current-buffer)) - (p (point)) - (window-start (window-start))) - (erase-buffer) - (insert buf) - (let ((winconf gnus-prev-winconf)) - (gnus-article-mode) - (set-window-configuration winconf) - ;; Tippy-toe some to make sure that point remains where it was. - (save-current-buffer - (set-buffer curbuf) - (set-window-start (get-buffer-window (current-buffer)) window-start) - (goto-char p))))) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Article modified; kill anyway? ")) + (let ((curbuf (current-buffer)) + (p (point)) + (window-start (window-start))) + (erase-buffer) + (if (gnus-buffer-live-p gnus-original-article-buffer) + (insert-buffer gnus-original-article-buffer)) + (let ((winconf gnus-prev-winconf)) + (gnus-article-mode) + (set-window-configuration winconf) + ;; Tippy-toe some to make sure that point remains where it was. + (save-current-buffer + (set-buffer curbuf) + (set-window-start (get-buffer-window (current-buffer)) window-start) + (goto-char p)))))) (defun gnus-article-edit-full-stops () "Interactively repair spacing at end of sentences." @@ -4928,12 +5068,12 @@ groups." (defun gnus-article-mime-edit-article-unwind () "Unwind `gnus-article-buffer' if article editing was given up." (remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) - (when mime-edit-mode-flag - (mime-edit-exit 'nomime 'no-error) - (message "")) (when (featurep 'font-lock) (setq font-lock-defaults nil) - (font-lock-mode 0))) + (font-lock-mode -1)) + (when mime-edit-mode-flag + (mime-edit-exit 'nomime 'no-error) + (message ""))) (defun gnus-article-mime-edit-article-setup () "Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode @@ -4942,7 +5082,8 @@ after replacing with the original article." (setq gnus-article-edit-done-function `(lambda (&rest args) (when mime-edit-mode-flag - (mime-edit-exit) + (let (mime-edit-insert-user-agent-field) + (mime-edit-exit)) (message "")) (goto-char (point-min)) (let (case-fold-search) @@ -4950,53 +5091,79 @@ after replacing with the original article." (format "^%s$" (regexp-quote mail-header-separator)) nil t) (replace-match ""))) - (when (featurep 'font-lock) - (setq font-lock-defaults nil) - (font-lock-mode 0)) (apply ,gnus-article-edit-done-function args) - (set-buffer gnus-original-article-buffer) - (erase-buffer) - (insert-buffer gnus-article-buffer) + (insert + (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer))) (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (set-buffer gnus-article-buffer) (gnus-article-prepare-display))) - (substitute-key-definition - 'gnus-article-edit-exit 'gnus-article-mime-edit-exit - gnus-article-edit-mode-map) + (substitute-key-definition 'gnus-article-edit-done + 'gnus-article-mime-edit-done + gnus-article-edit-mode-map) + (substitute-key-definition 'gnus-article-edit-exit + 'gnus-article-mime-edit-exit + gnus-article-edit-mode-map) (erase-buffer) (insert-buffer gnus-original-article-buffer) - (mime-edit-again) + (let ((ofn (symbol-function 'mime-edit-decode-single-part-in-buffer))) + (fset 'mime-edit-decode-single-part-in-buffer + (lambda (&rest args) + (if (let ((content-type (car args))) + (and (eq 'message (mime-content-type-primary-type + content-type)) + (eq 'rfc822 (mime-content-type-subtype content-type)))) + (setcar (cdr args) 'not-decode-text)) + (apply ofn args))) + (unwind-protect + (mime-edit-again) + (fset 'mime-edit-decode-single-part-in-buffer ofn))) (when (featurep 'font-lock) (set (make-local-variable 'font-lock-defaults) '(message-font-lock-keywords t)) (font-lock-set-defaults) (turn-on-font-lock)) + (set-buffer-modified-p nil) + (delete-other-windows) (add-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind) (gnus-run-hooks 'gnus-article-mime-edit-article-setup-hook)) +(defun gnus-article-mime-edit-done (&optional arg) + "Update the article MIME edits and exit." + (interactive "P") + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode -1)) + (gnus-article-edit-done arg)) + (defun gnus-article-mime-edit-exit () "Exit the article MIME editing without updating." (interactive) - (let ((winconf gnus-prev-winconf) - buf) + (when (or (not (buffer-modified-p)) + (yes-or-no-p "Article modified; kill anyway? ")) + (when (featurep 'font-lock) + (setq font-lock-defaults nil) + (font-lock-mode -1)) (when mime-edit-mode-flag - (mime-edit-exit) + (let (mime-edit-insert-user-agent-field) + (mime-edit-exit)) (message "")) (goto-char (point-min)) (let (case-fold-search) (when (re-search-forward (format "^%s$" (regexp-quote mail-header-separator)) nil t) (replace-match ""))) - (when (featurep 'font-lock) - (setq font-lock-defaults nil) - (font-lock-mode 0)) - ;; We remove all text props from the article buffer. - (setq buf (format "%s" (buffer-string))) - (set-buffer (get-buffer-create gnus-original-article-buffer)) - (erase-buffer) - (insert buf) - (setq gnus-current-headers (gnus-article-make-full-mail-header)) - (gnus-article-prepare-display) - (set-window-configuration winconf))) + (let ((winconf gnus-prev-winconf)) + (insert (prog1 + (buffer-substring-no-properties (point-min) (point-max)) + (set-buffer (get-buffer-create gnus-original-article-buffer)) + (erase-buffer))) + (setq gnus-current-headers (gnus-article-make-full-mail-header)) + (set-buffer gnus-article-buffer) + (gnus-article-prepare-display) + (set-window-configuration winconf)))) ;;; ;;; Article highlights @@ -5012,9 +5179,10 @@ after replacing with the original article." :type 'regexp) (defcustom gnus-button-alist - `(("<\\(url:[>\n\t ]*?\\)?news:[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" - 0 t gnus-button-message-id 2) - ("\\bnews:\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t gnus-button-message-id 1) + `(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>" + 0 t gnus-button-handle-news 3) + ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t + gnus-button-handle-news 2) ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)" 1 t gnus-button-fetch-group 4) @@ -5022,7 +5190,7 @@ after replacing with the original article." ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2 t gnus-button-message-id 3) ("\\( \n\t]+\\)>" 0 t gnus-url-mailto 2) - ("mailto:\\([-a-zA-Z.@_+0-9%]+\\)" 0 t gnus-url-mailto 1) + ("mailto:\\([-a-zA-Z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1) ;; This is how URLs _should_ be embedded in text... ("]*\\)>" 0 t gnus-button-embedded-url 1) @@ -5400,6 +5568,45 @@ specified by `gnus-button-alist'." (gnus-message 1 "You must define `%S' to use this button" (cons fun args))))))) +(defun gnus-parse-news-url (url) + (let (scheme server group message-id articles) + (with-temp-buffer + (insert url) + (goto-char (point-min)) + (when (looking-at "\\([A-Za-z]+\\):") + (setq scheme (match-string 1)) + (goto-char (match-end 0))) + (when (looking-at "//\\([^/]+\\)/") + (setq server (match-string 1)) + (goto-char (match-end 0))) + + (cond + ((looking-at "\\(.*@.*\\)") + (setq message-id (match-string 1))) + ((looking-at "\\([^/]+\\)/\\([-0-9]+\\)") + (setq group (match-string 1) + articles (split-string (match-string 2) "-"))) + ((looking-at "\\([^/]+\\)/?") + (setq group (match-string 1))) + (t + (error "Unknown news URL syntax")))) + (list scheme server group message-id articles))) + +(defun gnus-button-handle-news (url) + "Fetch a news URL." + (destructuring-bind (scheme server group message-id articles) + (gnus-parse-news-url url) + (cond + (message-id + (save-excursion + (set-buffer gnus-summary-buffer) + (if server + (let ((gnus-refer-article-method (list (list 'nntp server)))) + (gnus-summary-refer-article message-id)) + (gnus-summary-refer-article message-id)))) + (group + (gnus-button-fetch-group url))))) + (defun gnus-button-message-id (message-id) "Fetch MESSAGE-ID." (save-excursion @@ -5484,30 +5691,25 @@ forbidden in URL encoding." (setq to (gnus-url-unhex-string url))) (setq args (cons (list "to" to) args) subject (cdr-safe (assoc "subject" args))) - (gnus-setup-message 'reply - (message-mail) - (while args - (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) - (if (fboundp func) - (funcall func) - (message-position-on-field (caar args))) - (insert (mapconcat 'identity (cdar args) ", ")) - (setq args (cdr args))) - (if subject - (message-goto-body) - (message-goto-subject))))) - -(defun gnus-button-mailto (address) - "Mail to ADDRESS." - (set-buffer (gnus-copy-article-buffer)) - (message-reply address)) - -(defalias 'gnus-button-reply 'message-reply) + (gnus-msg-mail) + (while args + (setq func (intern-soft (concat "message-goto-" (downcase (caar args))))) + (if (fboundp func) + (funcall func) + (message-position-on-field (caar args))) + (insert (mapconcat 'identity (cdar args) ", ")) + (setq args (cdr args))) + (if subject + (message-goto-body) + (message-goto-subject)))) (defun gnus-button-embedded-url (address) "Activate ADDRESS with `browse-url'." (browse-url (gnus-strip-whitespace address))) +(eval-when-compile + ;; Silence the byte-compiler. + (autoload 'smiley-toggle-buffer "gnus-bitmap")) (defun gnus-article-smiley-display () "Display \"smileys\" as small graphical icons." (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max))) @@ -5734,11 +5936,11 @@ For example: (defun gnus-article-encrypt-body (protocol &optional n) "Encrypt the article body." - (interactive + (interactive (list (or gnus-article-encrypt-protocol (completing-read "Encrypt protocol: " - gnus-article-encrypt-protocol-alist + gnus-article-encrypt-protocol-alist nil t)) current-prefix-arg)) (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) @@ -5765,7 +5967,7 @@ For example: (let* ((buffer-read-only nil) (headers (mapcar (lambda (field) - (and (save-restriction + (and (save-restriction (message-narrow-to-head) (goto-char (point-min)) (search-forward field nil t)) @@ -5843,7 +6045,7 @@ For example: (mm-remove-parts (cdr handle)) (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region)) buffer-read-only) - (when region + (when region (delete-region (car region) (cdr region)) (set-marker (car region) nil) (set-marker (cdr region) nil))) @@ -5864,7 +6066,7 @@ For example: (if details (if gnus-mime-security-show-details-inline (let ((gnus-mime-security-button-pressed t) - (gnus-mime-security-button-line-format + (gnus-mime-security-button-line-format (get-text-property (point) 'gnus-line-format)) buffer-read-only) (forward-char -1) @@ -5873,9 +6075,9 @@ For example: (forward-char -1)) (forward-char) (delete-region (point) - (or (text-property-not-all + (or (text-property-not-all (point) (point-max) - 'gnus-line-format + 'gnus-line-format gnus-mime-security-button-line-format) (point-max))) (gnus-insert-mime-security-button handle)) @@ -5899,7 +6101,7 @@ For example: (defun gnus-insert-mime-security-button (handle &optional displayed) (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol)) (gnus-tmp-type - (concat + (concat (or (nth 2 (assoc protocol mm-verify-function-alist)) (nth 2 (assoc protocol mm-decrypt-function-alist)) "Unknown") @@ -5916,20 +6118,20 @@ For example: (setq gnus-tmp-details (if gnus-tmp-details (concat "\n" gnus-tmp-details) "")) - (setq gnus-tmp-pressed-details + (setq gnus-tmp-pressed-details (if gnus-mime-security-button-pressed gnus-tmp-details "")) (unless (bolp) (insert "\n")) (setq b (point)) (gnus-eval-format - gnus-mime-security-button-line-format + gnus-mime-security-button-line-format gnus-mime-security-button-line-format-alist `(keymap ,gnus-mime-security-button-map ,@(if (>= (string-to-number emacs-version) 21) nil ;; XEmacs doesn't care (list 'local-map gnus-mime-security-button-map)) gnus-callback gnus-mime-security-press-button - gnus-line-format ,gnus-mime-security-button-line-format + gnus-line-format ,gnus-mime-security-button-line-format article-type annotation gnus-data ,handle)) (setq e (point)) @@ -5955,11 +6157,11 @@ For example: (gnus-mime-display-mixed (cdr handle)) (unless (bolp) (insert "\n")) - (let ((gnus-mime-security-button-line-format + (let ((gnus-mime-security-button-line-format gnus-mime-security-button-end-line-format)) (gnus-insert-mime-security-button handle)) (mm-set-handle-multipart-parameter - handle 'gnus-region + handle 'gnus-region (cons (set-marker (make-marker) (point-min)) (set-marker (make-marker) (point-max))))))