X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;ds=sidebyside;f=lisp%2Fgnus-art.el;h=8f88fa12994ac224094802f92e4113275480a65a;hb=02c1ff49ee866544d2918d446fcc0b3412821c33;hp=584d4410b2f1c571482c6ef892b280a4fb9a0347;hpb=48f45033fe0ec8029918a407c49720af0244cc0e;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 584d441..8f88fa1 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,5 +1,5 @@ ;;; gnus-art.el --- article mode commands for Semi-gnus -;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -28,20 +28,18 @@ ;;; Code: (eval-when-compile (require 'cl)) +(eval-when-compile (require 'static)) -(require 'custom) +(require 'path-util) (require 'gnus) (require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) -(require 'browse-url) (require 'alist) (require 'mime-view) ;; Avoid byte-compile warnings. (eval-when-compile - (defvar gnus-article-decoded-p) - (defvar gnus-article-mime-handles) (require 'mm-bodies) (require 'mail-parse) (require 'mm-decode) @@ -126,11 +124,19 @@ "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:" "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:" "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:" - "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:" - "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:" + "^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:" "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:" - "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" - "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:") + "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:" + "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:" + "^X-FTN" "^X-EXP32-SerialNo:" "^Encoding:" "^Importance:" + "^Autoforwarded:" "^Original-Encoded-Information-Types:" "^X-Ya-Pop3:" + "^X-Face-Version:" "^X-Vms-To:" "^X-ML-NAME:" "^X-ML-COUNT:" + "^Mailing-List:" "^X-finfo:" "^X-md5sum:" "^X-md5sum-Origin:" + "^X-Sun-Charset:" "^X-Accept-Language:" "^X-Envelope-Sender:" + "^List-[A-Za-z]+:" "^X-Listprocessor-Version:" + "^X-Received:" "^X-Distribute:" "^X-Sequence:" "^X-Juno-Line-Breaks:" + "^X-Notes-Item:" "^X-MS-TNEF-Correlator:" "^x-uunet-gateway:" + "^X-Received:" "^Content-length:" "X-precedence:") "*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." @@ -171,8 +177,8 @@ Possible values in this list are `empty', `newsgroups', `followup-to', (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) - (const :tag "Very long To header." long-to) - (const :tag "Multiple To headers." many-to)) + (const :tag "Very long To and/or Cc header." long-to) + (const :tag "Multiple To and/or Cc headers." many-to)) :group 'gnus-article-hiding) (defcustom gnus-signature-separator '("^-- $" "^-- *$") @@ -184,7 +190,7 @@ the end of the buffer." :group 'gnus-article-signature) (defcustom gnus-signature-limit nil - "Provide a limit to what is considered a signature. + "Provide a limit to what is considered a signature. If it is a number, no signature may not be longer (in characters) than that number. If it is a floating point number, no signature may be longer (in lines) than that number. If it is a function, the function @@ -203,11 +209,25 @@ regexp. If it matches, the text in question is not a signature." :group 'gnus-article-hiding) (defcustom gnus-article-x-face-command - "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | xv -quit -" + (cond + ;; Fixme: This isn't the right thing for mixed graphical and and + ;; non-graphical frames in a session. + ((and (fboundp 'image-type-available-p) + (image-type-available-p 'xbm)) + 'gnus-article-display-xface) + ((and (not gnus-xemacs) + window-system + (module-installed-p 'x-face-mule)) + 'x-face-mule-gnus-article-display-x-face) + (t + "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -")) "*String or function to be executed to display an X-Face header. If it is a string, the command will be executed in a sub-shell asynchronously. The compressed face will be piped to this command." - :type 'string ;Leave function case to Lisp. + :type '(choice string + (function-item gnus-article-display-xface) + (function-item x-face-mule-gnus-article-display-x-face) + function) :group 'gnus-article-washing) (defcustom gnus-article-x-face-too-ugly nil @@ -217,7 +237,7 @@ asynchronously. The compressed face will be piped to this command." (defcustom gnus-emphasis-alist (let ((format - "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)") + "\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)") (types '(("_" "_" underline) ("/" "/" italic) @@ -231,7 +251,7 @@ asynchronously. The compressed face will be piped to this command." ,@(mapcar (lambda (spec) (list - (format format (car spec) (cadr spec)) + (format format (car spec) (car (cdr spec))) 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec))))) types))) "*Alist that says how to fontify certain phrases. @@ -251,6 +271,14 @@ is the face used for highlighting." face)) :group 'gnus-article-emphasis) +(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n" + "A regexp to describe whitespace which should not be emphasized. +Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\". +The former avoids underlining of leading and trailing whitespace, +and the latter avoids underlining any whitespace at all." + :group 'gnus-article-emphasis + :type 'regexp) + (defface gnus-emphasis-bold '((t (:bold t))) "Face used for displaying strong emphasized text (*word*)." :group 'gnus-article-emphasis) @@ -268,7 +296,7 @@ is the face used for highlighting." :group 'gnus-article-emphasis) (defface gnus-emphasis-underline-italic '((t (:italic t :underline t))) - "Face used for displaying underlined italic emphasized text (_*word*_)." + "Face used for displaying underlined italic emphasized text (_/word/_)." :group 'gnus-article-emphasis) (defface gnus-emphasis-bold-italic '((t (:bold t :italic t))) @@ -281,6 +309,11 @@ is the face used for highlighting." Esample: (_/*word*/_)." :group 'gnus-article-emphasis) +(defface gnus-emphasis-highlight-words + '((t (:background "black" :foreground "yellow"))) + "Face used for displaying highlighted words." + :group 'gnus-article-emphasis) + (defcustom gnus-article-time-format "%a, %b %d %Y %T %Z" "Format for display of Date headers in article bodies. See `format-time-string' for the possible values. @@ -415,7 +448,7 @@ beginning of a line." :type 'regexp :group 'gnus-article-various) -(defcustom gnus-article-mode-line-format "Gnus: %g %S%m" +(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m" "*The format specification for the article mode line. See `gnus-summary-mode-line-format' for a closer description. @@ -470,8 +503,7 @@ Obsolete; use the face `gnus-signature-face' for customizations instead." :group 'gnus-article-signature) (defface gnus-signature-face - '((((type x)) - (:italic t))) + '((t (:italic t))) "Face used for highlighting a signature in the article buffer." :group 'gnus-article-highlight :group 'gnus-article-signature) @@ -589,9 +621,9 @@ displayed by the first non-nil matching CONTENT face." ("\221" "`") ("\222" "'") ("\223" "``") - ("\224" "''") + ("\224" "\"") ("\225" "*") - ("\226" "-") + ("\226" "---") ("\227" "-") ("\231" "(TM)") ("\233" ">") @@ -605,7 +637,7 @@ displayed by the first non-nil matching CONTENT face." :type '(repeat regexp)) (defcustom gnus-unbuttonized-mime-types '(".*/.*") - "List of MIME types that should not be given buttons when rendered." + "List of MIME types that should not be given buttons when rendered inline." :group 'gnus-article-mime :type '(repeat regexp)) @@ -627,6 +659,22 @@ be added below it (otherwise)." :group 'gnus-article-headers :type 'boolean) +(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 +the function return `t' is used. For `nil', the first part is +used." + :group 'gnus-article-mime + :type '(choice + (item :tag "first" :value nil) + (item :tag "undisplayed" :value undisplayed) + (item :tag "undisplayed or alternative" + :value undisplayed-alternative) + (function))) + ;;; ;;; The treatment variables ;;; @@ -639,7 +687,9 @@ be added below it (otherwise)." (const :tag "On" t) (const :tag "Header" head) (const :tag "Last" last) + (const :tag "Mime" mime) (integer :tag "Less") + (repeat :tag "Groups" regexp) (sexp :tag "Predicate"))) (defvar gnus-article-treat-head-custom @@ -660,7 +710,7 @@ See the manual for details." :type gnus-article-treat-custom) (put 'gnus-treat-highlight-signature 'highlight t) -(defcustom gnus-treat-buttonize t +(defcustom gnus-treat-buttonize 100000 "Add buttons. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -676,7 +726,7 @@ See the manual for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-buttonize-head 'highlight t) -(defcustom gnus-treat-emphasize t +(defcustom gnus-treat-emphasize nil "Emphasize text. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -726,6 +776,13 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) +(defcustom gnus-treat-strip-list-identifiers 'head + "Strip list identifiers from `gnus-list-identifiers`. +Valid values are nil, t, `head', `last', an integer or a predicate. +See the manual for details." + :group 'gnus-article-treat + :type gnus-article-treat-custom) + (defcustom gnus-treat-strip-pgp t "Strip PGP signatures. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -835,13 +892,6 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-strip-blank-lines nil - "Strip all blank lines. -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-overstrike t "Treat overstrike highlighting. Valid values are nil, t, `head', `last', an integer or a predicate. @@ -850,8 +900,12 @@ See the manual for details." :type gnus-article-treat-custom) (put 'gnus-treat-overstrike 'highlight t) -(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface)) - 'head nil) +(defcustom gnus-treat-display-xface + (if (or (and gnus-xemacs (featurep 'xface)) + (eq 'x-face-mule-gnus-article-display-x-face + gnus-article-x-face-command)) + 'head + nil) "Display X-Face headers. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -859,9 +913,13 @@ See the manual for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-display-xface 'highlight t) -(defcustom gnus-treat-display-smileys (if (and gnus-xemacs - (featurep 'xpm)) - t nil) +(defcustom gnus-treat-display-smileys + (if (or (and gnus-xemacs (featurep 'xpm)) + (and (not gnus-xemacs) + window-system + (module-installed-p 'gnus-bitmap))) + t + nil) "Display smileys. Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." @@ -898,36 +956,49 @@ See the manual for details." :group 'gnus-article-treat :type gnus-article-treat-custom) -(defcustom gnus-treat-decode-message-body-as-default-mime-charset nil - "Decode the message body as `default-mime-charset'. -Recommended values are nil or `nomime'. +(defcustom gnus-treat-decode-article-as-default-mime-charset nil + "Decode an article as `default-mime-charset'. For instance, if you want to +attempt to decode an article even if the value of `gnus-show-mime' is nil, +you could set this variable to something like: nil for don't decode, t for +decode the body, '(or header t) for the whole article, etc." + :group 'gnus-article-treat + :type '(radio (const :tag "Off" nil) + (const :tag "Decode body" t) + (const :tag "Decode all" (or head t)))) + +(defcustom gnus-treat-translate nil + "Translate articles from one language to another. +Valid values are nil, t, `head', `last', an integer or a predicate. See the manual for details." :group 'gnus-article-treat - :type '(choice (const :tag "Off" nil) - (const :tag "On" nomime))) + :type gnus-article-treat-custom) ;;; Internal variables (defvar article-goto-body-goes-to-point-min-p nil) (defvar gnus-article-wash-types nil) +(defvar gnus-article-emphasis-alist nil) (defvar gnus-article-mime-handle-alist-1 nil) (defvar gnus-treatment-function-alist - '((gnus-treat-strip-banner gnus-article-strip-banner) + '((gnus-treat-decode-article-as-default-mime-charset + gnus-article-decode-article-as-default-mime-charset) + (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-long-lines) (gnus-treat-strip-cr gnus-article-remove-cr) - (gnus-treat-emphasize gnus-article-emphasize) + (gnus-treat-display-xface gnus-article-display-x-face) (gnus-treat-hide-headers gnus-article-maybe-hide-headers) (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers) (gnus-treat-hide-signature gnus-article-hide-signature) (gnus-treat-hide-citation gnus-article-hide-citation) + (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) (gnus-treat-strip-pgp gnus-article-hide-pgp) (gnus-treat-strip-pem gnus-article-hide-pem) (gnus-treat-highlight-headers gnus-article-highlight-headers) + (gnus-treat-emphasize gnus-article-emphasize) (gnus-treat-highlight-citation gnus-article-highlight-citation) (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-date-ut gnus-article-date-ut) @@ -942,15 +1013,12 @@ See the manual for details." gnus-article-strip-leading-blank-lines) (gnus-treat-strip-multiple-blank-lines gnus-article-strip-multiple-blank-lines) - (gnus-treat-strip-blank-lines gnus-article-strip-blank-lines) (gnus-treat-overstrike gnus-article-treat-overstrike) (gnus-treat-buttonize-head gnus-article-add-buttons-to-head) - (gnus-treat-display-xface gnus-article-display-x-face) - (gnus-treat-display-smileys gnus-smiley-display) + (gnus-treat-display-smileys 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) - (gnus-treat-decode-message-body-as-default-mime-charset - gnus-article-decode-message-body-as-default-mime-charset))) + (gnus-treat-play-sounds gnus-earcon-display))) (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) @@ -1052,8 +1120,8 @@ Initialized from `text-mode-syntax-table.") (interactive (gnus-article-hidden-arg)) ;; Lars said that this function might be inhibited. (if (gnus-article-check-hidden-text 'headers arg) - ;; Show boring headers as well. (progn + ;; Show boring headers as well. (gnus-article-show-hidden-text 'boring-headers) (when (eq 1 (point-min)) (set-window-start (get-buffer-window (current-buffer)) 1))) @@ -1061,6 +1129,7 @@ Initialized from `text-mode-syntax-table.") (save-excursion (save-restriction (let ((buffer-read-only nil) + (inhibit-read-only t) (case-fold-search t) (max (1+ (length gnus-sorted-header-list))) (ignored (when (not gnus-visible-headers) @@ -1108,6 +1177,7 @@ Initialized from `text-mode-syntax-table.") (when (setq beg (text-property-any (point-min) (point-max) 'message-rank (+ 2 max))) ;; We delete or make invisible the unwanted headers. + (push 'headers gnus-article-wash-types) (if delete (progn (add-text-properties @@ -1176,11 +1246,15 @@ always hide." 4)) (gnus-article-hide-header "date")))) ((eq elem 'long-to) - (let ((to (message-fetch-field "to"))) + (let ((to (message-fetch-field "to")) + (cc (message-fetch-field "cc"))) (when (> (length to) 1024) - (gnus-article-hide-header "to")))) + (gnus-article-hide-header "to")) + (when (> (length cc) 1024) + (gnus-article-hide-header "cc")))) ((eq elem 'many-to) - (let ((to-count 0)) + (let ((to-count 0) + (cc-count 0)) (goto-char (point-min)) (while (re-search-forward "^to:" nil t) (setq to-count (1+ to-count))) @@ -1192,7 +1266,19 @@ always hide." (forward-line -1) (narrow-to-region (point) (point-max)) (gnus-article-hide-header "to")) - (setq to-count (1- to-count))))))))))))) + (setq to-count (1- to-count)))) + (goto-char (point-min)) + (while (re-search-forward "^cc:" nil t) + (setq cc-count (1+ cc-count))) + (when (> cc-count 1) + (while (> cc-count 0) + (goto-char (point-min)) + (save-restriction + (re-search-forward "^cc:" nil nil cc-count) + (forward-line -1) + (narrow-to-region (point) (point-max)) + (gnus-article-hide-header "cc")) + (setq cc-count (1- cc-count))))))))))))) (defun gnus-article-hide-header (header) (save-excursion @@ -1207,6 +1293,87 @@ always hide." (point-max))) 'boring-headers)))) +(defun article-toggle-headers (&optional arg) + "Toggle hiding of headers. If given a negative prefix, always show; +if given a positive prefix, always hide." + (interactive (gnus-article-hidden-arg)) + (let ((force (when (numberp arg) + (cond ((> arg 0) 'always-hide) + ((< arg 0) 'always-show)))) + (window (get-buffer-window gnus-article-buffer)) + (header-end (point-min)) + header-start field-end field-start + (inhibit-point-motion-hooks t) + (inhibit-read-only t) + buffer-read-only) + (save-restriction + (widen) + (while (and (setq header-start + (text-property-any header-end (point-max) + 'article-treated-header t)) + (setq header-end + (text-property-not-all header-start (point-max) + 'article-treated-header t))) + (setq field-end header-start) + (cond + (;; Hide exposed invisible fields. + (and (not (eq 'always-show force)) + (setq field-start + (text-property-any field-end header-end + 'exposed-invisible-field t))) + (while (and field-start + (setq field-end (text-property-not-all + field-start header-end + 'exposed-invisible-field t))) + (add-text-properties field-start field-end gnus-hidden-properties) + (setq field-start (text-property-any field-end header-end + 'exposed-invisible-field t))) + (put-text-property header-start header-end + 'exposed-invisible-field nil)) + (;; Expose invisible fields. + (and (not (eq 'always-hide force)) + (setq field-start + (text-property-any field-end header-end 'invisible t))) + (while (and field-start + (setq field-end (text-property-not-all + field-start header-end + 'invisible t))) + ;; If the invisible text is not terminated with newline, we + ;; won't expose it. Because it may be created by x-face-mule. + ;; BTW, XEmacs sometimes fail in putting a invisible text + ;; property with `gnus-article-hide-text' (really?). In that + ;; case, the invisible text might be started from the middle of + ;; a line so we will expose the sort of thing. + (when (or (not (or (eq header-start field-start) + (eq ?\n (char-before field-start)))) + (eq ?\n (char-before field-end))) + (remove-text-properties field-start field-end + gnus-hidden-properties) + (put-text-property field-start field-end + 'exposed-invisible-field t)) + (setq field-start (text-property-any field-end header-end + 'invisible t)))) + (;; Hide fields. + (not (eq 'always-show force)) + (narrow-to-region header-start header-end) + (article-hide-headers) + ;; Re-display X-Face image under XEmacs. + (when (and gnus-xemacs + (gnus-functionp gnus-article-x-face-command)) + (let ((func (cadr (assq 'gnus-treat-display-xface + gnus-treatment-function-alist))) + (condition 'head)) + (when (and (not gnus-inhibit-treatment) + func + (gnus-treat-predicate gnus-treat-display-xface)) + (funcall func) + (put-text-property header-start header-end 'read-only nil)))) + (widen)) + )) + (goto-char (point-min)) + (when window + (set-window-start window (point-min)))))) + (defvar gnus-article-normalized-header-length 40 "Length of normalized headers.") @@ -1282,23 +1449,29 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (let ((buffer-read-only nil)) (while (search-forward "\b" nil t) (let ((next (char-after)) - (previous (char-after (- (point) 2)))) + start end previous) + (backward-char 2) + (setq start (point) + previous (char-after)) + (forward-char 3) + (setq end (point)) + (backward-char) ;; We do the boldification/underlining by hiding the ;; overstrikes and putting the proper text property ;; on the letters. (cond ((eq next previous) - (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) - (put-text-property (point) (1+ (point)) 'face 'bold)) + (gnus-article-hide-text-type start (point) 'overstrike) + (put-text-property (point) end 'face 'bold)) ((eq next ?_) (gnus-article-hide-text-type (1- (point)) (1+ (point)) 'overstrike) (put-text-property - (- (point) 2) (1- (point)) 'face 'underline)) + start (1- (point)) 'face 'underline)) ((eq previous ?_) - (gnus-article-hide-text-type (- (point) 2) (point) 'overstrike) + (gnus-article-hide-text-type start (point) 'overstrike) (put-text-property - (point) (1+ (point)) 'face 'underline))))))))) + (point) end 'face 'underline))))))))) (defun article-fill-long-lines () "Fill lines that are wider than the window width." @@ -1382,7 +1555,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: " 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 @@ -1416,42 +1589,57 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (set-buffer gnus-article-buffer) (let ((inhibit-point-motion-hooks t) buffer-read-only - (mail-parse-charset gnus-newsgroup-charset)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (mail-decode-encoded-word-region (point-min) (point-max))))) (defun article-decode-charset (&optional prompt) "Decode charset-encoded text in the article. If PROMPT (the prefix), prompt for a coding system to use." (interactive "P") + (let ((inhibit-point-motion-hooks t) (case-fold-search t) + buffer-read-only + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case nil + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets)) + ct cte ctl charset format) (save-excursion (save-restriction (article-narrow-to-head) - (let* ((inhibit-point-motion-hooks t) - (case-fold-search t) - (ct (message-fetch-field "Content-Type" t)) - (cte (message-fetch-field "Content-Transfer-Encoding" t)) - (ctl (and ct (ignore-errors - (mail-header-parse-content-type ct)))) - (charset (cond - (prompt - (mm-read-coding-system "Charset to decode: ")) - (ctl - (mail-content-type-get ctl 'charset)))) - (mail-parse-charset gnus-newsgroup-charset) - buffer-read-only) - (when (memq charset gnus-newsgroup-ignored-charsets) - (setq charset nil)) - (goto-char (point-max)) - (widen) - (forward-line 1) - (narrow-to-region (point) (point-max)) - (when (and (or (not ctl) - (equal (car ctl) "text/plain")) - (not (mm-uu-test))) - (mm-decode-body - charset (and cte (intern (downcase - (gnus-strip-whitespace cte)))) - (car ctl))))))) + (setq ct (message-fetch-field "Content-Type" t) + cte (message-fetch-field "Content-Transfer-Encoding" t) + ctl (and ct (ignore-errors + (mail-header-parse-content-type ct))) + charset (cond + (prompt + (mm-read-coding-system "Charset to decode: ")) + (ctl + (mail-content-type-get ctl 'charset))) + 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)))) + (setq ctl nil)) + (goto-char (point-max))) + (forward-line 1) + (save-restriction + (narrow-to-region (point) (point-max)) + (when (and (eq mail-parse-charset 'gnus-decoded) + (eq (mm-body-7-or-8) '8bit)) + ;; The text code could have been decoded. + (setq charset mail-parse-charset)) + (when (and (or (not ctl) + (equal (car ctl) "text/plain")) + (not format)) ;; article with format will decode later. + (mm-decode-body + charset (and cte (intern (downcase + (gnus-strip-whitespace cte)))) + (car ctl))))))) (defun article-decode-encoded-words () "Remove encoded-word encoding from headers." @@ -1474,11 +1662,75 @@ or not." (when (or force (and type (string-match "quoted-printable" (downcase type)))) (article-goto-body) + (quoted-printable-decode-region (point) (point-max) charset))))) + +(defun article-de-base64-unreadable (&optional force) + "Translate a base64 article. +If FORCE, decode the article whether it is marked as base64 not." + (interactive (list 'force)) + (save-excursion + (let ((buffer-read-only nil) + (type (gnus-fetch-field "content-transfer-encoding")) + (charset gnus-newsgroup-charset)) + (when (or force + (and type (string-match "quoted-printable" (downcase type)))) + (article-goto-body) + (save-restriction + (narrow-to-region (point) (point-max)) + (base64-decode-region (point-min) (point-max)) + (if (mm-coding-system-p charset) + (mm-decode-coding-region (point-min) (point-max) charset))))))) + +(eval-when-compile + (require 'rfc1843)) + +(defun article-decode-HZ () + "Translate a HZ-encoded article." + (interactive) + (require 'rfc1843) + (save-excursion + (let ((buffer-read-only nil)) + (rfc1843-decode-region (point-min) (point-max))))) + +(defun article-wash-html () + "Format an html article." + (interactive) + (save-excursion + (let ((buffer-read-only nil) + (charset gnus-newsgroup-charset)) + (article-goto-body) + (save-window-excursion (save-restriction (narrow-to-region (point) (point-max)) - (quoted-printable-decode-region (point-min) (point-max)) - (when charset - (mm-decode-body charset))))))) + (mm-setup-w3) + (let ((w3-strict-width (window-width)) + (url-standalone-mode t)) + (condition-case var + (w3-region (point-min) (point-max)) + (error)))))))) + +(defun article-hide-list-identifiers () + "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)))))))))) (defun article-hide-pgp () "Remove any PGP headers and signatures in the current article." @@ -1492,9 +1744,9 @@ or not." (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t) (push 'pgp gnus-article-wash-types) (delete-region (match-beginning 0) (match-end 0)) - ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too - (when (looking-at "Hash:.*$") - (delete-region (point) (1+ (gnus-point-at-eol)))) + ;; Remove armor headers (rfc2440 6.2) + (delete-region (point) (or (re-search-forward "^[ \t]*\n" nil t) + (point))) (setq beg (point)) ;; Hide the actual signature. (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t) @@ -1564,18 +1816,50 @@ always hide." (while (re-search-forward banner nil t) (delete-region (match-beginning 0) (match-end 0)))))))))) +(defun article-babel () + "Translate article using an online translation service." + (interactive) + (require 'babel) + (save-excursion + (set-buffer gnus-article-buffer) + (when (article-goto-body) + (let* ((buffer-read-only nil) + (start (point)) + (end (point-max)) + (orig (buffer-substring start end)) + (trans (babel-as-string orig))) + (save-restriction + (narrow-to-region start end) + (delete-region start end) + (insert trans)))))) + (defun article-hide-signature (&optional arg) "Hide the signature in the current article. If given a negative prefix, always show; if given a positive prefix, always hide." (interactive (gnus-article-hidden-arg)) - (unless (gnus-article-check-hidden-text 'signature arg) - (save-excursion - (save-restriction - (let ((buffer-read-only nil)) - (when (gnus-article-narrow-to-signature) - (gnus-article-hide-text-type - (point-min) (point-max) 'signature))))))) + (save-excursion + (save-restriction + (if (interactive-p) + (progn + (widen) + (article-goto-body)) + (goto-char (point-min))) + (unless (gnus-article-check-hidden-text 'signature arg) + (let ((buffer-read-only nil) + (button (point))) + (while (setq button (text-property-any button (point-max) + 'gnus-callback + 'gnus-signature-toggle)) + (setq button (text-property-not-all button (point-max) + 'gnus-callback + 'gnus-signature-toggle)) + (when (and button (not (eobp))) + (gnus-article-hide-text-type + (1+ button) + (next-single-property-change (1+ button) 'mime-view-entity + nil (point-max)) + 'signature)))))))) (defun article-strip-headers-in-body () "Strip offensive headers from bodies." @@ -1786,14 +2070,15 @@ If HIDE, hide the text instead." (defun article-date-ut (&optional type highlight header) "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 +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." (interactive (list 'ut t)) (let* ((header (or header - (mail-header-date (save-excursion - (set-buffer gnus-summary-buffer) - gnus-current-headers)) + (and (eq 1 (point-min)) + (mail-header-date (save-excursion + (set-buffer gnus-summary-buffer) + gnus-current-headers))) (message-fetch-field "date") "")) (date (if (vectorp header) (mail-header-date header) @@ -1812,13 +2097,16 @@ should replace the \"Date:\" one, or should be added below it." ;; If Date is missing, try again for X-Sent. (re-search-forward "^X-Sent:[ \t]" nil t)) (setq bface (get-text-property (gnus-point-at-bol) 'face) + date (or (get-text-property (gnus-point-at-bol) + 'original-date) + date) eface (get-text-property (1- (gnus-point-at-eol)) 'face))) (let ((buffer-read-only nil)) ;; Delete any old X-Sent headers. (when (setq date-pos - (next-single-property-change (point-min) - 'article-date-lapsed)) + (text-property-any (point-min) (point-max) + 'article-date-lapsed t)) (goto-char (setq date-pos (set-marker (make-marker) date-pos))) (delete-region (match-beginning 0) (progn (forward-line 1) (point)))) @@ -1851,6 +2139,8 @@ should replace the \"Date:\" one, or should be added below it." ;; Do highlighting. (when (looking-at "\\([^:]+\\): *\\(.*\\)$") (put-text-property (match-beginning 1) (1+ (match-end 1)) + 'original-date date) + (put-text-property (match-beginning 1) (1+ (match-end 1)) 'face bface) (put-text-property (match-beginning 2) (match-end 2) 'face eface)))))))) @@ -1866,17 +2156,18 @@ should replace the \"Date:\" one, or should be added below it." ;; functions since they aren't particularly resistant to ;; buggy dates. ((eq type 'local) - (let ((tz (car (current-time-zone)))) - (format "Date: %s %s%04d" (current-time-string time) - (if (> tz 0) "+" "-") (abs (/ tz 36))))) + (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))))) + (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))))) @@ -1895,9 +2186,13 @@ should replace the \"Date:\" one, or should be added below it." (format-time-string gnus-article-time-format time)))) ;; ISO 8601. ((eq type 'iso8601) - (concat - "Date: " - (format-time-string "%Y%m%dT%H%M%S" time))) + (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 @@ -2008,15 +2303,33 @@ This format is defined by the `gnus-article-time-format' variable." "Show all hidden text in the article buffer." (interactive) (save-excursion + (widen) (let ((buffer-read-only nil)) - (gnus-article-unhide-text (point-min) (point-max))))) + (gnus-article-unhide-text (point-min) (point-max)) + (gnus-remove-text-with-property 'gnus-prev) + (gnus-remove-text-with-property 'gnus-next)))) + +(defun article-show-all-headers () + "Show all hidden headers in the article buffer." + (interactive) + (save-excursion + (save-restriction + (widen) + (article-narrow-to-head) + (let ((buffer-read-only nil)) + (gnus-article-unhide-text (point-min) (point-max)))))) (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 gnus-emphasis-alist) + (let ((alist (or + (condition-case nil + (with-current-buffer gnus-summary-buffer + gnus-article-emphasis-alist) + (error)) + gnus-emphasis-alist)) (buffer-read-only nil) (props (append '(article-type emphasis) gnus-hidden-properties)) @@ -2031,6 +2344,7 @@ This format is defined by the `gnus-article-time-format' variable." face (nth 3 elem)) (while (re-search-forward regexp nil t) (when (and (match-beginning visible) (match-beginning invisible)) + (push 'emphasis gnus-article-wash-types) (gnus-article-hide-text (match-beginning invisible) (match-end invisible) props) (gnus-article-unhide-text-type @@ -2039,6 +2353,26 @@ This format is defined by the `gnus-article-time-format' variable." (match-beginning visible) (match-end visible) 'face face) (goto-char (match-end invisible))))))))) +(defun gnus-article-setup-highlight-words (&optional highlight-words) + "Setup newsgroup emphasis alist." + (unless gnus-article-emphasis-alist + (let ((name (and gnus-newsgroup-name + (gnus-group-real-name gnus-newsgroup-name)))) + (make-local-variable 'gnus-article-emphasis-alist) + (setq gnus-article-emphasis-alist + (nconc + (let ((alist gnus-group-highlight-words-alist) elem highlight) + (while (setq elem (pop alist)) + (when (and name (string-match (car elem) name)) + (setq alist nil + highlight (copy-sequence (cdr elem))))) + highlight) + (copy-sequence highlight-words) + (if gnus-newsgroup-name + (copy-sequence (gnus-group-find-parameter + gnus-newsgroup-name 'highlight-words t))) + gnus-emphasis-alist))))) + (defvar gnus-summary-article-menu) (defvar gnus-summary-post-menu) @@ -2336,27 +2670,32 @@ If variable `gnus-use-long-file-name' is non-nil, it is gfunc (cdr func)) (setq afunc func gfunc (intern (format "gnus-%s" func)))) - (fset gfunc - (if (not (fboundp afunc)) - nil - `(lambda (&optional interactive &rest args) - ,(documentation afunc t) - (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) - (if interactive - (call-interactively ',afunc) - (apply ',afunc args)))))))) + (defalias gfunc + (if (fboundp afunc) + `(lambda (&optional interactive &rest args) + ,(documentation afunc t) + (interactive (list t)) + (save-excursion + (set-buffer gnus-article-buffer) + (if interactive + (call-interactively ',afunc) + (apply ',afunc args)))))))) '(article-hide-headers article-hide-boring-headers + article-toggle-headers article-treat-overstrike article-fill-long-lines article-capitalize-sentences article-remove-cr article-display-x-face article-de-quoted-unreadable + article-de-base64-unreadable + article-decode-HZ + article-wash-html + article-hide-list-identifiers article-hide-pgp article-strip-banner + article-babel article-hide-pem article-hide-signature article-strip-headers-in-body @@ -2379,7 +2718,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is article-emphasize article-treat-dumbquotes article-normalize-headers - (article-show-all . gnus-article-show-all-headers)))) + (article-show-all-headers . gnus-article-show-all-headers) + (article-show-all . gnus-article-show-all)))) ;;; ;;; Gnus article mode @@ -2397,11 +2737,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "s" gnus-article-show-summary "\C-c\C-m" gnus-article-mail "?" gnus-article-describe-briefly - gnus-mouse-2 gnus-article-push-button - "\r" gnus-article-press-button - "\t" gnus-article-next-button - "\M-\t" gnus-article-prev-button - "e" gnus-article-edit + "e" gnus-summary-edit-article "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-i" gnus-info-find-node @@ -2452,11 +2788,12 @@ If variable `gnus-use-long-file-name' is non-nil, it is (easy-menu-define gnus-article-treatment-menu gnus-article-mode-map "" '("Treatment" - ["Hide headers" gnus-article-hide-headers t] + ["Hide headers" gnus-article-toggle-headers t] ["Hide signature" gnus-article-hide-signature t] ["Hide citation" gnus-article-hide-citation t] ["Treat overstrike" gnus-article-treat-overstrike t] - ["Remove carriage return" gnus-article-remove-cr t])) + ["Remove carriage return" gnus-article-remove-cr t] + ["Decode HZ" gnus-article-decode-HZ t])) ;; Note "Commands" menu is defined in gnus-sum.el for consistency @@ -2499,7 +2836,7 @@ commands: (make-local-variable 'gnus-article-mime-handles) (make-local-variable 'gnus-article-decoded-p) (make-local-variable 'gnus-article-mime-handle-alist) - (make-local-variable 'gnus-article-washed-types) + (make-local-variable 'gnus-article-wash-types) (gnus-set-default-directory) (buffer-disable-undo) (setq buffer-read-only t) @@ -2524,6 +2861,7 @@ commands: (setq gnus-article-buffer name) (setq gnus-original-article-buffer original) (gnus-set-global-variables))) + (gnus-article-setup-highlight-words) ;; Init original article buffer. (save-excursion (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) @@ -2663,8 +3001,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (message "Message marked for downloading")) (gnus-summary-mark-article article gnus-canceled-mark) (unless (memq article gnus-newsgroup-sparse) - (gnus-error 1 - "No such article (may have expired or been canceled)"))))) + (gnus-error 1 "No such article (may have expired or been canceled)"))))) (if (or (eq result 'pseudo) (eq result 'nneething)) (progn @@ -2736,98 +3073,119 @@ If ALL-HEADERS is non-nil, no headers are hidden." (goto-char (point-min)) (when (re-search-forward "^[^\t ]+:" nil t) (goto-char (match-beginning 0))) - (save-restriction - (narrow-to-region (point) - (if (search-forward "\n\n" nil t) - (point) - (point-max))) - (gnus-treat-article 'head) - (goto-char (point-max))) - (let* ((start (point)) - (root-entity (unless number - (get-text-property (point-min) 'mime-view-entity))) - (entity (if (and root-entity - (eq 'multipart - (mime-content-type-primary-type - (mime-entity-content-type root-entity)))) - (get-text-property start 'mime-view-entity) - root-entity)) - (number (or number 0)) - content-type treat-type) - (while (and (not (eobp)) - (progn (mime-preview-move-to-next) - (> (point) start))) - (if entity + (let ((entity (if (eq 1 (point-min)) + (get-text-property 1 'mime-view-entity) + (get-text-property (point) 'mime-view-entity))) + last-entity child-entity next type) + (setq child-entity (mime-entity-children entity)) + (if child-entity + (setq last-entity (nth (1- (length child-entity)) + child-entity)) + (setq last-entity entity)) + (save-restriction + (narrow-to-region (point) + (if (search-forward "\n\n" nil t) + (point) + (point-max))) + (gnus-treat-article 'head) + (put-text-property (point-min) (point-max) 'article-treated-header t) + (goto-char (point-max))) + (while (and (not (eobp)) entity) + (setq next (set-marker + (make-marker) + (next-single-property-change (point) 'mime-view-entity + nil (point-max)))) + (let ((types (mime-entity-content-type entity))) + (while (eq 'multipart (mime-content-type-primary-type types)) + (setq entity (car (mime-entity-children entity)) + types (mime-entity-content-type entity))) + (when types + (setq type (format "%s/%s" + (mime-content-type-primary-type types) + (mime-content-type-subtype types))))) + (if (string-equal type "message/rfc822") (progn - (setq content-type (mime-entity-content-type entity) - treat-type (format "%s/%s" - (mime-content-type-primary-type - content-type) - (mime-content-type-subtype - content-type))) - (if (string-equal treat-type "message/rfc822") - (save-restriction - (narrow-to-region start (point-max)) - (gnus-article-prepare-mime-display number) - (goto-char (point-max))) - (save-restriction - (narrow-to-region start (point)) - (setq start (point) - entity (get-text-property start 'mime-view-entity)) - (gnus-treat-article nil (incf number) nil treat-type)))) - (setq start (point) - entity (get-text-property start 'mime-view-entity)))) - (unless (eobp) - (save-restriction - (narrow-to-region (point) (point-max)) - (if entity - (progn - (setq content-type (mime-entity-content-type entity) - treat-type (format "%s/%s" - (mime-content-type-primary-type - content-type) - (mime-content-type-subtype - content-type))) - (if (string-equal treat-type "message/rfc822") - (gnus-article-prepare-mime-display number) - (incf number) - (gnus-treat-article 'last number number treat-type))) - (gnus-treat-article t)))))) + (setq next (point)) + (let ((children (mime-entity-children entity)) + last-children) + (when children + (setq last-children (nth (1- (length children)) children)) + (while + (and + (not (eq last-children + (get-text-property next 'mime-view-entity))) + (setq next + (next-single-property-change next + 'mime-view-entity + nil (point-max))))))) + (setq next (next-single-property-change next 'mime-view-entity + nil (point-max))) + (save-restriction + (narrow-to-region (point) next) + (gnus-article-prepare-mime-display) + (goto-char (point-max))) + (setq entity (get-text-property (point) 'mime-view-entity))) + (save-restriction + (narrow-to-region (point) next) + ;; Kludge. We have to count true number, but for now, + ;; part number is here only to achieve `last'. + (gnus-treat-article nil 1 + (if (eq entity last-entity) + 1 2) + type) + (goto-char (point-max))) + (setq entity (get-text-property next 'mime-view-entity)))))) ;;;###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) ;; Display message. - (let (mime-display-header-hook) + (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) ;; Call the treatment functions. - (save-restriction - (widen) - (if gnus-show-mime - (let (mime-preview-over-to-next-method-alist) - (gnus-article-prepare-mime-display)) - (std11-narrow-to-header) - (gnus-treat-article 'head) - (goto-char (point-max)) + (let ((inhibit-read-only t) + buffer-read-only) + (save-restriction (widen) - (narrow-to-region (point) (point-max)) - (gnus-treat-article t))) + (if gnus-show-mime + (gnus-article-prepare-mime-display) + (narrow-to-region (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (point) + (point-max))) + (gnus-treat-article 'head) + (put-text-property (point-min) (point-max) 'article-treated-header t) + (goto-char (point-max)) + (widen) + (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)) -(defun gnus-article-decode-message-body-as-default-mime-charset () - "Decode the message body as `default-mime-charset'." - (let (buffer-read-only) - (decode-mime-charset-region (point) (point-max) +(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 + (decode-mime-charset-region (point-min) (point-max) (with-current-buffer gnus-summary-buffer default-mime-charset)))) @@ -2855,19 +3213,22 @@ If ALL-HEADERS is non-nil, no headers are hidden." (?e gnus-tmp-dots ?s))) (defvar gnus-mime-button-commands - '((gnus-article-press-button "\r" "Toggle Display") - (gnus-mime-view-part "v" "View Interactively...") - (gnus-mime-save-part "o" "Save...") - (gnus-mime-copy-part "c" "View As Text, In Other Buffer") - (gnus-mime-inline-part "i" "View As Text, In This Buffer") - (gnus-mime-internalize-part "E" "View Internally") - (gnus-mime-externalize-part "e" "View Externally") - (gnus-mime-pipe-part "|" "Pipe To Command..."))) + '((gnus-article-press-button "\r" "Toggle Display") + (gnus-mime-view-part "v" "View Interactively...") + (gnus-mime-view-part-as-type "t" "View As Type...") + (gnus-mime-save-part "o" "Save...") + (gnus-mime-copy-part "c" "View As Text, In Other Buffer") + (gnus-mime-inline-part "i" "View As Text, In This Buffer") + (gnus-mime-internalize-part "E" "View Internally") + (gnus-mime-externalize-part "e" "View Externally") + (gnus-mime-pipe-part "|" "Pipe To Command..."))) (defun gnus-article-mime-part-status () - (if gnus-article-mime-handle-alist-1 - (format " (%d parts)" (length gnus-article-mime-handle-alist-1)) - "")) + (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))) + "")))) (defvar gnus-mime-button-map nil) (unless gnus-mime-button-map @@ -2893,7 +3254,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (cons (caddr c) (car c))) gnus-mime-button-commands)))))) (if response - (funcall response)))))) + (call-interactively response)))))) (defun gnus-mime-view-all-parts (&optional handles) "View all the MIME parts." @@ -2901,7 +3262,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." (save-current-buffer (set-buffer gnus-article-buffer) (let ((handles (or handles gnus-article-mime-handles)) - (mail-parse-charset gnus-newsgroup-charset)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (if (stringp (car handles)) (gnus-mime-view-all-parts (cdr handles)) (mapcar 'mm-display-part handles))))) @@ -2921,12 +3285,40 @@ If ALL-HEADERS is non-nil, no headers are hidden." (mm-pipe-part data))) (defun gnus-mime-view-part () - "Interactively choose a view method for the MIME part under point." + "Interactively choose a viewing method for the MIME part under point." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (mm-interactively-view-part data))) +(defun gnus-mime-view-part-as-type-internal () + (gnus-article-check-buffer) + (let* ((name (mail-content-type-get + (mm-handle-type (get-text-property (point) 'gnus-data)) + 'name)) + (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) + "Choose a MIME media type, and view the part as such." + (interactive + (list (completing-read + "View as MIME type: " + (mapcar (lambda (i) (list i i)) (mailcap-mime-types)) + nil nil + (gnus-mime-view-part-as-type-internal)))) + (gnus-article-check-buffer) + (let ((handle (get-text-property (point) 'gnus-data))) + (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))))) + (defun gnus-mime-copy-part (&optional handle) "Put the the MIME part under point into a new buffer." (interactive) @@ -2971,20 +3363,27 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-article-check-buffer) (let* ((handle (or handle (get-text-property (point) 'gnus-data))) (mm-user-display-methods nil) - (mm-all-images-fit t) - (mail-parse-charset gnus-newsgroup-charset)) + (mm-inlined-types nil) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (if (mm-handle-undisplayer handle) (mm-remove-part handle) (mm-display-part handle)))) (defun gnus-mime-internalize-part (&optional handle) - "View the MIME part under point with an internal viewer." + "View the MIME part under point with an internal viewer. +In 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-user-display-methods '((".*" . inline))) - (mm-all-images-fit t) - (mail-parse-charset gnus-newsgroup-charset)) + (mm-inlined-types '(".*")) + (mm-inline-large-images t) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (if (mm-handle-undisplayer handle) (mm-remove-part handle) (mm-display-part handle)))) @@ -2994,6 +3393,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (set-buffer gnus-article-buffer) (when (> n (length gnus-article-mime-handle-alist)) (error "No such part")) + (gnus-article-goto-part n) (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) (funcall function handle)))) @@ -3027,11 +3427,33 @@ If ALL-HEADERS is non-nil, no headers are hidden." (interactive "p") (gnus-article-part-wrapper n 'gnus-mime-inline-part)) -(defun gnus-article-view-part (n) +(defun gnus-article-mime-match-handle-first (condition) + (if condition + (let ((alist gnus-article-mime-handle-alist) ihandle n) + (while (setq ihandle (pop alist)) + (if (and (cond + ((functionp condition) + (funcall condition (cdr ihandle))) + ((eq condition 'undisplayed) + (not (or (mm-handle-undisplayer (cdr ihandle)) + (equal (mm-handle-media-type (cdr ihandle)) + "multipart/alternative")))) + ((eq condition 'undisplayed-alternative) + (not (mm-handle-undisplayer (cdr ihandle)))) + (t t)) + (gnus-article-goto-part (car ihandle)) + (or (not n) (< (car ihandle) n))) + (setq n (car ihandle)))) + (or n 1)) + 1)) + +(defun gnus-article-view-part (&optional n) "View MIME part N, which is the numerical prefix." - (interactive "p") + (interactive "P") (save-current-buffer (set-buffer gnus-article-buffer) + (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")) (let ((handle (cdr (assq n gnus-article-mime-handle-alist)))) @@ -3049,7 +3471,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." (forward-line 1) (prog1 (let ((window (selected-window)) - (mail-parse-charset gnus-newsgroup-charset)) + (mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) (save-excursion (unwind-protect (let ((win (get-buffer-window (current-buffer) t)) @@ -3072,7 +3497,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-treat-article nil id (1- (length gnus-article-mime-handles)) - (car (mm-handle-type handle)))))) + (mm-handle-media-type handle))))) (select-window window)))) (goto-char point) (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point))) @@ -3093,7 +3518,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (mail-content-type-get (mm-handle-disposition handle) 'filename) "")) - (gnus-tmp-type (car (mm-handle-type handle))) + (gnus-tmp-type (mm-handle-media-type handle)) (gnus-tmp-description (mail-decode-encoded-word-string (or (mm-handle-description handle) ""))) @@ -3161,9 +3586,10 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when (and (not ihandles) (not gnus-displaying-mime)) ;; Top-level call; we clean up. - (mm-destroy-parts gnus-article-mime-handles) - (setq gnus-article-mime-handles handles - gnus-article-mime-handle-alist nil) + (when gnus-article-mime-handles + (mm-destroy-parts gnus-article-mime-handles) + (setq gnus-article-mime-handle-alist nil));; A trick. + (setq gnus-article-mime-handles handles) ;; We allow users to glean info from the handles. (when gnus-article-mime-part-function (gnus-mime-part-function handles))) @@ -3183,12 +3609,13 @@ If ALL-HEADERS is non-nil, no headers are hidden." (narrow-to-region (point) (point-max)) (gnus-treat-article nil 1 1) (widen))) - ;; Highlight the headers. - (save-excursion - (save-restriction - (article-goto-body) - (narrow-to-region (point-min) (point)) - (gnus-treat-article 'head))))))) + (unless ihandles + ;; Highlight the headers. + (save-excursion + (save-restriction + (article-goto-body) + (narrow-to-region (point-min) (point)) + (gnus-treat-article 'head)))))))) (defvar gnus-mime-display-multipart-as-mixed nil) @@ -3226,7 +3653,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (mapcar 'gnus-mime-display-part handles)) (defun gnus-mime-display-single (handle) - (let ((type (car (mm-handle-type handle))) + (let ((type (mm-handle-media-type handle)) (ignored gnus-ignored-mime-types) (not-attachment t) (move nil) @@ -3237,38 +3664,45 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when (string-match (pop ignored) type) (throw 'ignored nil))) (if (and (setq not-attachment - (or (not (mm-handle-disposition handle)) - (equal (car (mm-handle-disposition handle)) - "inline") - (mm-attachment-override-p type))) - (mm-automatic-display-p type) - (or (mm-inlinable-part-p type) + (and (not (mm-inline-override-p handle)) + (or (not (mm-handle-disposition handle)) + (equal (car (mm-handle-disposition handle)) + "inline") + (mm-attachment-override-p handle)))) + (mm-automatic-display-p handle) + (or (mm-inlined-p handle) (mm-automatic-external-display-p type))) (setq display t) - (when (equal (car (split-string type "/")) - "text") + (when (equal (mm-handle-media-supertype handle) "text") (setq text t))) (let ((id (1+ (length gnus-article-mime-handle-alist)))) (push (cons id handle) gnus-article-mime-handle-alist) (when (or (not display) (not (gnus-unbuttonized-mime-type-p type))) - (gnus-article-insert-newline) + ;(gnus-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) (setq move t))) (let ((beg (point))) (cond (display (when move - (forward-line -2)) - (let ((mail-parse-charset gnus-newsgroup-charset)) + (forward-line -2) + (setq beg (point))) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (condition-case () + (set-buffer gnus-summary-buffer) + (error)) + gnus-newsgroup-ignored-charsets))) (mm-display-part handle t)) (goto-char (point-max))) ((and text not-attachment) (when move - (forward-line -2)) + (forward-line -2) + (setq beg (point))) (gnus-article-insert-newline) (mm-insert-inline handle (mm-get-part handle)) (goto-char (point-max)))) @@ -3279,7 +3713,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (gnus-treat-article nil (length gnus-article-mime-handle-alist) (1- (length gnus-article-mime-handles)) - (car (mm-handle-type handle)))))))))) + (mm-handle-media-type handle))))))))) (defun gnus-unbuttonized-mime-type-p (type) "Say whether TYPE is to be unbuttonized." @@ -3346,9 +3780,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (progn (insert (format "(%c) %-18s" (if (equal handle preferred) ?* ? ) - (if (stringp (car handle)) - (car handle) - (car (mm-handle-type handle))))) + (mm-handle-media-type handle))) (point)) `(gnus-callback (lambda (handles) @@ -3371,8 +3803,19 @@ If ALL-HEADERS is non-nil, no headers are hidden." (when preferred (if (stringp (car preferred)) (gnus-display-mime preferred) - (let ((mail-parse-charset gnus-newsgroup-charset)) - (mm-display-part preferred))) + (let ((mail-parse-charset gnus-newsgroup-charset) + (mail-parse-ignored-charsets + (save-excursion (set-buffer gnus-summary-buffer) + gnus-newsgroup-ignored-charsets))) + (mm-display-part preferred) + ;; Do highlighting. + (save-excursion + (save-restriction + (narrow-to-region (car begend) (point-max)) + (gnus-treat-article + nil (length gnus-article-mime-handle-alist) + (1- (length gnus-article-mime-handles)) + (mm-handle-media-type handle)))))) (goto-char (point-max)) (setcdr begend (point-marker))))) (when ibegend @@ -3382,25 +3825,24 @@ If ALL-HEADERS is non-nil, no headers are hidden." "Return a string which display status of article washing." (save-excursion (set-buffer gnus-article-buffer) - (let ((cite (gnus-article-hidden-text-p 'cite)) - (headers (gnus-article-hidden-text-p 'headers)) - (boring (gnus-article-hidden-text-p 'boring-headers)) - (pgp (gnus-article-hidden-text-p 'pgp)) - (pem (gnus-article-hidden-text-p 'pem)) - (signature (gnus-article-hidden-text-p 'signature)) - (overstrike (gnus-article-hidden-text-p 'overstrike)) - (emphasis (gnus-article-hidden-text-p 'emphasis)) - (mime gnus-show-mime)) + (let ((cite (memq 'cite gnus-article-wash-types)) + (headers (memq 'headers gnus-article-wash-types)) + (boring (memq 'boring-headers gnus-article-wash-types)) + (pgp (memq 'pgp gnus-article-wash-types)) + (pem (memq 'pem gnus-article-wash-types)) + (signature (memq 'signature gnus-article-wash-types)) + (overstrike (memq 'overstrike gnus-article-wash-types)) + (emphasis (memq 'emphasis gnus-article-wash-types))) (format "%c%c%c%c%c%c%c" (if cite ?c ? ) (if (or headers boring) ?h ? ) (if (or pgp pem) ?p ? ) (if signature ?s ? ) (if overstrike ?o ? ) - (if mime ?m ? ) + (if gnus-show-mime ?m ? ) (if emphasis ?e ? ))))) -(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) +(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers) (defun gnus-article-maybe-hide-headers () "Hide unwanted headers if `gnus-have-all-headers' is nil. @@ -3422,7 +3864,7 @@ Provided for backwards compatibility." ;; save it to file. (goto-char (point-max)) (insert "\n") - (append-to-file (point-min) (point-max) file-name) + (write-region-as-binary (point-min) (point-max) file-name 'append) t))) (defun gnus-narrow-to-page (&optional arg) @@ -3481,48 +3923,56 @@ If given a numerical ARG, move forward ARG pages." If end of article, return non-nil. Otherwise return nil. Argument LINES specifies lines to be scrolled up." (interactive "p") - (move-to-window-line -1) - (if (save-excursion - (end-of-line) - (and (pos-visible-in-window-p) ;Not continuation line. - (eobp))) - ;; Nothing in this page. - (if (or (not gnus-page-broken) - (save-excursion - (save-restriction - (widen) (forward-line 1) (eobp)))) ;Real end-of-buffer? - t ;Nothing more. - (gnus-narrow-to-page 1) ;Go to next page. - nil) - ;; More in this page. - (let ((scroll-in-place nil)) - (condition-case () - (scroll-up lines) - (end-of-buffer - ;; Long lines may cause an end-of-buffer error. - (goto-char (point-max))))) - (move-to-window-line 0) - nil)) + (let ((start (window-start)) + end-of-buffer end-of-page) + (save-excursion + (move-to-window-line -1) + (if (<= (point) start) + (progn + (forward-line 2) + (setq start (point))) + (forward-line 1) + (setq start nil)) + (unless (or (cond ((eq (1+ (buffer-size)) (point)) + (and (pos-visible-in-window-p) + (setq end-of-buffer t))) + ((eobp) + (setq end-of-page t))) + (not lines)) + (move-to-window-line lines) + (unless (search-backward "\n\n" nil t) + (setq start (point))))) + (cond (end-of-buffer t) + (end-of-page + (gnus-narrow-to-page 1) + nil) + (t + (if start + (set-window-start (selected-window) start) + (let (window-pixel-scroll-increment) + (scroll-up lines))) + nil)))) (defun gnus-article-prev-page (&optional lines) "Show previous page of current article. Argument LINES specifies lines to be scrolled down." (interactive "p") - (move-to-window-line 0) - (if (and gnus-page-broken - (bobp) - (not (save-restriction (widen) (bobp)))) ;Real beginning-of-buffer? - (progn - (gnus-narrow-to-page -1) ;Go to previous page. - (goto-char (point-max)) - (recenter -1)) - (let ((scroll-in-place nil)) - (prog1 - (condition-case () - (scroll-down lines) - (beginning-of-buffer - (goto-char (point-min)))) - (move-to-window-line 0))))) + (let (beginning-of-buffer beginning-of-page) + (save-excursion + (move-to-window-line 0) + (cond ((eq 1 (point)) + (setq beginning-of-buffer t)) + ((bobp) + (setq beginning-of-page t)))) + (cond (beginning-of-buffer) + (beginning-of-page + (gnus-narrow-to-page -1)) + (t + (condition-case nil + (let (window-pixel-scroll-increment) + (scroll-down lines)) + (beginning-of-buffer + (goto-char (point-min)))))))) (defun gnus-article-refer-article () "Read article specified by message-id around point." @@ -3584,7 +4034,7 @@ Argument LINES specifies lines to be scrolled down." (gnus-article-check-buffer) (let ((nosaves '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F" - "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" + "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article '("A\r")) @@ -3597,7 +4047,9 @@ Argument LINES specifies lines to be scrolled down." (set-buffer gnus-article-current-summary) (let (gnus-pick-mode) (push (or key last-command-event) unread-command-events) - (setq keys (read-key-sequence nil)))) + (setq keys (static-if (featurep 'xemacs) + (events-to-keys (read-key-sequence nil)) + (read-key-sequence nil))))) (message "") (if (or (member keys nosaves) @@ -3609,7 +4061,8 @@ Argument LINES specifies lines to be scrolled down." ;; We disable the pick minor mode commands. (let (gnus-pick-mode) (setq func (lookup-key (current-local-map) keys)))) - (if (not func) + (if (or (not func) + (numberp func)) (ding) (unless (member keys nosave-in-article) (set-buffer gnus-article-current-summary)) @@ -3656,6 +4109,7 @@ headers will be hidden. If given a prefix, show the hidden text instead." (interactive (append (gnus-article-hidden-arg) (list 'force))) (gnus-article-hide-headers arg) + (gnus-article-hide-list-identifiers arg) (gnus-article-hide-pgp arg) (gnus-article-hide-citation-maybe arg force) (gnus-article-hide-signature arg)) @@ -3688,8 +4142,7 @@ If given a prefix, show the hidden text instead." ;; We only request an article by message-id when we do not have the ;; headers for it, so we'll have to get those. (when (stringp article) - (let ((gnus-override-method gnus-refer-article-method)) - (gnus-read-header article))) + (gnus-read-header article)) ;; If the article number is negative, that means that this article ;; doesn't belong in this newsgroup (possibly), so we find its @@ -3707,8 +4160,7 @@ If given a prefix, show the hidden text instead." ;; This is a sparse gap article. (setq do-update-line article) (setq article (mail-header-id header)) - (let ((gnus-override-method gnus-refer-article-method)) - (setq sparse-header (gnus-read-header article))) + (setq sparse-header (gnus-read-header article)) (setq gnus-newsgroup-sparse (delq article gnus-newsgroup-sparse))) ((vectorp header) @@ -3759,20 +4211,40 @@ If given a prefix, show the hidden text instead." (gnus-cache-request-article article group)) 'article) ;; Get the article and put into the article buffer. - ((or (stringp article) (numberp article)) - (let ((gnus-override-method - (and (stringp article) gnus-refer-article-method)) + ((or (stringp article) + (numberp article)) + (let ((gnus-override-method gnus-override-method) + (methods (and (stringp article) + gnus-refer-article-method)) + result (buffer-read-only nil)) - (erase-buffer) - (gnus-kill-all-overlays) - (gnus-check-group-server) - (when (gnus-request-article article group (current-buffer)) - (when (numberp article) - (gnus-async-prefetch-next group article gnus-summary-buffer) - (when gnus-keep-backlog - (gnus-backlog-enter-article - group article (current-buffer)))) - 'article))) + (setq methods + (if (listp methods) + 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 gnus-current-select-method)) + (erase-buffer) + (gnus-kill-all-overlays) + (let ((gnus-newsgroup-name group)) + (gnus-check-group-server)) + (when (gnus-request-article article group (current-buffer)) + (when (numberp article) + (gnus-async-prefetch-next group article + gnus-summary-buffer) + (when gnus-keep-backlog + (gnus-backlog-enter-article + group article (current-buffer)))) + (setq result 'article)) + (if (not result) + (if methods + (setq gnus-override-method (pop methods)) + (setq result 'done)))) + (and (eq result 'article) 'article))) ;; It was a pseudo. (t article))) @@ -3885,8 +4357,6 @@ groups." (set-buffer gnus-article-buffer) (gnus-article-edit-mode) (funcall start-func) - ;;(gnus-article-delete-text-of-type 'annotation) - ;;(gnus-set-text-properties (point-min) (point-max) nil) (gnus-configure-windows 'edit-article) (setq gnus-article-edit-done-function exit-func) (setq gnus-prev-winconf winconf) @@ -3948,7 +4418,7 @@ groups." "Exit the article editing without updating." (interactive) ;; We remove all text props from the article buffer. - (let ((buf (format "%s" (buffer-string))) + (let ((buf (buffer-substring-no-properties (point-min) (point-max))) (curbuf (current-buffer)) (p (point)) (window-start (window-start))) @@ -4062,7 +4532,7 @@ after replacing with the original article." ;;; Internal Variables: -(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)" +(defcustom gnus-button-url-regexp "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\)\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)\\)" "Regular expression that matches URLs." :group 'gnus-article-buttons :type 'regexp) @@ -4081,9 +4551,9 @@ after replacing with the original article." ("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) + ("]*\\)>" 0 t gnus-button-embedded-url 1) ;; Raw URLs. - (,gnus-button-url-regexp 0 t gnus-button-url 0)) + (,gnus-button-url-regexp 0 t browse-url 0)) "*Alist of regexps matching buttons in article bodies. Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where @@ -4111,9 +4581,9 @@ variable it the real callback function." ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1) ("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+" 0 t gnus-button-mailto 0) - ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0) - ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0) + ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t browse-url 0) + ("^Subject:" ,gnus-button-url-regexp 0 t browse-url 0) + ("^[^:]+:" ,gnus-button-url-regexp 0 t browse-url 0) ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t gnus-button-message-id 3)) "*Alist of headers and regexps to match buttons in article heads. @@ -4269,21 +4739,28 @@ do the highlighting. See the documentation for those functions." It does this by highlighting everything after `gnus-signature-separator' using `gnus-signature-face'." (interactive) + (when gnus-signature-face + (save-excursion + (set-buffer gnus-article-buffer) + (let ((buffer-read-only nil) + (inhibit-point-motion-hooks t)) + (save-restriction + (when (gnus-article-narrow-to-signature) + (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) + 'face gnus-signature-face))))))) + +(defun gnus-article-buttonize-signature () + "Add button to the signature." + (interactive) (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) (inhibit-point-motion-hooks t)) - (save-restriction - (when (and gnus-signature-face - (gnus-article-narrow-to-signature)) - (gnus-overlay-put (gnus-make-overlay (point-min) (point-max)) - 'face gnus-signature-face) - (widen) - (gnus-article-search-signature) - (let ((start (match-beginning 0)) - (end (set-marker (make-marker) (1+ (match-end 0))))) - (gnus-article-add-button start (1- end) 'gnus-signature-toggle - end))))))) + (when (gnus-article-search-signature) + (gnus-article-add-button (match-beginning 0) (match-end 0) + 'gnus-signature-toggle + (set-marker (make-marker) + (1+ (match-end 0)))))))) (defun gnus-button-in-region-p (b e prop) "Say whether PROP exists in the region." @@ -4302,14 +4779,17 @@ specified by `gnus-button-alist'." (alist gnus-button-alist) beg entry regexp) ;; Remove all old markers. - (let (marker entry) + (let (marker entry new-list) (while (setq marker (pop gnus-button-marker-list)) - (goto-char marker) - (when (setq entry (gnus-button-entry)) - (put-text-property (match-beginning (nth 1 entry)) - (match-end (nth 1 entry)) - 'gnus-callback nil)) - (set-marker marker nil))) + (if (or (< marker (point-min)) (>= marker (point-max))) + (push marker new-list) + (goto-char marker) + (when (setq entry (gnus-button-entry)) + (put-text-property (match-beginning (nth 1 entry)) + (match-end (nth 1 entry)) + 'gnus-callback nil)) + (set-marker marker nil))) + (setq gnus-button-marker-list new-list)) ;; We skip the headers. (article-goto-body) (setq beg (point)) @@ -4395,10 +4875,12 @@ specified by `gnus-button-alist'." (save-excursion (set-buffer gnus-article-buffer) (let ((buffer-read-only nil) - (inhibit-point-motion-hooks t)) + (inhibit-point-motion-hooks t) + (limit (next-single-property-change end 'mime-view-entity + nil (point-max)))) (if (get-text-property end 'invisible) - (gnus-article-unhide-text end (point-max)) - (gnus-article-hide-text end (point-max) gnus-hidden-properties))))) + (gnus-article-unhide-text end limit) + (gnus-article-hide-text end limit gnus-hidden-properties))))) (defun gnus-button-entry () ;; Return the first entry in `gnus-button-alist' matching this place. @@ -4542,19 +5024,13 @@ forbidden in URL encoding." (gnus-setup-message 'reply (message-reply address))) -(defun gnus-button-url (address) - "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. - (if (listp browse-url-browser-function) - (browse-url address) - (funcall browse-url-browser-function address))) - (defun gnus-button-embedded-url (address) "Browse ADDRESS." - ;; In Emacs 20, `browse-url-browser-function' may be an alist. - (if (listp browse-url-browser-function) - (browse-url (gnus-strip-whitespace address)) - (funcall browse-url-browser-function (gnus-strip-whitespace address)))) + (browse-url (gnus-strip-whitespace address))) + +(defun gnus-article-smiley-display () + "Display \"smileys\" as small graphical icons." + (smiley-toggle-buffer 1 (current-buffer) (point-min) (point-max))) ;;; Next/prev buttons in the article buffer. @@ -4567,18 +5043,29 @@ forbidden in URL encoding." (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page) (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page)) -(defun gnus-insert-prev-page-button () - (let ((buffer-read-only nil)) - (gnus-eval-format - gnus-prev-page-line-format nil - `(gnus-prev t local-map ,gnus-prev-page-map - gnus-callback gnus-article-button-prev-page - article-type annotation)))) +(static-if (featurep 'xemacs) + (defun gnus-insert-prev-page-button () + (let ((buffer-read-only nil)) + (gnus-eval-format + gnus-prev-page-line-format nil + `(gnus-prev t local-map ,gnus-prev-page-map + gnus-callback gnus-article-button-prev-page + article-type annotation)))) + (defun gnus-insert-prev-page-button () + (let ((buffer-read-only nil) + (situation (get-text-property (point-min) 'mime-view-situation))) + (set-keymap-parent gnus-prev-page-map (current-local-map)) + (gnus-eval-format + gnus-prev-page-line-format nil + `(gnus-prev t local-map ,gnus-prev-page-map + gnus-callback gnus-article-button-prev-page + article-type annotation + mime-view-situation ,situation)))) + ) (defvar gnus-next-page-map nil) (unless gnus-next-page-map - (setq gnus-next-page-map (make-keymap)) - (suppress-keymap gnus-prev-page-map) + (setq gnus-next-page-map (make-sparse-keymap)) (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page) (define-key gnus-next-page-map "\r" 'gnus-button-next-page)) @@ -4598,13 +5085,25 @@ forbidden in URL encoding." (gnus-article-prev-page) (select-window win))) -(defun gnus-insert-next-page-button () - (let ((buffer-read-only nil)) - (gnus-eval-format gnus-next-page-line-format nil - `(gnus-next - t local-map ,gnus-next-page-map - gnus-callback gnus-article-button-next-page - article-type annotation)))) +(static-if (featurep 'xemacs) + (defun gnus-insert-next-page-button () + (let ((buffer-read-only nil)) + (gnus-eval-format gnus-next-page-line-format nil + `(gnus-next + t local-map ,gnus-next-page-map + gnus-callback gnus-article-button-next-page + article-type annotation)))) + (defun gnus-insert-next-page-button () + (let ((buffer-read-only nil) + (situation (get-text-property (point-min) 'mime-view-situation))) + (set-keymap-parent gnus-next-page-map (current-local-map)) + (gnus-eval-format gnus-next-page-line-format nil + `(gnus-next + t local-map ,gnus-next-page-map + gnus-callback gnus-article-button-next-page + article-type annotation + mime-view-situation ,situation)))) + ) (defun gnus-article-button-next-page (arg) "Go to the next page." @@ -4626,8 +5125,8 @@ forbidden in URL encoding." '(mail-decode-encoded-word-region) "List of methods used to decode headers. -This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is -FUNCTION, FUNCTION will be apply to all newsgroups. If item is a +This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item +is FUNCTION, FUNCTION will be apply to all newsgroups. If item is a (REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups whose names match REGEXP. @@ -4645,13 +5144,13 @@ For example: (eq gnus-newsgroup-name (car gnus-decode-header-methods-cache))) (setq gnus-decode-header-methods-cache (list gnus-newsgroup-name)) - (mapc '(lambda (x) - (if (symbolp x) - (nconc gnus-decode-header-methods-cache (list x)) - (if (and gnus-newsgroup-name - (string-match (car x) gnus-newsgroup-name)) - (nconc gnus-decode-header-methods-cache - (list (cdr x)))))) + (mapcar (lambda (x) + (if (symbolp x) + (nconc gnus-decode-header-methods-cache (list x)) + (if (and gnus-newsgroup-name + (string-match (car x) gnus-newsgroup-name)) + (nconc gnus-decode-header-methods-cache + (list (cdr x)))))) gnus-decode-header-methods)) (let ((xlist gnus-decode-header-methods-cache)) (pop xlist) @@ -4676,17 +5175,37 @@ For example: (when (string-match (pop list) type) (throw 'found t))))))) (highlightp (gnus-visual-p 'article-highlight 'highlight)) - val elem) + (entity (static-unless (featurep 'xemacs) + (when (eq 'head condition) + (get-text-property (point-min) 'mime-view-entity)))) + val elem buttonized) (gnus-run-hooks 'gnus-part-display-hook) - (while (setq elem (pop alist)) - (setq val (symbol-value (car elem))) - (when (and (or (consp val) - treated-type) - (gnus-treat-predicate val) - (or (not (get (car elem) 'highlight)) - highlightp)) - (save-restriction - (funcall (cadr elem))))))) + (unless gnus-inhibit-treatment + (while (setq elem (pop alist)) + (setq val + (save-excursion + (if (gnus-buffer-live-p gnus-summary-buffer) + (set-buffer gnus-summary-buffer)) + (symbol-value (car elem)))) + (when (and (or (consp val) + treated-type) + (gnus-treat-predicate val) + (or (not (get (car elem) 'highlight)) + highlightp)) + (when (and (not buttonized) + (memq (car elem) + '(gnus-treat-hide-signature + gnus-treat-highlight-signature))) + (gnus-article-buttonize-signature) + (setq buttonized t)) + (save-restriction + (funcall (cadr elem))))) + ;; FSF Emacsen does not inherit the existing text properties + ;; in the new text, so we should do it for `mime-view-entity'. + (static-unless (featurep 'xemacs) + (when entity + (put-text-property (point-min) (point-max) + 'mime-view-entity entity)))))) ;; Dynamic variables. (defvar part-number) @@ -4696,12 +5215,13 @@ For example: (defvar length) (defun gnus-treat-predicate (val) (cond - ((eq val 'mime) - (and gnus-show-mime t)) - ((eq val 'nomime) - (not gnus-show-mime)) ((null val) nil) + ((and (listp val) + (stringp (car val))) + (apply 'gnus-or (mapcar `(lambda (s) + (string-match s ,(or gnus-newsgroup-name ""))) + val))) ((listp val) (let ((pred (pop val))) (cond @@ -4710,11 +5230,13 @@ For example: ((eq pred 'and) (apply 'gnus-and (mapcar 'gnus-treat-predicate val))) ((eq pred 'not) - (not (gnus-treat-predicate val))) + (not (gnus-treat-predicate (car val)))) ((eq pred 'typep) - (equal (cadr val) type)) + (equal (car val) type)) (t - (gnus-treat-predicate pred))))) + (error "%S is not a valid predicate" pred))))) + ((eq val 'mime) + gnus-show-mime) (condition (eq condition val)) ((eq val t) @@ -4749,28 +5271,24 @@ For example: (set-alist 'mime-preview-quitting-method-alist 'gnus-original-article-mode #'gnus-mime-preview-quitting-method) -(defun gnus-following-method (buf) - (set-buffer buf) - (message-followup) - (message-yank-original) - (kill-buffer buf) - (goto-char (point-min)) - ) - (set-alist 'mime-preview-following-method-alist 'gnus-original-article-mode #'gnus-following-method) (set-alist 'mime-preview-over-to-previous-method-alist 'gnus-original-article-mode (lambda () - (gnus-article-read-summary-keys - nil (gnus-character-to-event ?P)))) + (if (> (point-min) 1) + (gnus-article-prev-page) + (gnus-article-read-summary-keys + nil (gnus-character-to-event ?P))))) (set-alist 'mime-preview-over-to-next-method-alist 'gnus-original-article-mode' (lambda () - (gnus-article-read-summary-keys - nil (gnus-character-to-event ?N)))) + (if (< (point-max) (buffer-size)) + (gnus-article-next-page) + (gnus-article-read-summary-keys + nil (gnus-character-to-event ?N))))) ;;; @ end