-;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000 Free Software Foundation, Inc.
+;;; gnus-art.el --- article mode commands for Semi-gnus
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
-;; Keywords: news
+;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;; Katsumi Yamaoka <yamaoka@jpl.org>
+;; Keywords: mail, news, MIME
;; This file is part of GNU Emacs.
;;; Code:
(eval-when-compile (require 'cl))
+(eval-when-compile (require 'static))
+(require 'path-util)
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
-(require 'mm-bodies)
-(require 'mail-parse)
-(require 'mm-decode)
-(require 'mm-view)
+(require 'alist)
+(require 'mime-view)
(require 'wid-edit)
-(require 'mm-uu)
+
+;; Avoid byte-compile warnings.
+(eval-when-compile
+ (require 'mm-bodies)
+ (require 'mail-parse)
+ (require 'mm-decode)
+ (require 'mm-view)
+ (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."
"^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
"^Old-Received:" "^X-Pgp" "^X-Auth:" "^X-From-Line:"
"^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
- "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
+ "^MBOX-Line" "^Priority:" "^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:"
"^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."
:group 'gnus-article-hiding)
(defcustom gnus-visible-headers
- "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
+ "^From:\\|^Newsgroups:\\|^Subject:\\|^Date:\\|^Followup-To:\\|^Reply-To:\\|^Organization:\\|^Summary:\\|^Keywords:\\|^To:\\|^[BGF]?Cc:\\|^Posted-To:\\|^Mail-Copies-To:\\|^Mail-Followup-To:\\|^Apparently-To:\\|^Gnus-Warning:\\|^Resent-From:\\|^X-Sent:"
"*All headers that do not match this regexp will be hidden.
This variable can also be a list of regexp of headers to remain visible.
If this variable is non-nil, `gnus-ignored-headers' will be ignored."
(defcustom gnus-boring-article-headers '(empty followup-to reply-to)
"Headers that are only to be displayed if they have interesting data.
Possible values in this list are `empty', `newsgroups', `followup-to',
-`reply-to', `date', `long-to', and `many-to'."
+`to-address', `reply-to', `date', `long-to', and `many-to'."
:type '(set (const :tag "Headers with no content." empty)
(const :tag "Newsgroups with only one group." newsgroups)
+ (const :tag "To identical to to-address." to-address)
(const :tag "Followup-to identical to newsgroups." followup-to)
(const :tag "Reply-to identical to from." reply-to)
(const :tag "Date less than four days old." date)
;; non-graphical frames in a session.
;; gnus-xmas.el overrides this for XEmacs.
(defcustom gnus-article-x-face-command
- (if (and (fboundp 'image-type-available-p)
- (image-type-available-p 'xbm))
- 'gnus-article-display-xface
- (if gnus-article-compface-xbm
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -"
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
+ (cond
+ ((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))
+ 'gnus-article-display-xface)
+ ((and (not (featurep 'xemacs))
+ window-system
+ (module-installed-p 'x-face-mule))
+ 'x-face-mule-gnus-article-display-x-face)
+ (gnus-article-compface-xbm
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | display -")
+ (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 '(choice string
+ (function-item
+ :tag "x-face-decode-message-header (x-face-e21)"
+ x-face-decode-message-header)
(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)
+(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
"\\(\\s-\\|^\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-,;:\"]\\s-\\|[?!.]+\\s-\\|\\s)\\)")
,@(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.
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."
+ :version "21.1"
:group 'gnus-article-emphasis
:type 'regexp)
(cons :value ("" "") regexp (repeat string))
(sexp :value nil))))
+(defcustom gnus-article-display-method-for-mime
+ 'gnus-article-display-mime-message
+ "Function to display a MIME message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
+(defcustom gnus-article-display-method-for-traditional
+ 'gnus-article-display-traditional-message
+ "*Function to display a traditional message.
+The function is called from the article buffer."
+ :group 'gnus-article-mime
+ :type 'function)
+
(defcustom gnus-page-delimiter "^\^L"
"*Regexp describing what to use as article page delimiters.
The default value is \"^\^L\", which is a form linefeed at the
: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
(item :tag "skip" nil)
(face :value default)))))
-(defcustom gnus-article-decode-hook
- '(article-decode-charset article-decode-encoded-words)
+(defcustom gnus-article-decode-hook nil
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
(defcustom gnus-ignored-mime-types nil
"List of MIME types that should be ignored by Gnus."
+ :version "21.1"
:group 'gnus-article-mime
:type '(repeat regexp))
(defcustom gnus-unbuttonized-mime-types '(".*/.*")
"List of MIME types that should not be given buttons when rendered inline."
+ :version "21.1"
:group 'gnus-article-mime
:type '(repeat regexp))
(defcustom gnus-mime-multipart-functions nil
"An alist of MIME types to functions to display them."
+ :version "21.1"
:group 'gnus-article-mime
:type 'alist)
When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
either replace the old \"Date:\" header (if this variable is nil), or
be added below it (otherwise)."
+ :version "21.1"
: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
+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)))
(defcustom gnus-mime-action-alist
'(("save to file" . gnus-mime-save-part)
+ ("save and strip" . gnus-mime-save-part-and-strip)
("display as text" . gnus-mime-inline-part)
("view the part" . gnus-mime-view-part)
("pipe to command" . gnus-mime-pipe-part)
("toggle display" . gnus-article-press-button)
+ ("toggle display" . gnus-article-view-part-as-charset)
("view as type" . gnus-mime-view-part-as-type)
("internalize type" . gnus-mime-internalize-part)
("externalize type" . gnus-mime-externalize-part))
:type '(repeat (cons (string :tag "name")
(function))))
+(defcustom gnus-mime-action-alist
+ '(("save to file" . gnus-mime-save-part)
+ ("display as text" . gnus-mime-inline-part)
+ ("view the part" . gnus-mime-view-part)
+ ("pipe to command" . gnus-mime-pipe-part)
+ ("toggle display" . gnus-article-press-button)
+ ("view as type" . gnus-mime-view-part-as-type)
+ ("internalize type" . gnus-mime-internalize-part)
+ ("externalize type" . gnus-mime-externalize-part))
+ "An alist of actions that run on the MIME attachment."
+ :version "21.1"
+ :group 'gnus-article-mime
+ :type '(repeat (cons (string :tag "name")
+ (function))))
+
;;;
;;; The treatment variables
;;;
(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")))
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
-(defcustom gnus-treat-emphasize
+(defcustom gnus-treat-emphasize
(and (or window-system
(featurep 'xemacs)
(>= (string-to-number emacs-version) 21))
: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-custom)
+(defcustom gnus-treat-hide-citation-maybe nil
+ "Hide cited text.
+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-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."
+ :version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
: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.
"Display the date in the ISO8601 format.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
+ :version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-head-custom)
"Strip the X-No-Archive header line from the beginning of the body.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
+ :version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
:type gnus-article-treat-custom)
(put 'gnus-treat-overstrike 'highlight t)
-(defcustom gnus-treat-display-xface
+(defcustom gnus-treat-display-xface
(and (or (and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm)
(string-match "^0x" (shell-command-to-string "uncompface")))
- (and (featurep 'xemacs) (featurep 'xface)))
+ (and (featurep 'xemacs) (featurep 'xface))
+ (eq 'x-face-mule-gnus-article-display-x-face
+ gnus-article-x-face-command))
'head)
"Display X-Face headers.
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)
-(defcustom gnus-treat-display-smileys
+(defcustom gnus-treat-display-smileys
(if (or (and (featurep 'xemacs)
(featurep 'xpm))
(and (fboundp 'image-type-available-p)
- (image-type-available-p 'pbm)))
- t nil)
+ (image-type-available-p 'pbm))
+ (and (not (featurep 'xemacs))
+ window-system
+ (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)
"Capitalize sentence-starting words.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
+ :version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
"Play sounds.
Valid values are nil, t, `head', `last', an integer or a predicate.
See the manual for details."
+ :version "21.1"
:group 'gnus-article-treat
:type gnus-article-treat-custom)
+(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."
+ :version "21.1"
+ :group 'gnus-article-treat
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-x-pgp-sig nil
+ "Verify X-PGP-Sig.
+To automatically treat X-PGP-Sig, set it to head.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See the manual for details."
:group 'gnus-article-treat
+ :group 'mime-security
:type gnus-article-treat-custom)
+(defvar gnus-article-encrypt-protocol-alist
+ '(("PGP" . mml2015-self-encrypt)))
+
+;; Set to nil if more than one protocol added to
+;; gnus-article-encrypt-protocol-alist.
+(defcustom gnus-article-encrypt-protocol "PGP"
+ "The protocol used for encrypt articles.
+It is a string, such as \"PGP\". If nil, ask user."
+ :type 'string
+ :group 'mime-security)
+
;;; 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-strip-banner gnus-article-strip-banner)
+ `((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-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-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-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)))
- (modify-syntax-entry ?- "w" table)
+ ;; This causes the citation match run O(2^n).
+ ;; (modify-syntax-entry ?- "w" table)
(modify-syntax-entry ?> ")" table)
(modify-syntax-entry ?< "(" table)
table)
(defun article-hide-headers (&optional arg delete)
"Hide unwanted headers and possibly sort them as well."
- (interactive)
- ;; This function might be inhibited.
+ (interactive (gnus-article-hidden-arg))
+ ;; Lars said that this function might be inhibited.
+ (if (gnus-article-check-hidden-text 'headers arg)
+ (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)))
(unless gnus-inhibit-hiding
(save-excursion
(save-restriction
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(case-fold-search t)
(max (1+ (length gnus-sorted-header-list)))
(ignored (when (not gnus-visible-headers)
(while (looking-at "From ")
(forward-line 1))
(unless (bobp)
- (delete-region (point-min) (point)))
+ (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
(message-sort-headers-1)
(when (setq beg (text-property-any
(point-min) (point-max) 'message-rank (+ 2 max)))
- ;; We delete the unwanted headers.
+ ;; We delete or make invisible the unwanted headers.
(push 'headers gnus-article-wash-types)
- (add-text-properties (point-min) (+ 5 (point-min))
- '(article-type headers dummy-invisible t))
- (delete-region beg (point-max))))))))
+ (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)
"Toggle hiding of headers that aren't very interesting.
'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
+ (gnus-string-equal
(nth 1 (mail-extract-address-components from))
(nth 1 (mail-extract-address-components reply-to)))))
(gnus-article-hide-header "reply-to"))))
(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))
+ (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 (featurep '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.")
(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."
(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: " 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))
format (and ctl (mail-content-type-get ctl 'format)))
(when cte
(setq cte (mail-header-strip cte)))
- (if (and ctl (not (string-match "/" (car ctl))))
+ (if (and ctl (not (string-match "/" (car ctl))))
(setq ctl nil))
(goto-char (point-max)))
(forward-line 1)
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
- (let ((inhibit-point-motion-hooks t)
- (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))
- buffer-read-only)
- (save-restriction
- (article-narrow-to-head)
- (funcall gnus-decode-header-function (point-min) (point-max)))))
+ (let (buffer-read-only)
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset)))
+ (mime-decode-header-in-buffer charset)
+ )))
(defun article-de-quoted-unreadable (&optional force)
"Translate a quoted-printable-encoded article.
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(setq type
(gnus-fetch-field "content-transfer-encoding"))
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (unless charset
(setq charset gnus-newsgroup-charset))
(when (or force
(and type (let ((case-fold-search t))
(if (gnus-buffer-live-p gnus-original-article-buffer)
(with-current-buffer gnus-original-article-buffer
(let* ((ct (gnus-fetch-field "content-type"))
- (ctl (and ct
+ (ctl (and ct
(ignore-errors
(mail-header-parse-content-type ct)))))
(setq charset (and ctl
(mail-content-type-get ctl 'charset)))
(if (stringp charset)
(setq charset (intern (downcase charset)))))))
- (unless charset
+ (unless charset
(setq charset gnus-newsgroup-charset))
(article-goto-body)
(save-window-excursion
"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
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."
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)))))
should replace the \"Date:\" one, or should be added below it."
(interactive (list 'ut t))
(let* ((header (or header
+ (and (eq 1 (point-min))
+ (mail-header-date (save-excursion
+ (set-buffer gnus-summary-buffer)
+ gnus-current-headers)))
(message-fetch-field "date")
""))
- (tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
- (date-regexp
- (cond
- ((not gnus-article-date-lapsed-new-header)
- tdate-regexp)
- ((eq type 'lapsed)
- "^X-Sent:[ \t]")
- (t
- "^Date:[ \t]")))
(date (if (vectorp header) (mail-header-date header)
header))
(inhibit-point-motion-hooks t)
- pos
- bface eface)
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (when (re-search-forward tdate-regexp 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))
- (forward-line 1))
- (when (and date (not (string= date "")))
- (goto-char (point-min))
+ bface eface date-pos)
+ (when (and date (not (string= date "")))
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (when (or (and (eq type 'lapsed)
+ gnus-article-date-lapsed-new-header
+ ;; Attempt to get the face of X-Sent first.
+ (re-search-forward "^X-Sent:[ \t]" nil t))
+ (re-search-forward "^Date:[ \t]" nil t)
+ ;; 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 Date headers.
- (while (re-search-forward date-regexp nil t)
- (if pos
- (delete-region (progn (beginning-of-line) (point))
- (progn (forward-line 1) (point)))
- (delete-region (progn (beginning-of-line) (point))
- (progn (end-of-line) (point)))
- (setq pos (point))))
- (when (and (not pos) (re-search-forward tdate-regexp nil t))
- (forward-line 1))
- (if pos (goto-char pos))
- (insert (article-make-date-line date (or type 'ut)))
- (when (not pos)
- (insert "\n")
- (forward-line -1))
+ ;; Delete any old X-Sent headers.
+ (when (setq date-pos
+ (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))))
+ (goto-char (point-min))
+ ;; Delete any old Date headers.
+ (while (re-search-forward "^Date:[ \t]" nil t)
+ (unless date-pos
+ (setq date-pos (match-beginning 0)))
+ (unless (and (eq type 'lapsed)
+ gnus-article-date-lapsed-new-header)
+ (delete-region (match-beginning 0)
+ (progn (message-next-header) (point)))))
+ (if date-pos
+ (progn
+ (goto-char date-pos)
+ (unless (bolp)
+ ;; Possibly, Date has been deleted.
+ (insert "\n"))
+ (when (and (eq type 'lapsed)
+ gnus-article-date-lapsed-new-header
+ (looking-at "Date:"))
+ (forward-line 1)))
+ (goto-char (point-min)))
+ (insert (article-make-date-line date type))
+ (when (eq type 'lapsed)
+ (put-text-property (gnus-point-at-bol) (point)
+ 'article-date-lapsed t))
+ (insert "\n")
+ (forward-line -1)
;; Do highlighting.
- (beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
(put-text-property (match-beginning 1) (1+ (match-end 1))
'original-date date)
(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
"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-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)
(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
+ (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))
highlight)
(copy-sequence highlight-words)
(if gnus-newsgroup-name
- (copy-sequence (gnus-group-find-parameter
+ (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)
+(eval-when-compile
+ (defvar gnus-summary-article-menu)
+ (defvar gnus-summary-post-menu))
;;; Saving functions.
(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 "news" (gnus-newsgroup-directory-form newsgroup)))
gnus-article-save-directory)))
+(defun gnus-sender-save-name (newsgroup headers &optional last-file)
+ "Generate file name from sender."
+ (let ((from (mail-header-from headers)))
+ (expand-file-name
+ (if (and from (string-match "\\([^ <]+\\)@" from))
+ (match-string 1 from)
+ "nobody")
+ gnus-article-save-directory)))
+
+(defun article-verify-x-pgp-sig ()
+ "Verify X-PGP-Sig."
+ (interactive)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (let ((sig (with-current-buffer gnus-original-article-buffer
+ (gnus-fetch-field "X-PGP-Sig")))
+ items info headers)
+ (when (and sig
+ mml2015-use
+ (mml2015-clear-verify-function))
+ (with-temp-buffer
+ (insert-buffer gnus-original-article-buffer)
+ (setq items (split-string sig))
+ (message-narrow-to-head)
+ (let ((inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ ;; Don't verify multiple headers.
+ (setq headers (mapconcat (lambda (header)
+ (concat header ": "
+ (mail-fetch-field header) "\n"))
+ (split-string (nth 1 items) ",") "")))
+ (delete-region (point-min) (point-max))
+ (insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
+ (insert "X-Signed-Headers: " (nth 1 items) "\n")
+ (insert headers)
+ (widen)
+ (forward-line)
+ (while (not (eobp))
+ (if (looking-at "^-")
+ (insert "- "))
+ (forward-line))
+ (insert "\n-----BEGIN PGP SIGNATURE-----\n")
+ (insert "Version: " (car items) "\n\n")
+ (insert (mapconcat 'identity (cddr items) "\n"))
+ (insert "\n-----END PGP SIGNATURE-----\n")
+ (let ((mm-security-handle (list (format "multipart/signed"))))
+ (mml2015-clean-buffer)
+ (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
+ mm-security-handle 'gnus-details)
+ (mm-handle-multipart-ctl-parameter
+ mm-security-handle 'gnus-info)))))
+ (when info
+ (let (buffer-read-only bface eface)
+ (save-restriction
+ (message-narrow-to-head)
+ (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))
+ (message-remove-header "X-Gnus-PGP-Verify")
+ (if (re-search-forward "^X-PGP-Sig:" nil t)
+ (forward-line)
+ (goto-char (point-max)))
+ (narrow-to-region (point) (point))
+ (insert "X-Gnus-PGP-Verify: " info "\n")
+ (goto-char (point-min))
+ (forward-line)
+ (while (not (eobp))
+ (if (not (looking-at "^[ \t]"))
+ (insert " "))
+ (forward-line))
+ ;; Do highlighting.
+ (goto-char (point-min))
+ (when (looking-at "\\([^:]+\\): *")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-end 0) (point-max)
+ 'face eface)))))))))
+
(eval-and-compile
(mapcar
(lambda (func)
(call-interactively ',afunc)
(apply ',afunc args))))))))
'(article-hide-headers
+ article-verify-x-pgp-sig
article-hide-boring-headers
+ article-toggle-headers
article-treat-overstrike
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
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))))
\f
;;;
;;; Gnus article mode
(put 'gnus-article-mode 'mode-class 'special)
-(set-keymap-parent gnus-article-mode-map widget-keymap)
-
(gnus-define-keys gnus-article-mode-map
" " gnus-article-goto-next-page
"\177" gnus-article-goto-prev-page
"\M-^" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
-(substitute-key-definition
- 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map)
+;; Define almost undefined keys to `gnus-article-read-summary-keys'.
+(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
(easy-menu-define
gnus-article-treatment-menu gnus-article-mode-map ""
+ ;; Fixme: this should use :active (and maybe :visible).
'("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 quoted-unreadable" gnus-article-de-quoted-unreadable t]
- ["Remove base64" gnus-article-de-base64-unreadable t]
- ["Treat html" gnus-article-wash-html 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)))
+;; Fixme: do something for the Emacs tool bar in Article mode a la
+;; Summary.
+
(defun gnus-article-mode ()
"Major mode for displaying an article.
\\[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)
(make-local-variable 'minor-mode-alist)
+ (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)
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-mime-handle-alist)
(make-local-variable 'gnus-article-wash-types)
+ (make-local-variable 'gnus-article-charset)
+ (make-local-variable 'gnus-article-ignored-charsets)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t)
(set-syntax-table gnus-article-mode-syntax-table)
- (mm-enable-multibyte)
(gnus-run-hooks 'gnus-article-mode-hook))
(defun gnus-article-setup-buffer ()
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
- (mm-enable-multibyte)
+ (set-buffer-multibyte nil)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(save-excursion
(set-buffer name)
- (when gnus-article-mime-handles
- (mm-destroy-parts gnus-article-mime-handles)
- (setq gnus-article-mime-handles nil))
- ;; Set it to nil in article-buffer!
- (setq gnus-article-mime-handle-alist nil)
(buffer-disable-undo)
(setq buffer-read-only t)
(unless (eq major-mode 'gnus-article-mode)
(forward-line line)
(point)))))
+;;; @@ article filters
+;;;
+
+(defun gnus-article-display-mime-message ()
+ "Article display method for MIME message."
+ ;; called from `gnus-original-article-buffer'.
+ (let (charset all-headers)
+ (with-current-buffer gnus-summary-buffer
+ (setq charset default-mime-charset
+ all-headers gnus-have-all-headers))
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset)
+ (with-current-buffer (get-buffer-create gnus-article-buffer)
+ (make-local-variable 'default-mime-charset)
+ (setq default-mime-charset charset))
+ (mime-display-message mime-message-structure
+ gnus-article-buffer nil gnus-article-mode-map)
+ (when all-headers
+ (gnus-article-hide-headers nil -1)))
+ (run-hooks 'gnus-mime-article-prepare-hook))
+
+(defun gnus-article-display-traditional-message ()
+ "Article display method for traditional message."
+ (set-buffer gnus-article-buffer)
+ (let (buffer-read-only)
+ (erase-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)))
+
+(defun gnus-article-make-full-mail-header (&optional number charset)
+ "Create a new mail header structure in a raw article buffer."
+ (unless (and number charset)
+ (save-current-buffer
+ (set-buffer gnus-summary-buffer)
+ (unless number
+ (setq number (or (cdr gnus-article-current) 0)))
+ (unless charset
+ (setq charset (or default-mime-charset 'x-ctext)))))
+ (goto-char (point-min))
+ (let ((header-end (if (search-forward "\n\n" nil t)
+ (1- (point))
+ (goto-char (point-max))))
+ (chars (- (point-max) (point)))
+ (lines (count-lines (point) (point-max)))
+ (default-mime-charset charset)
+ xref)
+ (narrow-to-region (point-min) header-end)
+ (setq xref (std11-fetch-field "xref"))
+ (prog1
+ (make-full-mail-header
+ number
+ (std11-fetch-field "subject")
+ (std11-fetch-field "from")
+ (std11-fetch-field "date")
+ (std11-fetch-field "message-id")
+ (std11-fetch-field "references")
+ chars
+ lines
+ (when xref (concat "Xref: " xref)))
+ (widen))))
+
(defun gnus-article-prepare (article &optional all-headers header)
"Prepare ARTICLE in article mode buffer.
ARTICLE should either be an article number or a Message-ID.
(gnus-configure-windows 'article)
t))))))
+(defun gnus-article-prepare-mime-display (&optional number)
+ (goto-char (point-min))
+ (when (re-search-forward "^[^\t ]+:" nil t)
+ (goto-char (match-beginning 0)))
+ (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 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."
- ;; Hooks for getting information from the article.
- ;; This hook must be called before being narrowed.
(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)
- (gnus-run-hooks 'gnus-tmp-internal-hook)
- (when gnus-display-mime-function
- (funcall gnus-display-mime-function))
- (gnus-run-hooks 'gnus-article-prepare-hook)))
+ (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.
+ (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))
+ (save-restriction
+ (widen)
+ (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)))
+ (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)
+ default-mime-charset)))
;;;
;;; Gnus MIME viewing functions
'((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-view-part-as-charset "C" "View As charset...")
(gnus-mime-save-part "o" "Save...")
+ (gnus-mime-save-part-and-strip "\C-o" "Save and Strip")
(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-action-on-part "." "Take action on the part")))
(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))
+ 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)))
- (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
- (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)))))
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
+ (when handles
+ (mm-remove-parts 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)))))
+
+(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 param)
+ (if (mm-multiple-handles gnus-article-mime-handles)
+ (error "This function is not implemented."))
+ (setq file (and data (mm-save-part data)))
+ (when file
+ (with-current-buffer (mm-handle-buffer data)
+ (erase-buffer)
+ (insert "Content-Type: " (mm-handle-media-type data))
+ (mml-insert-parameter-string (cdr (mm-handle-type data))
+ '(charset))
+ (insert "\n")
+ (insert "Content-ID: " (message-make-message-id) "\n")
+ (insert "Content-Transfer-Encoding: binary\n")
+ (insert "\n"))
+ (setcdr data
+ (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 (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
+ (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))
+ (gnus-summary-edit-article-done
+ ,(or (mail-header-references gnus-current-headers) "")
+ ,(gnus-group-read-only-p)
+ ,gnus-summary-buffer no-highlight))))))
(defun gnus-mime-save-part ()
"Save the MIME part under point."
(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)
+ (mm-handle-cache handle)
+ (mm-handle-id handle)))
+ (setq gnus-article-mime-handles
+ (mm-merge-handles gnus-article-mime-handles handle))
+ (gnus-mm-display-part handle))))
+
(defun gnus-mime-copy-part (&optional handle)
"Put the the MIME part under point into a new buffer."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(contents (and handle (mm-get-part handle)))
- (base (and handle
+ (base (and handle
(file-name-nondirectory
(or
(mail-content-type-get (mm-handle-type handle) 'name)
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))
(setq charset
- (or (cdr (assq arg
+ (or (cdr (assq arg
gnus-summary-show-article-charset-alist))
(read-coding-system "Charset: ")))))
(forward-line 2)
(mm-insert-inline handle
- (if (and charset
- (setq charset (mm-charset-to-coding-system
+ (if (and charset
+ (setq charset (mm-charset-to-coding-system
charset))
(not (eq charset 'ascii)))
(mm-decode-coding-string contents charset)
(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-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
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-copy-part))
+(defun gnus-article-view-part-as-charset (n)
+ "Copy MIME part N, which is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
+
(defun gnus-article-externalize-part (n)
"View MIME part N externally, which is the numerical prefix."
(interactive "p")
(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
'name)
(mail-content-type-get (mm-handle-disposition handle)
'filename)
+ (mail-content-type-get (mm-handle-type handle)
+ 'url)
""))
(gnus-tmp-type (mm-handle-media-type handle))
(gnus-tmp-description
(setq b (point))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
- `(local-map ,gnus-mime-button-map
- keymap ,gnus-mime-button-map
- gnus-callback gnus-mm-display-part
- gnus-part ,gnus-tmp-id
- article-type annotation
- gnus-data ,handle))
+ `(keymap ,gnus-mime-button-map
+ ,@(if (>= (string-to-number emacs-version) 21)
+ nil
+ (list 'local-map gnus-mime-button-map))
+ gnus-callback gnus-mm-display-part
+ gnus-part ,gnus-tmp-id
+ article-type annotation
+ gnus-data ,handle))
(setq e (point))
(widget-convert-button
'link b e
(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
+ ;;;!!! included images, so we just display it as a mixed multipart.
+ ;;(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))
+ (gnus-mime-display-security handle))
+ ((equal (car handle) "multipart/encrypted")
+ (or (memq 'encrypted gnus-article-wash-types)
+ (push 'encrypted gnus-article-wash-types))
+ (gnus-mime-display-security handle))
;; Other multiparts are handled like multipart/mixed.
(t
(gnus-mime-display-mixed (cdr handle)))))
;(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)))))))))
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',not-pref ',begend ,id))
- local-map ,gnus-mime-button-map
+ ,@(if (>= (string-to-number emacs-version) 21)
+ nil ;; XEmacs doesn't care
+ (list 'local-map gnus-mime-button-map))
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
keymap ,gnus-mime-button-map
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',handle ',begend ,id))
- local-map ,gnus-mime-button-map
+ ,@(if (>= (string-to-number emacs-version) 21)
+ nil ;; XEmacs doesn't care
+ (list 'local-map gnus-mime-button-map))
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
keymap ,gnus-mime-button-map
(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)
(boring (memq 'boring-headers gnus-article-wash-types))
(pgp (memq 'pgp gnus-article-wash-types))
(pem (memq 'pem gnus-article-wash-types))
+ (signed (memq 'signed gnus-article-wash-types))
+ (encrypted (memq 'encrypted 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"
+ (format "%c%c%c%c%c%c%c"
(if cite ?c ? )
(if (or headers boring) ?h ? )
- (if (or pgp pem) ?p ? )
+ (if (or pgp pem signed encrypted) ?p ? )
(if signature ?s ? )
(if overstrike ?o ? )
+ (if gnus-show-mime ?m ? )
(if emphasis ?e ? )))))
(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (mm-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)
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."
(defun gnus-article-check-buffer ()
"Beep if not in an article buffer."
- (unless (equal major-mode 'gnus-article-mode)
+ (unless (eq (get-buffer gnus-article-buffer) (current-buffer))
(error "Command invoked outside of a Gnus article buffer")))
(defun gnus-article-read-summary-keys (&optional arg key not-restore-window)
(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"))
(set-buffer gnus-article-current-summary)
(let (gnus-pick-mode)
(push (or key last-command-event) unread-command-events)
- (setq keys (if (featurep 'xemacs)
+ (setq keys (static-if (featurep 'xemacs)
(events-to-keys (read-key-sequence nil))
(read-key-sequence nil)))))
-
(message "")
(if (or (member keys nosaves)
(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)))
(assq article gnus-newsgroup-reads)))
gnus-canceled-mark))
nil)
- ;; We first check `gnus-original-article-buffer'.
- ((and (get-buffer gnus-original-article-buffer)
- (numberp article)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
- (and (equal (car gnus-original-article) group)
- (eq (cdr gnus-original-article) article))))
- (insert-buffer-substring gnus-original-article-buffer)
- 'article)
;; Check the backlog.
((and gnus-keep-backlog
(gnus-backlog-request-article group article (current-buffer)))
((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
(if (get-buffer gnus-original-article-buffer)
(set-buffer gnus-original-article-buffer)
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (set-buffer-multibyte nil)
(buffer-disable-undo)
(setq major-mode 'gnus-original-article-mode)
(setq buffer-read-only t))
:group 'gnus-article-various
:type 'hook)
+(defcustom gnus-article-edit-article-setup-function
+ 'gnus-article-mime-edit-article-setup
+ "Function called to setup an editing article buffer."
+ :group 'gnus-article-various
+ :type 'function)
+
(defvar gnus-article-edit-done-function nil)
(defvar gnus-article-edit-mode-map nil)
(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)
- (gnus-message 6 "C-c C-c to end edits")))
+ (when gnus-article-edit-article-setup-function
+ (funcall gnus-article-edit-article-setup-function))
+ (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."
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
(start (window-start)))
- (gnus-article-edit-exit)
+ (remove-hook 'gnus-article-mode-hook
+ 'gnus-article-mime-edit-article-unwind)
+ ;; 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."
(query-replace-regexp "\\([.!?][])}]* \\)\\([[({A-Z]\\)" "\\1 \\2"))))
;;;
+;;; Article editing with MIME-Edit
+;;;
+
+(defcustom gnus-article-mime-edit-article-setup-hook nil
+ "Hook run after setting up a MIME editing article buffer."
+ :group 'gnus-article-various
+ :type 'hook)
+
+(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 (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (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
+after replacing with the original article."
+ (setq gnus-show-mime t)
+ (setq gnus-article-edit-done-function
+ `(lambda (&rest args)
+ (when mime-edit-mode-flag
+ (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 "")))
+ (apply ,gnus-article-edit-done-function args)
+ (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-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)
+ (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)
+ (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
+ (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 "")))
+ (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)
(when fun
(funcall fun data))))
+(defun gnus-article-prev-button (n)
+ "Move point to N buttons backward.
+If N is negative, move forward instead."
+ (interactive "p")
+ (gnus-article-next-button (- n)))
+
+(defun gnus-article-next-button (n)
+ "Move point to N buttons forward.
+If N is negative, move backward instead."
+ (interactive "p")
+ (let ((function (if (< n 0) 'previous-single-property-change
+ 'next-single-property-change))
+ (inhibit-point-motion-hooks t)
+ (backward (< n 0))
+ (limit (if (< n 0) (point-min) (point-max))))
+ (setq n (abs n))
+ (while (and (not (= limit (point)))
+ (> n 0))
+ ;; Skip past the current button.
+ (when (get-text-property (point) 'gnus-callback)
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Go to the next (or previous) button.
+ (gnus-goto-char (funcall function (point) 'gnus-callback nil limit))
+ ;; Put point at the start of the button.
+ (when (and backward (not (get-text-property (point) 'gnus-callback)))
+ (goto-char (funcall function (point) 'gnus-callback nil limit)))
+ ;; Skip past intangible buttons.
+ (when (get-text-property (point) 'intangible)
+ (incf n))
+ (decf n))
+ (unless (zerop n)
+ (gnus-message 5 "No more buttons"))
+ n))
+
(defun gnus-article-highlight (&optional force)
"Highlight current article.
This function calls `gnus-article-highlight-headers',
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."
(list 'gnus-callback fun)
(and data (list 'gnus-data data))))
(widget-convert-button 'link from to :action 'gnus-widget-press-button
- :button-keymap gnus-widget-button-keymap))
+ ;; Quote `:button-keymap' for Mule 2.3
+ ;; but it won't work.
+ ':button-keymap gnus-widget-button-keymap))
;;; Internal functions:
(save-excursion
(set-buffer gnus-article-buffer)
(let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t))
- (if (text-property-any end (point-max) 'article-type 'signature)
+ (inhibit-point-motion-hooks t)
+ (limit (next-single-property-change end 'mime-view-entity
+ nil (point-max))))
+ (if (text-property-any end limit 'article-type 'signature)
(gnus-remove-text-properties-when
- 'article-type 'signature end (point-max)
+ 'article-type 'signature end limit
(cons 'article-type (cons 'signature
gnus-hidden-properties)))
(gnus-add-text-properties-when
- 'article-type nil end (point-max)
+ 'article-type nil end limit
(cons 'article-type (cons 'signature
gnus-hidden-properties)))))))
(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 to (gnus-url-unhex-string url)))
(setq args (cons (list "to" to) args)
subject (cdr-safe (assoc "subject" args)))
- (message-mail)
+ (gnus-msg-mail)
(while args
(setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
(if (fboundp func)
(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)
-
(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)))
+
;;; Next/prev buttons in the article buffer.
(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
(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))
(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."
(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
- (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))
- (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.
(eval-when-compile
(equal (car val) type))
(t
(error "%S is not a valid predicate" pred)))))
+ ((eq val 'mime)
+ gnus-show-mime)
(condition
(eq condition val))
((eq val t)
(t
(error "%S is not a valid value" val))))
+(defun gnus-article-encrypt-body (protocol &optional n)
+ "Encrypt the article body."
+ (interactive
+ (list
+ (or gnus-article-encrypt-protocol
+ (completing-read "Encrypt protocol: "
+ 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."))
+ (if (equal gnus-newsgroup-name "nndraft:queue")
+ (error "Don't encrypt the article in group nndraft:queue."))
+ (gnus-summary-iterate n
+ (save-excursion
+ (set-buffer gnus-summary-buffer)
+ (let ((mail-parse-charset gnus-newsgroup-charset)
+ (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets)
+ (summary-buffer gnus-summary-buffer)
+ references point)
+ (gnus-set-global-variables)
+ (when (gnus-group-read-only-p)
+ (error "The current newsgroup does not support article encrypt"))
+ (gnus-summary-show-article t)
+ (setq references
+ (or (mail-header-references gnus-current-headers) ""))
+ (set-buffer gnus-article-buffer)
+ (let* ((buffer-read-only nil)
+ (headers
+ (mapcar (lambda (field)
+ (and (save-restriction
+ (message-narrow-to-head)
+ (goto-char (point-min))
+ (search-forward field nil t))
+ (prog2
+ (message-narrow-to-field)
+ (buffer-substring (point-min) (point-max))
+ (delete-region (point-min) (point-max))
+ (widen))))
+ '("Content-Type:" "Content-Transfer-Encoding:"
+ "Content-Disposition:"))))
+ (message-narrow-to-head)
+ (message-remove-header "MIME-Version")
+ (goto-char (point-max))
+ (setq point (point))
+ (insert (apply 'concat headers))
+ (widen)
+ (narrow-to-region point (point-max))
+ (let ((message-options message-options))
+ (message-options-set 'message-sender user-mail-address)
+ (message-options-set 'message-recipients user-mail-address)
+ (message-options-set 'message-sign-encrypt 'not)
+ (funcall func))
+ (goto-char (point-min))
+ (insert "MIME-Version: 1.0\n")
+ (widen)
+ (gnus-summary-edit-article-done
+ references nil summary-buffer t))
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ (save-excursion
+ (when (get-buffer gnus-original-article-buffer)
+ (set-buffer gnus-original-article-buffer)
+ (setq gnus-original-article nil)))
+ (when gnus-use-cache
+ (gnus-cache-update-article
+ (car gnus-article-current) (cdr gnus-article-current))))))))
+
+(defvar gnus-mime-security-button-line-format "%{%([[%t:%i]%D]%)%}\n"
+ "The following specs can be used:
+%t The security MIME type
+%i Additional info
+%d Details
+%D Details if button is pressed")
+
+(defvar gnus-mime-security-button-end-line-format "%{%([[End of %t]%D]%)%}\n"
+ "The following specs can be used:
+%t The security MIME type
+%i Additional info
+%d Details
+%D Details if button is pressed")
+
+(defvar gnus-mime-security-button-line-format-alist
+ '((?t gnus-tmp-type ?s)
+ (?i gnus-tmp-info ?s)
+ (?d gnus-tmp-details ?s)
+ (?D gnus-tmp-pressed-details ?s)))
+
+(defvar gnus-mime-security-button-map
+ (let ((map (make-sparse-keymap)))
+ (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))
+
+(defvar gnus-mime-security-details-buffer nil)
+
+(defvar gnus-mime-security-button-pressed nil)
+
+(defvar gnus-mime-security-show-details-inline t
+ "If non-nil, show details in the article buffer.")
+
+(defun gnus-mime-security-verify-or-decrypt (handle)
+ (mm-remove-parts (cdr handle))
+ (let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
+ buffer-read-only)
+ (when region
+ (delete-region (car region) (cdr region))
+ (set-marker (car region) nil)
+ (set-marker (cdr region) nil)))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (let ((point (point))
+ buffer-read-only)
+ (gnus-mime-display-security handle)
+ (goto-char point)))
+
+(defun gnus-mime-security-show-details (handle)
+ (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
+ (if details
+ (if gnus-mime-security-show-details-inline
+ (let ((gnus-mime-security-button-pressed t)
+ (gnus-mime-security-button-line-format
+ (get-text-property (point) 'gnus-line-format))
+ 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
+ (point) (point-max)
+ '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)
+ (with-current-buffer gnus-mime-security-details-buffer
+ (erase-buffer)
+ t)
+ (setq gnus-mime-security-details-buffer
+ (gnus-get-buffer-create "*MIME Security Details*")))
+ (with-current-buffer gnus-mime-security-details-buffer
+ (insert details)
+ (goto-char (point-min)))
+ (pop-to-buffer gnus-mime-security-details-buffer))
+ (gnus-message 5 "No details."))))
+
+(defun gnus-mime-security-press-button (handle)
+ (if (mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ (gnus-mime-security-show-details handle)
+ (gnus-mime-security-verify-or-decrypt handle)))
+
+(defun gnus-insert-mime-security-button (handle &optional displayed)
+ (let* ((protocol (mm-handle-multipart-ctl-parameter handle 'protocol))
+ (gnus-tmp-type
+ (concat
+ (or (nth 2 (assoc protocol mm-verify-function-alist))
+ (nth 2 (assoc protocol mm-decrypt-function-alist))
+ "Unknown")
+ (if (equal (car handle) "multipart/signed")
+ " Signed" " Encrypted")
+ " Part"))
+ (gnus-tmp-info
+ (or (mm-handle-multipart-ctl-parameter handle 'gnus-info)
+ "Undecided"))
+ (gnus-tmp-details
+ (mm-handle-multipart-ctl-parameter handle 'gnus-details))
+ gnus-tmp-pressed-details
+ b e)
+ (setq gnus-tmp-details
+ (if gnus-tmp-details
+ (concat "\n" gnus-tmp-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-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
+ article-type annotation
+ gnus-data ,handle))
+ (setq e (point))
+ (widget-convert-button
+ 'link b e
+ :mime-handle handle
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-mime-security-button-map
+ :help-echo
+ (lambda (widget/window &optional overlay pos)
+ ;; Needed to properly clear the message due to a bug in
+ ;; wid-edit (XEmacs only).
+ (if (boundp 'help-echo-owns-message)
+ (setq help-echo-owns-message t))
+ (format
+ "%S: show detail"
+ (aref gnus-mouse-2 0))))))
+
+(defun gnus-mime-display-security (handle)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-insert-mime-security-button handle)
+ (gnus-mime-display-mixed (cdr handle))
+ (unless (bolp)
+ (insert "\n"))
+ (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))))))
+
+
+;;; @ for mime-view
+;;;
+
+(defun gnus-article-header-presentation-method (entity situation)
+ (mime-insert-header entity)
+ )
+
+(set-alist 'mime-header-presentation-method-alist
+ 'gnus-original-article-mode
+ #'gnus-article-header-presentation-method)
+
+(defun gnus-mime-preview-quitting-method ()
+ (mime-preview-kill-buffer)
+ (delete-other-windows)
+ (gnus-article-show-summary)
+ (gnus-summary-select-article gnus-show-all-headers t))
+
+(set-alist 'mime-preview-quitting-method-alist
+ 'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
+
+(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 ()
+ (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 ()
+ (if (< (point-max) (buffer-size))
+ (gnus-article-next-page)
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?N)))))
+
+
+;;; @ end
+;;;
+
(gnus-ems-redefine)
(provide 'gnus-art)