;;; 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 <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
(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")
"^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:")
+ "^X-Received:" "^Content-length:" "X-precedence:"
+ "^X-Authenticated-User:" "^X-Comment" "^X-Report:" "^X-Abuse-Info:"
+ "^X-HTTP-Proxy:" "^X-Mydeja-Info:" "^X-Copyright" "^X-No-Markup:"
+ "^X-Abuse-Info:")
"*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."
(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'."
+Possible values in this list are:
+
+ 'empty Headers with no content.
+ 'newsgroups Newsgroup identical to Gnus group.
+ 'to-address To identical to To-address.
+ 'followup-to Followup-to identical to Newsgroups.
+ 'reply-to Reply-to identical to From.
+ 'date Date less than four days old.
+ 'long-to To and/or Cc longer than 1024 characters.
+ 'many-to Multiple To and/or Cc."
:type '(set (const :tag "Headers with no content." empty)
- (const :tag "Newsgroups with only one group." newsgroups)
- (const :tag "Followup-to identical to newsgroups." followup-to)
- (const :tag "Reply-to identical to from." reply-to)
+ (const :tag "Newsgroups identical to Gnus 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)
- (const :tag "Very long To and/or Cc header." long-to)
+ (const :tag "To and/or Cc longer than 1024 characters." long-to)
(const :tag "Multiple To and/or Cc headers." many-to))
:group 'gnus-article-hiding)
: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))
(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
(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)
-(defcustom gnus-article-banner-alist nil
- "Banner alist for stripping.
-For example,
- ((egroups . \"^[ \\t\\n]*-------------------+\\\\( eGroups Sponsor -+\\\\)?....\\n\\\\(.+\\n\\\\)+\"))"
- :version "21.1"
- :type '(repeat (cons symbol regexp))
- :group 'gnus-article-washing)
+(gnus-define-group-parameter
+ banner
+ :variable-document
+ "Alist of regexps (to match group names) and banner."
+ :variable-group gnus-article-washing
+ :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
+ "If non-nil, specify how to remove `banners' from articles.
+
+Symbol `signature' means to remove signatures delimited by
+`gnus-signature-separator'. Any other symbol is used to look up a
+regular expression to match the banner in `gnus-article-banner-alist'.
+A string is used as a regular expression to match the banner
+directly.")
(defcustom gnus-emphasis-alist
(let ((format
: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
(background light))
(:foreground "indianred4" :italic t))
(t
- (:italic t))) "Face used for displaying header content."
+ (:italic t)))
+ "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
(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)))
: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.
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
+(defcustom gnus-treat-date-english nil
+ "Display the Date in a format that can be read aloud in English.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
+ :group 'gnus-article-treat
+ :type gnus-article-treat-head-custom)
+
(defcustom gnus-treat-date-lapsed nil
"Display the Date header in a way that says how much time has elapsed.
Valid values are nil, t, `head', `last', an integer or a predicate.
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)
(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)
;;; Internal variables
+(defvar gnus-english-month-names
+ '("January" "February" "March" "April" "May" "June" "July" "August"
+ "September" "October" "November" "December"))
+
(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-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)
(gnus-treat-fill-long-lines gnus-article-fill-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
(gnus-treat-display-xface gnus-article-display-x-face)
+ (gnus-treat-date-ut gnus-article-date-ut)
+ (gnus-treat-date-local gnus-article-date-local)
+ (gnus-treat-date-english gnus-article-date-english)
+ (gnus-treat-date-lapsed gnus-article-date-lapsed)
+ (gnus-treat-date-original gnus-article-date-original)
+ (gnus-treat-date-user-defined gnus-article-date-user)
+ (gnus-treat-date-iso8601 gnus-article-date-iso8601)
(gnus-treat-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-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)
(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)
- (gnus-treat-date-local gnus-article-date-local)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
- (gnus-treat-date-original gnus-article-date-original)
- (gnus-treat-date-user-defined gnus-article-date-user)
- (gnus-treat-date-iso8601 gnus-article-date-iso8601)
(gnus-treat-strip-trailing-blank-lines
gnus-article-remove-trailing-blank-lines)
(gnus-treat-strip-leading-blank-lines
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)))
(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)
(gnus-article-show-hidden-text 'boring-headers)
(when (eq 1 (point-min))
(set-window-start (get-buffer-window (current-buffer)) 1)))
- (unless gnus-inhibit-hiding
- (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)
- (cond ((stringp gnus-ignored-headers)
- gnus-ignored-headers)
- ((listp gnus-ignored-headers)
- (mapconcat 'identity gnus-ignored-headers
- "\\|")))))
- (visible
- (cond ((stringp gnus-visible-headers)
- gnus-visible-headers)
- ((and gnus-visible-headers
- (listp gnus-visible-headers))
- (mapconcat 'identity gnus-visible-headers "\\|"))))
- (inhibit-point-motion-hooks t)
- beg)
- ;; First we narrow to just the headers.
- (article-narrow-to-head)
- ;; Hide any "From " lines at the beginning of (mail) articles.
- (while (looking-at "From ")
- (forward-line 1))
- (unless (bobp)
- (if delete
- (delete-region (point-min) (point))
- (gnus-article-hide-text (point-min) (point)
- (nconc (list 'article-type 'headers)
- gnus-hidden-properties))))
- ;; Then treat the rest of the header lines.
- ;; Then we use the two regular expressions
- ;; `gnus-ignored-headers' and `gnus-visible-headers' to
- ;; select which header lines is to remain visible in the
- ;; article buffer.
- (while (re-search-forward "^[^ \t]*:" nil t)
- (beginning-of-line)
- ;; Mark the rank of the header.
- (put-text-property
- (point) (1+ (point)) 'message-rank
- (if (or (and visible (looking-at visible))
- (and ignored
- (not (looking-at ignored))))
- (gnus-article-header-rank)
- (+ 2 max)))
- (forward-line 1))
- (message-sort-headers-1)
- (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
- (point-min) (+ 5 (point-min))
- '(article-type headers dummy-invisible t))
- (delete-region beg (point-max)))
- (gnus-article-hide-text-type beg (point-max) 'headers))))))))
+ (unless gnus-inhibit-hiding
+ (save-excursion
+ (save-restriction
+ (let ((inhibit-read-only t)
+ (case-fold-search t)
+ (max (1+ (length gnus-sorted-header-list)))
+ (ignored (when (not gnus-visible-headers)
+ (cond ((stringp gnus-ignored-headers)
+ gnus-ignored-headers)
+ ((listp gnus-ignored-headers)
+ (mapconcat 'identity gnus-ignored-headers
+ "\\|")))))
+ (visible
+ (cond ((stringp gnus-visible-headers)
+ gnus-visible-headers)
+ ((and gnus-visible-headers
+ (listp gnus-visible-headers))
+ (mapconcat 'identity gnus-visible-headers "\\|"))))
+ (inhibit-point-motion-hooks t)
+ beg)
+ ;; First we narrow to just the headers.
+ (article-narrow-to-head)
+ ;; Hide any "From " lines at the beginning of (mail) articles.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (unless (bobp)
+ (if delete
+ (delete-region (point-min) (point))
+ (gnus-article-hide-text (point-min) (point)
+ (nconc (list 'article-type 'headers)
+ gnus-hidden-properties))))
+ ;; Then treat the rest of the header lines.
+ ;; Then we use the two regular expressions
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+ ;; select which header lines is to remain visible in the
+ ;; article buffer.
+ (while (re-search-forward "^[^ \t:]*:" nil t)
+ (beginning-of-line)
+ ;; Mark the rank of the header.
+ (put-text-property
+ (point) (1+ (point)) 'message-rank
+ (if (or (and visible (looking-at visible))
+ (and ignored
+ (not (looking-at ignored))))
+ (gnus-article-header-rank)
+ (+ 2 max)))
+ (forward-line 1))
+ (message-sort-headers-1)
+ (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
+ (point-min) (+ 5 (point-min))
+ '(article-type headers dummy-invisible t))
+ (delete-region beg (point-max)))
+ (gnus-article-hide-text-type beg (point-max) 'headers))))))))
)
(defun article-hide-boring-headers (&optional arg)
'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"))
(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")))
(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
(width (window-width (get-buffer-window (current-buffer)))))
(save-restriction
(article-goto-body)
- (let ((adaptive-fill-mode nil))
+ (let ((adaptive-fill-mode nil)) ;Why? -sm
(while (not (eobp))
(end-of-line)
(when (>= (current-column) (min fill-column width))
(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))
(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
(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)))))
(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))
gnus-newsgroup-ignored-charsets))
ct cte ctl charset format)
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (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)))))))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (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."
(mime-decode-header-in-buffer charset)
)))
-(defun article-de-quoted-unreadable (&optional force)
+(defun article-de-quoted-unreadable (&optional force read-charset)
"Translate a quoted-printable-encoded article.
If FORCE, decode the article whether it is marked as quoted-printable
-or not."
- (interactive (list 'force))
+or not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
(let ((buffer-read-only nil) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(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
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(quoted-printable-decode-region
(point) (point-max) (mm-charset-to-coding-system charset))))))
-(defun article-de-base64-unreadable (&optional force)
+(defun article-de-base64-unreadable (&optional force read-charset)
"Translate a base64 article.
-If FORCE, decode the article whether it is marked as base64 not."
- (interactive (list 'force))
+If FORCE, decode the article whether it is marked as base64 not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
(let ((buffer-read-only nil) type charset)
(if (gnus-buffer-live-p gnus-original-article-buffer)
(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
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(let ((buffer-read-only nil))
(rfc1843-decode-region (point-min) (point-max)))))
-(defun article-wash-html ()
- "Format an html article."
- (interactive)
+(defun article-wash-html (&optional read-charset)
+ "Format an html article.
+If READ-CHARSET, ask for a coding system."
+ (interactive "P")
(save-excursion
(let ((buffer-read-only nil)
charset)
(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
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
(setq charset gnus-newsgroup-charset))
(article-goto-body)
(save-window-excursion
"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."
(save-excursion
(save-restriction
(let ((inhibit-point-motion-hooks t)
- (banner (gnus-group-find-parameter gnus-newsgroup-name 'banner))
+ (banner (gnus-parameter-banner gnus-newsgroup-name))
(gnus-signature-limit nil)
buffer-read-only beg end)
(when banner
(start (point))
(end (point-max))
(orig (buffer-substring start end))
- (trans (babel-as-string orig)))
+ (trans (babel-as-string orig)))
(save-restriction
(narrow-to-region start end)
(delete-region start end)
- (insert trans))))))
+ (insert trans))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
(replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
(article-goto-body)
- (while (re-search-forward "\n\n\n+" nil t)
+ (while (re-search-forward "\n\n\\(\n+\\)" nil t)
(unless (gnus-annotation-in-region-p
(match-beginning 0) (match-end 0))
- (replace-match "\n\n" t t))))))
+ (delete-region (match-beginning 1) (match-end 1)))))))
(defun article-strip-leading-space ()
"Remove all white space from the beginning of the lines in the article."
(> arg 0))
nil)
((< arg 0)
- (gnus-article-show-hidden-text type))
+ (gnus-article-show-hidden-text type)
+ t)
(t
(if (eq hide 'hidden)
- (gnus-article-show-hidden-text type)
+ (progn
+ (gnus-article-show-hidden-text type)
+ t)
nil)))))))
(defun gnus-article-hidden-text-p (type)
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)))))
(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)
+ 'original-date)
+ date)
eface (get-text-property (1- (gnus-point-at-eol))
'face)))
(let ((buffer-read-only nil))
(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"))))))
- (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."
(interactive (list t))
(article-date-ut 'local highlight))
+(defun article-date-english (&optional highlight)
+ "Convert the current article date to something that is proper English."
+ (interactive (list t))
+ (article-date-ut 'english highlight))
+
(defun article-date-original (&optional highlight)
"Convert the current article date to what it was originally.
This is only useful if you have used some other date conversion
(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)
visible (nth 2 elem)
face (nth 3 elem))
(while (re-search-forward regexp nil t)
- (when (and (match-beginning visible) (match-beginning invisible))
+ (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
- (match-beginning visible) (match-end visible) 'emphasis)
- (gnus-put-text-property-excluding-newlines
- (match-beginning visible) (match-end visible) 'face face)
- (goto-char (match-end invisible)))))))))
+ (gnus-article-hide-text
+ (match-beginning invisible) (match-end invisible) props)
+ (gnus-article-unhide-text-type
+ (match-beginning visible) (match-end visible) 'emphasis)
+ (gnus-put-text-property-excluding-newlines
+ (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."
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.
(car (push result file-name-history)))))))
;; Create the directory.
(gnus-make-directory (file-name-directory file))
- ;; If we have read a directory, we append the default file name.
+ ;; If we have read a directory, we append the default file name.
(when (file-directory-p file)
(setq file (expand-file-name (file-name-nondirectory
default-name)
(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: "
"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)
(expand-file-name
(if (gnus-use-long-file-name 'not-save)
newsgroup
- (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup)))
+ (file-relative-name
+ (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
+ default-directory))
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)
(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
(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))
(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)
gfunc (intern (format "gnus-%s" func))))
(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))))))))
+ `(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-verify-x-pgp-sig
article-hide-boring-headers
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
article-strip-blank-lines
article-strip-all-blank-lines
article-date-local
+ article-date-english
article-date-iso8601
article-date-original
article-date-ut
"\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
["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.
\\[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)
(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)
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)
;;;###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
(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
(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
(let ((map (make-sparse-keymap)))
- ;; Not for Emacs 21: fixme better.
- ;; (set-keymap-parent map gnus-article-mode-map)
+ (unless (>= (string-to-number emacs-version) 21)
+ ;; XEmacs doesn't care.
+ (set-keymap-parent map gnus-article-mode-map))
(define-key map gnus-mouse-2 'gnus-article-push-button)
(define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
(dolist (c gnus-mime-button-commands)
(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
(goto-char (point-min))
(or (search-forward "\n\n") (goto-char (point-max)))
(let (buffer-read-only)
- (delete-region (point) (point-max)))
- (mm-display-parts handles)))))
+ (delete-region (point) (point-max))
+ (mm-display-parts handles))))))
(defun gnus-mime-save-part-and-strip ()
"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
+ (handles gnus-article-mime-handles))
+ (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)
(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 ()
- (erase-buffer)
- (let ((mail-parse-charset (or gnus-article-charset
- ',gnus-newsgroup-charset))
- (mail-parse-ignored-charsets
- (or gnus-article-ignored-charsets
- ',gnus-newsgroup-ignored-charsets))
- (mbl mml-buffer-list))
- (setq mml-buffer-list nil)
- (insert-buffer gnus-original-article-buffer)
- (mime-to-mml gnus-article-mime-handles)
- (setq gnus-article-mime-handles nil)
- (make-local-hook 'kill-buffer-hook)
- (let ((mbl1 mml-buffer-list))
- (setq mml-buffer-list mbl)
- (set (make-local-variable 'mml-buffer-list) mbl1))
- (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
+ `(lambda ()
+ (erase-buffer)
+ (let ((mail-parse-charset (or gnus-article-charset
+ ',gnus-newsgroup-charset))
+ (mail-parse-ignored-charsets
+ (or gnus-article-ignored-charsets
+ ',gnus-newsgroup-ignored-charsets))
+ (mbl mml-buffer-list))
+ (setq mml-buffer-list nil)
+ (insert-buffer gnus-original-article-buffer)
+ (mime-to-mml ',handles)
+ (setq gnus-article-mime-handles nil)
+ (let ((mbl1 mml-buffer-list))
+ (setq mml-buffer-list mbl)
+ (set (make-local-variable 'mml-buffer-list) mbl1))
+ ;; LOCAL argument of add-hook differs between GNU Emacs
+ ;; and XEmacs. make-local-hook makes sure they are local.
+ (make-local-hook 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
`(lambda (no-highlight)
(let ((mail-parse-charset (or gnus-article-charset
',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
- 'mml-destroy-buffers t)
- (kill-local-variable 'mml-buffer-list))
+ (mml-to-mime)
+ (mml-destroy-buffers)
+ (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 ()
(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 ()
(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)
+ nil
+ (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)
(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: ")))))
+ (mm-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)
(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)))
(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))
+ (mm-read-coding-system "Charset: ")))
+ (gnus-newsgroup-ignored-charsets 'gnus-all))
(gnus-article-press-button)))))
(defun gnus-mime-externalize-part (&optional handle)
(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
(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
(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"))))
(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"))
(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
;; This will remove the part.
(mm-display-part handle)
(save-restriction
- (narrow-to-region (point) (1+ (point)))
+ (narrow-to-region (point)
+ (if (eobp) (point) (1+ (point))))
(mm-display-part handle)
;; We narrow to the part itself and
;; then call the treatment functions.
nil id
(gnus-article-mime-total-parts)
(mm-handle-media-type handle)))))
- (select-window window))))
+ (if (window-live-p window)
+ (select-window window)))))
(goto-char point)
(delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
(gnus-insert-mime-button
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
(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
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)))
+ ;;(gnus-mime-display-mixed (cdr handle))
+ ;;;!!! No, w3 can display everything just fine.
+ (gnus-mime-display-part (cadr handle)))
((equal (car handle) "multipart/signed")
(or (memq 'signed gnus-article-wash-types)
(push 'signed gnus-article-wash-types))
"inline")
(mm-attachment-override-p handle))))
(mm-automatic-display-p handle)
- (or (mm-inlined-p handle)
+ (or (and
+ (mm-inlinable-p handle)
+ (mm-inlined-p handle))
(mm-automatic-external-display-p type)))
(setq display t)
(when (equal (mm-handle-media-supertype handle) "text")
;(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))
(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))
(save-restriction
(narrow-to-region beg (point))
(gnus-treat-article
- nil id
+ nil id
(gnus-article-mime-total-parts)
(mm-handle-media-type handle)))))))))
(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)
(interactive "P")
(gnus-article-check-buffer)
(let ((nosaves
- '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
- "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
- "=" "^" "\M-^" "|"))
- (nosave-but-article
- '("A\r"))
- (nosave-in-article
- '("\C-d"))
- (up-to-top
- '("n" "Gn" "p" "Gp"))
- keys new-sum-point)
+ '("q" "Q" "c" "r" "R" "\C-c\C-f" "m" "a" "f" "F"
+ "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
+ "=" "^" "\M-^" "|"))
+ (nosave-but-article
+ '("A\r"))
+ (nosave-in-article
+ '("\C-d"))
+ (up-to-top
+ '("n" "Gn" "p" "Gp"))
+ keys new-sum-point)
(save-excursion
(set-buffer gnus-article-current-summary)
(let (gnus-pick-mode)
- (push (or key last-command-event) unread-command-events)
+ (push (or key last-command-event) unread-command-events)
(setq keys (static-if (featurep 'xemacs)
(events-to-keys (read-key-sequence nil))
(read-key-sequence nil)))))
(message "")
(if (or (member keys nosaves)
- (member keys nosave-but-article)
- (member keys nosave-in-article))
- (let (func)
- (save-window-excursion
- (pop-to-buffer gnus-article-current-summary 'norecord)
- ;; We disable the pick minor mode commands.
- (let (gnus-pick-mode)
- (setq func (lookup-key (current-local-map) keys))))
- (if (or (not func)
+ (member keys nosave-but-article)
+ (member keys nosave-in-article))
+ (let (func)
+ (save-window-excursion
+ (pop-to-buffer gnus-article-current-summary 'norecord)
+ ;; We disable the pick minor mode commands.
+ (let (gnus-pick-mode)
+ (setq func (lookup-key (current-local-map) keys))))
+ (if (or (not func)
(numberp func))
- (ding)
- (unless (member keys nosave-in-article)
- (set-buffer gnus-article-current-summary))
- (call-interactively func)
- (setq new-sum-point (point)))
- (when (member keys nosave-but-article)
- (pop-to-buffer gnus-article-buffer 'norecord)))
+ (ding)
+ (unless (member keys nosave-in-article)
+ (set-buffer gnus-article-current-summary))
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (when (member keys nosave-but-article)
+ (pop-to-buffer gnus-article-buffer 'norecord)))
;; These commands should restore window configuration.
(let ((obuf (current-buffer))
- (owin (current-window-configuration))
- (opoint (point))
- (summary gnus-article-current-summary)
- func in-buffer selected)
- (if not-restore-window
- (pop-to-buffer summary 'norecord)
- (switch-to-buffer summary 'norecord))
- (setq in-buffer (current-buffer))
- ;; We disable the pick minor mode commands.
- (if (and (setq func (let (gnus-pick-mode)
+ (owin (current-window-configuration))
+ (opoint (point))
+ (summary gnus-article-current-summary)
+ func in-buffer selected)
+ (if not-restore-window
+ (pop-to-buffer summary 'norecord)
+ (switch-to-buffer summary 'norecord))
+ (setq in-buffer (current-buffer))
+ ;; We disable the pick minor mode commands.
+ (if (and (setq func (let (gnus-pick-mode)
(lookup-key (current-local-map) keys)))
(functionp func))
- (progn
- (call-interactively func)
- (setq new-sum-point (point))
+ (progn
+ (call-interactively func)
+ (setq new-sum-point (point))
(when (eq in-buffer (current-buffer))
(setq selected (gnus-summary-select-article))
(set-buffer obuf)
(when win
(set-window-point win new-sum-point)))) )
(switch-to-buffer gnus-article-buffer)
- (ding))))))
+ (ding))))))
(defun gnus-article-describe-key (key)
"Display documentation of the function invoked by KEY. KEY is a string."
(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)))
(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)))
((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))
(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
"\C-c\C-w" gnus-article-edit-mode-map)
"f" gnus-article-edit-full-stops))
-(defun gnus-article-edit-mode ()
+(define-derived-mode gnus-article-edit-mode text-mode "Article Edit"
"Major mode for editing articles.
This is an extended text-mode.
\\{gnus-article-edit-mode-map}"
- (interactive)
- (setq major-mode 'gnus-article-edit-mode)
- (setq mode-name "Article Edit")
- (use-local-map gnus-article-edit-mode-map)
(make-local-variable 'gnus-article-edit-done-function)
(make-local-variable 'gnus-prev-winconf)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t))
(setq buffer-read-only nil)
(buffer-enable-undo)
- (widen)
- (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
+ (widen))
(defun gnus-article-edit (&optional force)
"Edit the current article.
(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."
(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))
(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."
(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
(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)
(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
: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)
("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)" 2
t gnus-button-message-id 3)
("\\(<URL: *\\)mailto: *\\([^> \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...
("<URL: *\\([^<>]*\\)>" 0 t gnus-button-embedded-url 1)
(interactive "e")
(set-buffer (window-buffer (posn-window (event-start event))))
(let* ((pos (posn-point (event-start event)))
- (data (get-text-property pos 'gnus-data))
+ (data (get-text-property pos 'gnus-data))
(fun (get-text-property pos 'gnus-callback)))
(goto-char pos)
(when fun
(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
(setq pairs (split-string query "&"))
(while pairs
(setq cur (car pairs)
- pairs (cdr pairs))
+ pairs (cdr pairs))
(if (not (string-match "=" cur))
- nil ; Grace
- (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
- val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
- (if downcase
- (setq key (downcase key)))
- (setq cur (assoc key retval))
- (if cur
- (setcdr cur (cons val (cdr cur)))
- (setq retval (cons (list key val) retval)))))
+ nil ; Grace
+ (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
+ (if downcase
+ (setq key (downcase key)))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
retval))
(defun gnus-url-unhex (x)
(if (> x ?9)
(if (>= x ?a)
- (+ 10 (- x ?a))
- (+ 10 (- x ?A)))
+ (+ 10 (- x ?a))
+ (+ 10 (- x ?A)))
(- x ?0)))
(defun gnus-url-unhex-string (str &optional allow-newlines)
forbidden in URL encoding."
(setq str (or str ""))
(let ((tmp "")
- (case-fold-search t))
+ (case-fold-search t))
(while (string-match "%[0-9a-f][0-9a-f]" str)
(let* ((start (match-beginning 0))
- (ch1 (gnus-url-unhex (elt str (+ start 1))))
- (code (+ (* 16 ch1)
- (gnus-url-unhex (elt str (+ start 2))))))
- (setq tmp (concat
- tmp (substring str 0 start)
- (cond
- (allow-newlines
- (char-to-string code))
- ((or (= code ?\n) (= code ?\r))
- " ")
- (t (char-to-string code))))
- str (substring str (match-end 0)))))
+ (ch1 (gnus-url-unhex (elt str (+ start 1))))
+ (code (+ (* 16 ch1)
+ (gnus-url-unhex (elt str (+ start 2))))))
+ (setq tmp (concat
+ tmp (substring str 0 start)
+ (cond
+ (allow-newlines
+ (char-to-string code))
+ ((or (= code ?\n) (= code ?\r))
+ " ")
+ (t (char-to-string code))))
+ str (substring str (match-end 0)))))
(setq tmp (concat tmp str))
tmp))
(setq url (substring url (match-beginning 1) nil)))
(let (to args subject func)
(if (string-match (regexp-quote "?") url)
- (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
- args (gnus-url-parse-query-string
- (substring url (match-end 0) nil) t))
+ (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
+ args (gnus-url-parse-query-string
+ (substring url (match-end 0) nil) t))
(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)
+ subject (cdr-safe (assoc "subject" args)))
+ (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)))
(string-match (car x) gnus-newsgroup-name))
(nconc gnus-decode-header-methods-cache
(list (cdr x))))))
- gnus-decode-header-methods))
+ gnus-decode-header-methods))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
(save-restriction
(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))))
(unless func
(error (format "Can't find the encrypt protocol %s" protocol)))
(if (equal gnus-newsgroup-name "nndraft:drafts")
- (error "Can't encrypt the article in group nndraft:drafts."))
+ (error "Can't encrypt the article in group nndraft:drafts"))
(if (equal gnus-newsgroup-name "nndraft:queue")
- (error "Don't encrypt the article in group nndraft:queue."))
+ (error "Don't encrypt the article in group nndraft:queue"))
(gnus-summary-iterate n
(save-excursion
(set-buffer gnus-summary-buffer)
(error "The current newsgroup does not support article encrypt"))
(gnus-summary-show-article t)
(setq references
- (or (mail-header-references gnus-current-headers) ""))
+ (or (mail-header-references gnus-current-headers) ""))
(set-buffer gnus-article-buffer)
(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))
(defvar gnus-mime-security-button-map
(let ((map (make-sparse-keymap)))
- ;; Not for Emacs 21: fixme better.
- ;;(set-keymap-parent map gnus-article-mode-map)
+ (unless (>= (string-to-number emacs-version) 21)
+ (set-keymap-parent map gnus-article-mode-map))
(define-key map gnus-mouse-2 'gnus-article-push-button)
(define-key map "\r" 'gnus-article-press-button)
map))
(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)))
(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)
+ buffer-read-only)
(forward-char -1)
(while (eq (get-text-property (point) 'gnus-line-format)
gnus-mime-security-button-line-format)
(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-mime-security-button-line-format)
+ 'gnus-line-format
+ gnus-mime-security-button-line-format)
(point-max)))
(gnus-insert-mime-security-button handle))
(if (gnus-buffer-live-p gnus-mime-security-details-buffer)
(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")
(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))
(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
- (cons (set-marker (make-marker)
- (point-min))
- (set-marker (make-marker)
- (point-max))))))
+ (mm-set-handle-multipart-parameter
+ handle 'gnus-region
+ (cons (set-marker (make-marker) (point-min))
+ (set-marker (make-marker) (point-max))))))
;;; @ for mime-view
projects / elisp / gnus.git- / blobdiff