;;; gnus-art.el --- article mode commands for Semi-gnus
-;; Copyright (C) 1996,97,98,99 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
+;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (require 'static)
+ (defvar tool-bar-map))
-(require 'custom)
+(require 'path-util)
(require 'gnus)
(require 'gnus-sum)
(require 'gnus-spec)
(require 'gnus-int)
-(require 'browse-url)
+(require 'gnus-win)
(require 'alist)
(require 'mime-view)
+(when (static-if (featurep 'xemacs)
+ (console-on-window-system-p)
+ window-system)
+ (require 'mime-image))
+(require 'wid-edit)
;; Avoid byte-compile warnings.
(eval-when-compile
- (defvar gnus-article-decoded-p)
- (defvar gnus-article-mime-handles)
(require 'mm-bodies)
(require 'mail-parse)
(require 'mm-decode)
(require 'mm-view)
- (require 'wid-edit)
- (require 'mm-uu)
- )
+ (require 'mm-uu))
+
+(require 'message)
+
+(autoload 'gnus-msg-mail "gnus-msg" nil t)
+(autoload 'gnus-button-mailto "gnus-msg")
+(autoload 'gnus-button-reply "gnus-msg" nil t)
+(autoload 'ansi-color-apply-on-region "ansi-color")
(defgroup gnus-article nil
"Article display."
- :link '(custom-manual "(gnus)The Article Buffer")
+ :link '(custom-manual "(gnus)Article Buffer")
:group 'gnus)
(defgroup gnus-article-treat nil
:group 'gnus-article)
(defcustom gnus-ignored-headers
- '("^Path:" "^Expires:" "^Date-Received:" "^References:" "^Xref:" "^Lines:"
- "^Relay-Version:" "^Message-ID:" "^Approved:" "^Sender:" "^Received:"
- "^X-UIDL:" "^MIME-Version:" "^Return-Path:" "^In-Reply-To:"
- "^Content-Type:" "^Content-Transfer-Encoding:" "^X-WebTV-Signature:"
- "^X-MimeOLE:" "^X-MSMail-Priority:" "^X-Priority:" "^X-Loop:"
- "^X-Authentication-Warning:" "^X-MIME-Autoconverted:" "^X-Face:"
- "^X-Attribution:" "^X-Originating-IP:" "^Delivered-To:"
- "^NNTP-[-A-Za-z]+:" "^Distribution:" "^X-no-archive:" "^X-Trace:"
- "^X-Complaints-To:" "^X-NNTP-Posting-Host:" "^X-Orig.*:"
- "^Abuse-Reports-To:" "^Cache-Post-Path:" "^X-Article-Creation-Date:"
- "^X-Poster:" "^X-Mail2News-Path:" "^X-Server-Date:" "^X-Cache:"
- "^Originator:" "^X-Problems-To:" "^X-Auth-User:" "^X-Post-Time:"
- "^X-Admin:" "^X-UID:" "^Resent-[-A-Za-z]+:" "^X-Mailing-List:"
- "^Precedence:" "^Original-[-A-Za-z]+:" "^X-filename:" "^X-Orcpt:"
- "^Old-Received:" "^X-Pgp-Fingerprint:" "^X-Pgp-Key-Id:"
- "^X-Pgp-Public-Key-Url:" "^X-Auth:" "^X-From-Line:"
- "^X-Gnus-Article-Number:" "^X-Majordomo:" "^X-Url:" "^X-Sender:"
- "^X-Mailing-List:" "^MBOX-Line" "^Priority:" "^X-Pgp" "^X400-[-A-Za-z]+:"
- "^Status:" "^X-Gnus-Mail-Source:" "^Cancel-Lock:")
+ (mapcar
+ (lambda (header)
+ (concat "^" header ":"))
+ '("Path" "Expires" "Date-Received" "References" "Xref" "Lines"
+ "Relay-Version" "Message-ID" "Approved" "Sender" "Received"
+ "X-UIDL" "MIME-Version" "Return-Path" "In-Reply-To"
+ "Content-Type" "Content-Transfer-Encoding" "X-WebTV-Signature"
+ "X-MimeOLE" "X-MSMail-Priority" "X-Priority" "X-Loop"
+ "X-Authentication-Warning" "X-MIME-Autoconverted" "X-Face"
+ "X-Attribution" "X-Originating-IP" "Delivered-To"
+ "NNTP-[-A-Za-z]+" "Distribution" "X-no-archive" "X-Trace"
+ "X-Complaints-To" "X-NNTP-Posting-Host" "X-Orig.*"
+ "Abuse-Reports-To" "Cache-Post-Path" "X-Article-Creation-Date"
+ "X-Poster" "X-Mail2News-Path" "X-Server-Date" "X-Cache"
+ "Originator" "X-Problems-To" "X-Auth-User" "X-Post-Time"
+ "X-Admin" "X-UID" "Resent-[-A-Za-z]+" "X-Mailing-List"
+ "Precedence" "Original-[-A-Za-z]+" "X-filename" "X-Orcpt"
+ "Old-Received" "X-Pgp" "X-Auth" "X-From-Line"
+ "X-Gnus-Article-Number" "X-Majordomo" "X-Url" "X-Sender"
+ "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"
+ "X-Face-Version" "X-Vms-To" "X-ML-NAME" "X-ML-COUNT"
+ "Mailing-List" "X-finfo" "X-md5sum" "X-md5sum-Origin"
+ "X-Sun-Charset" "X-Accept-Language" "X-Envelope-Sender"
+ "List-[A-Za-z]+" "X-Listprocessor-Version"
+ "X-Received" "X-Distribute" "X-Sequence" "X-Juno-Line-Breaks"
+ "X-Notes-Item" "X-MS-TNEF-Correlator" "x-uunet-gateway"
+ "X-Received" "Content-length" "X-precedence"
+ "X-Authenticated-User" "X-Comment" "X-Report" "X-Abuse-Info"
+ "X-HTTP-Proxy" "X-Mydeja-Info" "X-Copyright" "X-No-Markup"
+ "X-Abuse-Info" "X-From_" "X-Accept-Language" "Errors-To"
+ "X-BeenThere" "X-Mailman-Version" "List-Help" "List-Post"
+ "List-Subscribe" "List-Id" "List-Unsubscribe" "List-Archive"
+ "X-Content-length" "X-Posting-Agent" "Original-Received"
+ "X-Request-PGP" "X-Fingerprint" "X-WRIEnvto" "X-WRIEnvfrom"
+ "X-Virus-Scanned" "X-Delivery-Agent" "Posted-Date" "X-Gateway"
+ "X-Local-Origin" "X-Local-Destination" "X-UserInfo1"
+ "X-Received-Date" "X-Hashcash" "Face" "X-DMCA-Notifications"
+ "X-Abuse-and-DMCA-Info" "X-Postfilter" "X-Gpg-.*" "X-Disclaimer"))
"*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'."
+Possible values in this list are:
+
+ 'empty Headers with no content.
+ 'newsgroups Newsgroup identical to Gnus group.
+ 'to-address To identical to To-address.
+ 'to-list To identical to To-list.
+ 'cc-list CC identical to To-list.
+ 'followup-to Followup-to identical to Newsgroups.
+ 'reply-to Reply-to identical to From.
+ 'date Date less than four days old.
+ 'long-to To and/or Cc longer than 1024 characters.
+ 'many-to Multiple To and/or Cc."
:type '(set (const :tag "Headers with no content." empty)
- (const :tag "Newsgroups with only one group." newsgroups)
- (const :tag "Followup-to identical to newsgroups." followup-to)
- (const :tag "Reply-to identical to from." reply-to)
+ (const :tag "Newsgroups identical to Gnus group." newsgroups)
+ (const :tag "To identical to To-address." to-address)
+ (const :tag "To identical to To-list." to-list)
+ (const :tag "CC identical to To-list." cc-list)
+ (const :tag "Followup-to identical to Newsgroups." followup-to)
+ (const :tag "Reply-to identical to From." reply-to)
(const :tag "Date less than four days old." date)
- (const :tag "Very long To header." long-to)
- (const :tag "Multiple To headers." many-to))
+ (const :tag "To and/or Cc longer than 1024 characters." long-to)
+ (const :tag "Multiple To and/or Cc headers." many-to))
+ :group 'gnus-article-hiding)
+
+(defcustom gnus-article-skip-boring nil
+ "Skip over text that is not worth reading.
+By default, if you set this t, then Gnus will display citations and
+signatures, but will never scroll down to show you a page consisting
+only of boring text. Boring text is controlled by
+`gnus-article-boring-faces'."
+ :version "21.4"
+ :type 'boolean
:group 'gnus-article-hiding)
(defcustom gnus-signature-separator '("^-- $" "^-- *$")
:group 'gnus-article-signature)
(defcustom gnus-signature-limit nil
- "Provide a limit to what is considered a signature.
+ "Provide a limit to what is considered a signature.
If it is a number, no signature may not be longer (in characters) than
that number. If it is a floating point number, no signature may be
longer (in lines) than that number. If it is a function, the function
will be called without any parameters, and if it returns nil, there is
no signature in the buffer. If it is a string, it will be used as a
-regexp. If it matches, the text in question is not a signature."
+regexp. If it matches, the text in question is not a signature.
+
+This can also be a list of the above values."
:type '(choice (integer :value 200)
(number :value 4.0)
(function :value fun)
:type 'sexp
:group 'gnus-article-hiding)
+;; Fixme: This isn't the right thing for mixed graphical and non-graphical
+;; frames in a session.
(defcustom gnus-article-x-face-command
- "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | display -"
+ (cond
+ (noninteractive
+ 'ignore)
+ ((featurep 'xemacs)
+ (if (or (gnus-image-type-available-p 'xface)
+ (gnus-image-type-available-p 'pbm))
+ 'gnus-display-x-face-in-from
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -"))
+ ((gnus-image-type-available-p 'pbm)
+ 'gnus-display-x-face-in-from)
+ ((and window-system
+ (module-installed-p 'x-face-mule))
+ 'x-face-mule-gnus-article-display-x-face)
+ (t
+ "{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
+display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
- :type 'string ;Leave function case to Lisp.
+ :type `(choice
+ ,@(let ((x-face-mule (if (featurep 'xemacs)
+ nil
+ (module-installed-p 'x-face-mule))))
+ (delq nil
+ (list
+ 'string
+ (if (or (gnus-image-type-available-p 'xface)
+ (gnus-image-type-available-p 'pbm))
+ '(function-item gnus-display-x-face-in-from))
+ (if x-face-mule
+ '(function-item
+ x-face-mule-gnus-article-display-x-face))
+ 'function))))
+ :version "21.1"
+ :group 'gnus-picon
:group 'gnus-article-washing)
(defcustom gnus-article-x-face-too-ugly nil
:type '(choice regexp (const nil))
:group 'gnus-article-washing)
+(defcustom gnus-article-banner-alist nil
+ "Banner alist for stripping.
+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-article-address-banner-alist nil
+ "Alist of mail addresses and banners.
+Each element has the form (ADDRESS . BANNER), where ADDRESS is a regexp
+to match a mail address in the From: header, BANNER is one of a symbol
+`signature', an item in `gnus-article-banner-alist', a regexp and nil.
+If ADDRESS matches author's mail address, it will remove things like
+advertisements. For example:
+
+\((\"@yoo-hoo\\\\.co\\\\.jp\\\\'\" . \"\\n_+\\nDo You Yoo-hoo!\\\\?\\n.*\\n.*\\n\"))
+"
+ :type '(repeat
+ (cons
+ (regexp :tag "Address")
+ (choice :tag "Banner" :value nil
+ (const :tag "Remove signature" signature)
+ (symbol :tag "Item in `gnus-article-banner-alist'" none)
+ regexp
+ (const :tag "None" nil))))
+ :version "21.4"
+ :group 'gnus-article-washing)
+
(defcustom gnus-emphasis-alist
(let ((format
- "\\(\\s-\\|^\\|[-\"]\\|\\s(\\|\\s)\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\s-\\|[-?!.,;:\"]\\|\\s(\\|\\s)\\)")
+ "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
(types
- '(("_" "_" underline)
+ '(("\\*" "\\*" bold)
+ ("_" "_" underline)
("/" "/" italic)
- ("\\*" "\\*" bold)
("_/" "/_" underline-italic)
("_\\*" "\\*_" underline-bold)
("\\*/" "/\\*" bold-italic)
("_\\*/" "/\\*_" underline-bold-italic))))
- `(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
- 2 3 gnus-emphasis-underline)
- ,@(mapcar
+ `(,@(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)))
+ types)
+ ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+ 2 3 gnus-emphasis-underline)))
"*Alist that says how to fontify certain phrases.
Each item looks like this:
face))
:group 'gnus-article-emphasis)
+(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
+ "A regexp to describe whitespace which should not be emphasized.
+Typical values are \"^[ \\t]+\\\\|[ \\t]*\\n\" and \"[ \\t]+\\\\|[ \\t]*\\n\".
+The former avoids underlining of leading and trailing whitespace,
+and the latter avoids underlining any whitespace at all."
+ :version "21.1"
+ :group 'gnus-article-emphasis
+ :type 'regexp)
+
(defface gnus-emphasis-bold '((t (:bold t)))
"Face used for displaying strong emphasized text (*word*)."
:group 'gnus-article-emphasis)
:group 'gnus-article-emphasis)
(defface gnus-emphasis-underline-italic '((t (:italic t :underline t)))
- "Face used for displaying underlined italic emphasized text (_*word*_)."
+ "Face used for displaying underlined italic emphasized text (_/word/_)."
:group 'gnus-article-emphasis)
(defface gnus-emphasis-bold-italic '((t (:bold t :italic t)))
(defface gnus-emphasis-underline-bold-italic
'((t (:bold t :italic t :underline t)))
"Face used for displaying underlined bold italic emphasized text.
-Esample: (_/*word*/_)."
+Example: (_/*word*/_)."
+ :group 'gnus-article-emphasis)
+
+(defface gnus-emphasis-strikethru (if (featurep 'xemacs)
+ '((t (:strikethru t)))
+ '((t (:strike-through t))))
+ "Face used for displaying strike-through text (-word-)."
:group 'gnus-article-emphasis)
(defface gnus-emphasis-highlight-words
"Face used for displaying highlighted words."
:group 'gnus-article-emphasis)
-(defcustom gnus-article-time-format "%a, %b %d %Y %T %Z"
+(defcustom gnus-article-time-format "%a, %d %b %Y %T %Z"
"Format for display of Date headers in article bodies.
See `format-time-string' for the possible values.
The variable can also be function, which should return a complete Date
header. The function is called with one argument, the time, which can
be fed to `format-time-string'."
- :type '(choice string symbol)
+ :type '(choice string function)
:link '(custom-manual "(gnus)Article Date")
:group 'gnus-article-washing)
* gnus-summary-save-in-mail (Unix mail format)
* gnus-summary-save-in-folder (MH folder)
* gnus-summary-save-in-file (article format)
+* gnus-summary-save-body-in-file (article body)
* gnus-summary-save-in-vm (use VM's folder format)
* gnus-summary-write-to-file (article format -- overwrite)."
:group 'gnus-article-saving
(function-item gnus-summary-save-in-mail)
(function-item gnus-summary-save-in-folder)
(function-item gnus-summary-save-in-file)
+ (function-item gnus-summary-save-body-in-file)
(function-item gnus-summary-save-in-vm)
(function-item gnus-summary-write-to-file)))
:type 'regexp
:group 'gnus-article-various)
-(defcustom gnus-article-mode-line-format "Gnus: %g %S%m"
+(defcustom gnus-article-mode-line-format "Gnus: %g [%w] %S%m"
"*The format specification for the article mode line.
See `gnus-summary-mode-line-format' for a closer description.
: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
:type 'hook
:group 'gnus-article-various)
-(defcustom gnus-article-hide-pgp-hook nil
- "*A hook called after successfully hiding a PGP signature."
- :type 'hook
+(defcustom gnus-copy-article-ignored-headers nil
+ "List of headers to be removed when copying an article.
+Each element is a regular expression."
+ :version "22.0" ;; No Gnus
+ :type '(repeat regexp)
:group 'gnus-article-various)
+(make-obsolete-variable 'gnus-article-hide-pgp-hook
+ "This variable is obsolete in Gnus 5.10.")
+
(defcustom gnus-article-button-face 'bold
"Face used for highlighting buttons in the article buffer.
:group 'gnus-article-signature)
(defface gnus-signature-face
- '((((type x))
+ '((t
(:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
(:foreground "MidnightBlue" :italic t))
(t
(:italic t)))
- "Face used for displaying newsgroups headers."
+ "Face used for displaying newsgroups headers.
+In the default setup this face is only used for crossposted
+articles."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
(background light))
(:foreground "indianred4" :italic t))
(t
- (:italic t))) "Face used for displaying header content."
+ (:italic t)))
+ "Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
("Subject" nil gnus-header-subject-face)
("Newsgroups:.*," nil gnus-header-newsgroups-face)
("" gnus-header-name-face gnus-header-content-face))
- "*Controls highlighting of article header.
+ "*Controls highlighting of article headers.
An alist of the form (HEADER NAME CONTENT).
-HEADER is a regular expression which should match the name of an
-header header and NAME and CONTENT are either face names or nil.
+HEADER is a regular expression which should match the name of a
+header and NAME and CONTENT are either face names or nil.
The name of each header field will be displayed using the face
-specified by the first element in the list where HEADER match the
-header name and NAME is non-nil. Similarly, the content will be
-displayed by the first non-nil matching CONTENT face."
+specified by the first element in the list where HEADER matches
+the header name and NAME is non-nil. Similarly, the content will
+be displayed by the first non-nil matching CONTENT face."
:group 'gnus-article-headers
:group 'gnus-article-highlight
:type '(repeat (list (regexp :tag "Header")
(item :tag "skip" nil)
(face :value default)))))
-(defcustom gnus-article-decode-hook nil
+(defcustom gnus-article-decode-hook
+ '(article-decode-group-name article-decode-idna-rhs)
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
"Function used to decode headers.")
(defvar gnus-article-dumbquotes-map
- '(("\202" ",")
+ '(("\200" "EUR")
+ ("\202" ",")
("\203" "f")
("\204" ",,")
("\205" "...")
("\223" "``")
("\224" "\"")
("\225" "*")
- ("\226" "---")
- ("\227" "-")
+ ("\226" "-")
+ ("\227" "--")
+ ("\230" "~")
("\231" "(TM)")
("\233" ">")
("\234" "oe")
(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."
+ "List of MIME types that should not be given buttons when rendered inline.
+See also `gnus-buttonized-mime-types' which may override this variable.
+This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
+ :version "21.1"
:group 'gnus-article-mime
:type '(repeat regexp))
+(defcustom gnus-buttonized-mime-types nil
+ "List of MIME types that should be given buttons when rendered inline.
+If set, this variable overrides `gnus-unbuttonized-mime-types'.
+To see e.g. security buttons you could set this to
+`(\"multipart/signed\")'.
+This variable is only used when `gnus-inhibit-mime-unbuttonizing' is nil."
+ :version "21.4"
+ :group 'gnus-article-mime
+ :type '(repeat regexp))
+
+(defcustom gnus-inhibit-mime-unbuttonizing nil
+ "If non-nil, all MIME parts get buttons.
+When nil (the default value), then some MIME parts do not get buttons,
+as described by the variables `gnus-buttonized-mime-types' and
+`gnus-unbuttonized-mime-types'."
+ :version "21.4"
+ :group 'gnus-article-mime
+ :type 'boolean)
+
+(defcustom gnus-body-boundary-delimiter "_"
+ "String used to delimit header and body.
+This variable is used by `gnus-article-treat-body-boundary' which can
+be controlled by `gnus-treat-body-boundary'."
+ :version "21.4"
+ :group 'gnus-article-various
+ :type '(choice (item :tag "None" :value nil)
+ string))
+
+(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces"
+ "/usr/share/picons")
+ "Defines the location of the faces database.
+For information on obtaining this database of pretty pictures, please
+see http://www.cs.indiana.edu/picons/ftp/index.html"
+ :version "21.4"
+ :type '(repeat directory)
+ :link '(url-link :tag "download"
+ "http://www.cs.indiana.edu/picons/ftp/index.html")
+ :link '(custom-manual "(gnus)Picons")
+ :group 'gnus-picon)
+
+(defun gnus-picons-installed-p ()
+ "Say whether picons are installed on your machine."
+ (let ((installed nil))
+ (dolist (database gnus-picon-databases)
+ (when (file-exists-p database)
+ (setq installed t)))
+ installed))
+
(defcustom gnus-article-mime-part-function nil
"Function called with a MIME handle as the argument.
This is meant for people who want to do something automatic based
:type 'function)
(defcustom gnus-mime-multipart-functions nil
- "An alist of MIME types to functions to display them.")
+ "An alist of MIME types to functions to display them."
+ :version "21.1"
+ :group 'gnus-article-mime
+ :type '(repeat (cons :format "%v" (string :tag "MIME type") function)))
(defcustom gnus-article-date-lapsed-new-header nil
"Whether the X-Sent and Date headers can coexist.
When using `gnus-treat-date-lapsed', the \"X-Sent:\" header will
either replace the old \"Date:\" header (if this variable is nil), or
be added below it (otherwise)."
+ :version "21.1"
:group 'gnus-article-headers
:type 'boolean)
+(defcustom gnus-article-mime-match-handle-function 'undisplayed-alternative
+ "Function called with a MIME handle as the argument.
+This is meant for people who want to view first matched part.
+For `undisplayed-alternative' (default), the first undisplayed
+part or alternative part is used. For `undisplayed', the first
+undisplayed part is used. For a function, the first part which
+the function return t is used. For nil, the first part is
+used."
+ :version "21.1"
+ :group 'gnus-article-mime
+ :type '(choice
+ (item :tag "first" :value nil)
+ (item :tag "undisplayed" :value undisplayed)
+ (item :tag "undisplayed or alternative"
+ :value undisplayed-alternative)
+ (function)))
+
+(defcustom gnus-mime-action-alist
+ '(("save to file" . gnus-mime-save-part)
+ ("save and strip" . gnus-mime-save-part-and-strip)
+ ("delete part" . gnus-mime-delete-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)
+ ("toggle display" . gnus-article-view-part-as-charset)
+ ("view as type" . gnus-mime-view-part-as-type)
+ ("view internally" . gnus-mime-view-part-internally)
+ ("view externally" . gnus-mime-view-part-externally))
+ "An alist of actions that run on the MIME attachment."
+ :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")))
(defvar gnus-inhibit-treatment nil
"Whether to inhibit treatment.")
-(defcustom gnus-treat-highlight-signature '(or last (typep "text/x-vcard"))
+(defcustom gnus-treat-highlight-signature '(or t (typep "text/x-vcard"))
"Highlight the signature.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-signature 'highlight t)
-(defcustom gnus-treat-buttonize t
+(defcustom gnus-treat-buttonize 100000
"Add buttons.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles'."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(put 'gnus-treat-buttonize 'highlight t)
(defcustom gnus-treat-buttonize-head 'head
"Add buttons to the head.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(put 'gnus-treat-buttonize-head 'highlight t)
-(defcustom gnus-treat-emphasize t
+(defcustom gnus-treat-emphasize
+ (and (or window-system
+ (featurep 'xemacs))
+ 50000)
"Emphasize text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(put 'gnus-treat-emphasize 'highlight t)
(defcustom gnus-treat-strip-cr nil
"Remove carriage returns.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-unsplit-urls nil
+ "Remove newlines from within URLs.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :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 Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
: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.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-boring-headers nil
"Hide boring headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-hide-signature nil
"Hide the signature.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-article nil
"Fill the article.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-hide-citation nil
"Hide cited text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-hide-citation-maybe nil
+ "Hide cited text.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-strip-pgp t
- "Strip PGP signatures.
+(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."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
+(make-obsolete-variable 'gnus-treat-strip-pgp
+ "This option is obsolete in Gnus 5.10.")
+
(defcustom gnus-treat-strip-pem nil
"Strip PEM signatures.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-banner t
"Strip banners from articles.
The banner to be stripped is specified in the `banner' group parameter.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-highlight-headers 'head
"Highlight the headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(put 'gnus-treat-highlight-headers 'highlight t)
(defcustom gnus-treat-highlight-citation t
"Highlight cited text.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(put 'gnus-treat-highlight-citation 'highlight t)
(defcustom gnus-treat-date-ut nil
"Display the Date in UT (GMT).
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-local nil
"Display the Date in the local timezone.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-head-custom)
+
+(defcustom gnus-treat-date-english nil
+ "Display the Date in a format that can be read aloud in English.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-lapsed nil
"Display the Date header in a way that says how much time has elapsed.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-original nil
"Display the date in the original timezone.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-iso8601 nil
"Display the date in the ISO8601 format.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-date-user-defined nil
"Display the date in a user-defined format.
The format is defined by the `gnus-article-time-format' variable.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
(defcustom gnus-treat-strip-headers-in-body t
"Strip the X-No-Archive header line from the beginning of the body.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-trailing-blank-lines nil
"Strip trailing blank lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-leading-blank-lines nil
"Strip leading blank lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-strip-multiple-blank-lines nil
"Strip multiple blank lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-unfold-headers 'head
+ "Unfold folded header lines.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-fold-headers nil
+ "Fold headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(defcustom gnus-treat-strip-blank-lines nil
- "Strip all blank lines.
+(defcustom gnus-treat-fold-newsgroups 'head
+ "Fold the Newsgroups and Followup-To headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-overstrike t
"Treat overstrike highlighting.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(put 'gnus-treat-overstrike 'highlight t)
-(defcustom gnus-treat-display-xface (if (and gnus-xemacs (featurep 'xface))
- 'head nil)
+(defcustom gnus-treat-ansi-sequences (if (locate-library "ansi-color") t)
+ "Treat ANSI SGR control sequences.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
+(make-obsolete-variable 'gnus-treat-display-xface
+ 'gnus-treat-display-x-face)
+
+(defcustom gnus-treat-display-x-face
+ (and (not noninteractive)
+ (or (eq gnus-article-x-face-command
+ 'x-face-mule-gnus-article-display-x-face)
+ (and (fboundp 'image-type-available-p)
+ (image-type-available-p 'xbm)
+ (string-match "^0x" (shell-command-to-string "uncompface"))
+ (executable-find "icontopbm"))
+ (and (featurep 'xemacs)
+ (featurep 'xface)))
+ 'head)
"Display X-Face headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)X-Face' for details."
:group 'gnus-article-treat
+ :version "21.1"
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)X-Face")
+ :type gnus-article-treat-head-custom
+ :set (lambda (symbol value)
+ (set-default
+ symbol
+ (cond ((or (boundp symbol) (get symbol 'saved-value))
+ value)
+ ((boundp 'gnus-treat-display-xface)
+ (message "\
+** gnus-treat-display-xface is an obsolete variable;\
+ use gnus-treat-display-x-face instead")
+ (default-value 'gnus-treat-display-xface))
+ ((get 'gnus-treat-display-xface 'saved-value)
+ (message "\
+** gnus-treat-display-xface is an obsolete variable;\
+ use gnus-treat-display-x-face instead")
+ (eval (car (get 'gnus-treat-display-xface 'saved-value))))
+ (t
+ value)))))
+(put 'gnus-treat-display-x-face 'highlight t)
+
+(defcustom gnus-article-should-use-smiley-mule
+ (not (or (featurep 'xemacs)
+ (gnus-image-type-available-p 'xpm)
+ (gnus-image-type-available-p 'pbm)))
+ "Non-nil means use `smiley-mule' to show smileys rather than `smiley'.
+`smiley-mule' is boundled in BITMAP-MULE package. You can set it to t
+even if your Emacs supports images. It has no effect on XEmacs."
+ :group 'gnus-article-various
+ :type 'boolean
+ :get (lambda (symbol)
+ (and (not noninteractive)
+ (default-value symbol)
+ (not (featurep 'xemacs))
+ (module-installed-p 'smiley-mule)
+ t))
+ :set (lambda (symbol value)
+ (set-default symbol (and (not noninteractive)
+ value
+ (not (featurep 'xemacs))
+ (module-installed-p 'smiley-mule)
+ t))))
+
+(defvar gnus-article-smiley-mule-loaded-p nil
+ "Internal variable used to say whether `smiley-mule' is loaded (whether
+smiley functions are not overridden by `smiley').")
+
+(defcustom gnus-treat-display-face
+ (and (not noninteractive)
+ (or (and (fboundp 'image-type-available-p)
+ (image-type-available-p 'png))
+ (and (featurep 'xemacs)
+ (featurep 'png)))
+ 'head)
+ "Display Face headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)X-Face' for details."
+ :group 'gnus-article-treat
+ :version "21.4"
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)X-Face")
:type gnus-article-treat-head-custom)
-(put 'gnus-treat-display-xface 'highlight t)
-
-(defcustom gnus-treat-display-smileys (if (and gnus-xemacs
- (featurep 'xpm))
- t nil)
+(put 'gnus-treat-display-face 'highlight t)
+
+(defcustom gnus-treat-display-smileys
+ (if (and (not noninteractive)
+ (or (and (featurep 'xemacs)
+ (featurep 'xpm))
+ (gnus-image-type-available-p 'xpm)
+ (gnus-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."
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Smileys' for details."
:group 'gnus-article-treat
+ :version "21.1"
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Smileys")
:type gnus-article-treat-custom)
(put 'gnus-treat-display-smileys 'highlight t)
-(defcustom gnus-treat-display-picons (if gnus-xemacs 'head nil)
- "Display picons.
+(defcustom gnus-treat-from-picon
+ (if (and (gnus-image-type-available-p 'xpm)
+ (gnus-picons-installed-p))
+ 'head nil)
+ "Display picons in the From header.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Picons' for details."
+ :version "21.4"
:group 'gnus-article-treat
+ :group 'gnus-picon
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Picons")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-from-picon 'highlight t)
+
+(defcustom gnus-treat-mail-picon
+ (if (and (gnus-image-type-available-p 'xpm)
+ (gnus-picons-installed-p))
+ 'head nil)
+ "Display picons in To and Cc headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Picons' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :group 'gnus-picon
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Picons")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-mail-picon 'highlight t)
+
+(defcustom gnus-treat-newsgroups-picon
+ (if (and (gnus-image-type-available-p 'xpm)
+ (gnus-picons-installed-p))
+ 'head nil)
+ "Display picons in the Newsgroups and Followup-To headers.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)Picons' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :group 'gnus-picon
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :link '(custom-manual "(gnus)Picons")
+ :type gnus-article-treat-head-custom)
+(put 'gnus-treat-newsgroups-picon 'highlight t)
+
+(defcustom gnus-treat-body-boundary
+ (if (and (eq window-system 'x)
+ (or gnus-treat-newsgroups-picon
+ gnus-treat-mail-picon
+ gnus-treat-from-picon))
+ 'head nil)
+ "Draw a boundary at the end of the headers.
+Valid values are nil and `head'.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
-(put 'gnus-treat-display-picons 'highlight t)
(defcustom gnus-treat-capitalize-sentences nil
"Capitalize sentence-starting words.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :type gnus-article-treat-custom)
+
+(defcustom gnus-treat-wash-html nil
+ "Format as HTML.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-fill-long-lines nil
"Fill long lines.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-play-sounds nil
"Play sounds.
Valid values are nil, t, `head', `last', an integer or a predicate.
-See the manual for details."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
:group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
(defcustom gnus-treat-decode-article-as-default-mime-charset nil
(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."
+See Info node `(gnus)Customizing Articles' for details."
+ :version "21.1"
+ :group 'gnus-article-treat
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :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 Info node `(gnus)Customizing Articles' for details."
+ :version "21.4"
:group 'gnus-article-treat
+ :group 'mime-security
:type gnus-article-treat-custom)
+(defcustom gnus-treat-monafy nil
+ "Display body part with mona font.
+Valid values are nil, t, `head', `last', an integer or a predicate.
+See Info node `(gnus)Customizing Articles' for details."
+ :group 'gnus-article-treat
+ :group 'mime-security
+ :link '(custom-manual "(gnus)Customizing Articles")
+ :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."
+ :version "21.4"
+ :type 'string
+ :group 'mime-security)
+
+(defvar gnus-article-wash-function nil
+ "Function used for converting HTML into text.")
+
+(defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error))
+ (mm-coding-system-p 'utf-8)
+ (executable-find idna-program))
+ "Whether IDNA decoding of headers is used when viewing messages.
+This requires GNU Libidn, and by default only enabled if it is found."
+ :version "21.4"
+ :group 'gnus-article-headers
+ :type 'boolean)
+
+(defcustom gnus-article-over-scroll nil
+ "If non-nil, allow scrolling the article buffer even when there no more text."
+ :version "21.4"
+ :group 'gnus-article
+ :type 'boolean)
+
;;; Internal variables
+(defvar gnus-english-month-names
+ '("January" "February" "March" "April" "May" "June" "July" "August"
+ "September" "October" "November" "December"))
+
+(defvar gnus-button-regexp nil)
+(defvar gnus-button-marker-list nil)
+;; Regexp matching any of the regexps from `gnus-button-alist'.
+
+(defvar gnus-button-last nil)
+;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
+
(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-image-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-monafy gnus-article-monafy)
+ (gnus-treat-strip-banner gnus-article-strip-banner)
(gnus-treat-strip-headers-in-body gnus-article-strip-headers-in-body)
(gnus-treat-buttonize gnus-article-add-buttons)
(gnus-treat-fill-article gnus-article-fill-cited-article)
(gnus-treat-fill-long-lines gnus-article-fill-long-lines)
(gnus-treat-strip-cr gnus-article-remove-cr)
- (gnus-treat-emphasize gnus-article-emphasize)
- (gnus-treat-display-xface gnus-article-display-x-face)
- (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
- (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
- (gnus-treat-hide-signature gnus-article-hide-signature)
- (gnus-treat-hide-citation gnus-article-hide-citation)
- (gnus-treat-strip-pgp gnus-article-hide-pgp)
- (gnus-treat-strip-pem gnus-article-hide-pem)
- (gnus-treat-highlight-headers gnus-article-highlight-headers)
- (gnus-treat-highlight-citation gnus-article-highlight-citation)
- (gnus-treat-highlight-signature gnus-article-highlight-signature)
+ (gnus-treat-unsplit-urls gnus-article-unsplit-urls)
(gnus-treat-date-ut gnus-article-date-ut)
(gnus-treat-date-local gnus-article-date-local)
+ (gnus-treat-date-english gnus-article-date-english)
(gnus-treat-date-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-display-face gnus-article-display-face)
+ (gnus-treat-hide-headers gnus-article-maybe-hide-headers)
+ (gnus-treat-hide-boring-headers gnus-article-hide-boring-headers)
+ (gnus-treat-hide-signature gnus-article-hide-signature)
+ (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers)
+ (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace)
+ (gnus-treat-strip-pem gnus-article-hide-pem)
+ (gnus-treat-from-picon gnus-treat-from-picon)
+ (gnus-treat-mail-picon gnus-treat-mail-picon)
+ (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon)
+ (gnus-treat-highlight-headers gnus-article-highlight-headers)
+ (gnus-treat-highlight-signature gnus-article-highlight-signature)
(gnus-treat-strip-trailing-blank-lines
gnus-article-remove-trailing-blank-lines)
(gnus-treat-strip-leading-blank-lines
gnus-article-strip-leading-blank-lines)
(gnus-treat-strip-multiple-blank-lines
gnus-article-strip-multiple-blank-lines)
- (gnus-treat-strip-blank-lines gnus-article-strip-blank-lines)
(gnus-treat-overstrike gnus-article-treat-overstrike)
+ (gnus-treat-ansi-sequences gnus-article-treat-ansi-sequences)
+ (gnus-treat-unfold-headers gnus-article-treat-unfold-headers)
+ (gnus-treat-fold-headers gnus-article-treat-fold-headers)
+ ;; Displaying X-Face should be done after unfolding headers
+ ;; to protect bitmap lines.
+ (gnus-treat-display-x-face gnus-article-display-x-face)
+ (gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
(gnus-treat-buttonize-head gnus-article-add-buttons-to-head)
- (gnus-treat-display-smileys gnus-smiley-display)
- (gnus-treat-display-picons gnus-article-display-picons)
- (gnus-treat-play-sounds gnus-earcon-display)
- (gnus-treat-decode-article-as-default-mime-charset
- gnus-article-decode-article-as-default-mime-charset)))
+ (gnus-treat-display-smileys gnus-treat-smiley)
+ (gnus-treat-capitalize-sentences gnus-article-capitalize-sentences)
+ (gnus-treat-wash-html gnus-article-wash-html)
+ (gnus-treat-emphasize gnus-article-emphasize)
+ (gnus-treat-hide-citation gnus-article-hide-citation)
+ (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe)
+ (gnus-treat-highlight-citation gnus-article-highlight-citation)
+ (gnus-treat-body-boundary gnus-article-treat-body-boundary)
+ (gnus-treat-play-sounds gnus-earcon-display)))
(defvar gnus-article-mime-handle-alist nil)
(defvar article-lapsed-timer nil)
(defvar gnus-article-mode-syntax-table
(let ((table (copy-syntax-table text-mode-syntax-table)))
- (modify-syntax-entry ?- "w" table)
- (modify-syntax-entry ?> ")" table)
- (modify-syntax-entry ?< "(" table)
+ ;; This causes the citation match run O(2^n).
+ ;; (modify-syntax-entry ?- "w" table)
+ (modify-syntax-entry ?> ")<" table)
+ (modify-syntax-entry ?< "(>" table)
+ ;; make M-. in article buffers work for `foo' strings
+ (modify-syntax-entry ?' " " table)
+ (modify-syntax-entry ?` " " table)
table)
"Syntax table used in article mode buffers.
Initialized from `text-mode-syntax-table.")
(defvar gnus-inhibit-hiding nil)
+(defvar gnus-article-edit-mode nil)
+
+;;; Macros for dealing with the article buffer.
+
+(defmacro gnus-with-article-headers (&rest forms)
+ `(save-excursion
+ (set-buffer gnus-article-buffer)
+ (save-restriction
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t)
+ (case-fold-search t))
+ (article-narrow-to-head)
+ ,@forms))))
+
+(put 'gnus-with-article-headers 'lisp-indent-function 0)
+(put 'gnus-with-article-headers 'edebug-form-spec '(body))
+
+(defmacro gnus-with-article-buffer (&rest forms)
+ `(save-excursion
+ (set-buffer gnus-article-buffer)
+ (let ((inhibit-read-only t))
+ ,@forms)))
+
+(put 'gnus-with-article-buffer 'lisp-indent-function 0)
+(put 'gnus-with-article-buffer 'edebug-form-spec '(body))
+
+(defun gnus-article-goto-header (header)
+ "Go to HEADER, which is a regular expression."
+ (re-search-forward (concat "^\\(" header "\\):") nil t))
+
(defsubst gnus-article-hide-text (b e props)
"Set text PROPS on the B to E region, extending `intangible' 1 past B."
- (add-text-properties b e props)
+ (gnus-add-text-properties-when 'article-type nil b e props)
(when (memq 'intangible props)
(put-text-property
(max (1- b) (point-min))
b 'intangible (cddr (memq 'intangible props)))))
+
(defsubst gnus-article-unhide-text (b e)
"Remove hidden text properties from region between B and E."
(remove-text-properties b e gnus-hidden-properties)
(defun gnus-article-hide-text-type (b e type)
"Hide text of TYPE between B and E."
- (push type gnus-article-wash-types)
+ (gnus-add-wash-type type)
(gnus-article-hide-text
b e (cons 'article-type (cons type gnus-hidden-properties))))
(defun gnus-article-unhide-text-type (b e type)
"Unhide text of TYPE between B and E."
- (setq gnus-article-wash-types
- (delq type gnus-article-wash-types))
+ (gnus-delete-wash-type type)
(remove-text-properties
b e (cons 'article-type (cons type gnus-hidden-properties)))
(when (memq 'intangible gnus-hidden-properties)
(defsubst gnus-article-header-rank ()
"Give the rank of the string HEADER as given by `gnus-sorted-header-list'."
(let ((list gnus-sorted-header-list)
- (i 0))
+ (i 1))
(while list
- (when (looking-at (car list))
- (setq list nil))
- (setq list (cdr list))
- (incf i))
- i))
+ (if (looking-at (car list))
+ (setq list nil)
+ (setq list (cdr list))
+ (incf i)))
+ i))
(defun article-hide-headers (&optional arg delete)
"Hide unwanted headers and possibly sort them 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)
- (inhibit-read-only t)
- (case-fold-search t)
- (max (1+ (length gnus-sorted-header-list)))
- (ignored (when (not gnus-visible-headers)
- (cond ((stringp gnus-ignored-headers)
- gnus-ignored-headers)
- ((listp gnus-ignored-headers)
- (mapconcat 'identity gnus-ignored-headers
- "\\|")))))
- (visible
- (cond ((stringp gnus-visible-headers)
- gnus-visible-headers)
- ((and gnus-visible-headers
- (listp gnus-visible-headers))
- (mapconcat 'identity gnus-visible-headers "\\|"))))
- (inhibit-point-motion-hooks t)
- beg)
- ;; First we narrow to just the headers.
- (article-narrow-to-head)
- ;; Hide any "From " lines at the beginning of (mail) articles.
- (while (looking-at "From ")
- (forward-line 1))
- (unless (bobp)
- (if delete
- (delete-region (point-min) (point))
- (gnus-article-hide-text (point-min) (point)
- (nconc (list 'article-type 'headers)
- gnus-hidden-properties))))
- ;; Then treat the rest of the header lines.
- ;; Then we use the two regular expressions
- ;; `gnus-ignored-headers' and `gnus-visible-headers' to
- ;; select which header lines is to remain visible in the
- ;; article buffer.
- (while (re-search-forward "^[^ \t]*:" nil t)
- (beginning-of-line)
- ;; Mark the rank of the header.
- (put-text-property
- (point) (1+ (point)) 'message-rank
- (if (or (and visible (looking-at visible))
- (and ignored
- (not (looking-at ignored))))
- (gnus-article-header-rank)
- (+ 2 max)))
- (forward-line 1))
- (message-sort-headers-1)
- (when (setq beg (text-property-any
- (point-min) (point-max) 'message-rank (+ 2 max)))
- ;; We delete or make invisible the unwanted headers.
- (if delete
- (progn
- (add-text-properties
- (point-min) (+ 5 (point-min))
- '(article-type headers dummy-invisible t))
- (delete-region beg (point-max)))
- (gnus-article-hide-text-type beg (point-max) 'headers))))))))
- )
+ (unless gnus-inhibit-hiding
+ (let ((inhibit-read-only t)
+ (case-fold-search t)
+ (max (1+ (length gnus-sorted-header-list)))
+ (inhibit-point-motion-hooks t)
+ (cur (current-buffer))
+ ignored visible beg)
+ (save-excursion
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
+ ;; group parameters, so we should go to the summary buffer.
+ (when (prog1
+ (condition-case nil
+ (progn (set-buffer gnus-summary-buffer) t)
+ (error nil))
+ (setq ignored (when (not gnus-visible-headers)
+ (cond ((stringp gnus-ignored-headers)
+ gnus-ignored-headers)
+ ((listp gnus-ignored-headers)
+ (mapconcat 'identity
+ gnus-ignored-headers
+ "\\|"))))
+ visible (cond ((stringp gnus-visible-headers)
+ gnus-visible-headers)
+ ((and gnus-visible-headers
+ (listp gnus-visible-headers))
+ (mapconcat 'identity
+ gnus-visible-headers
+ "\\|")))))
+ (set-buffer cur))
+ (save-restriction
+ ;; First we narrow to just the headers.
+ (article-narrow-to-head)
+ ;; Hide any "From " lines at the beginning of (mail) articles.
+ (while (looking-at "From ")
+ (forward-line 1))
+ (unless (bobp)
+ (if delete
+ (delete-region (point-min) (point))
+ (gnus-article-hide-text (point-min) (point)
+ (nconc (list 'article-type 'headers)
+ gnus-hidden-properties))))
+ ;; Then treat the rest of the header lines.
+ ;; Then we use the two regular expressions
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' to
+ ;; select which header lines is to remain visible in the
+ ;; article buffer.
+ (while (re-search-forward "^[^ \t:]*:" nil t)
+ (beginning-of-line)
+ ;; Mark the rank of the header.
+ (put-text-property
+ (point) (1+ (point)) 'message-rank
+ (if (or (and visible (looking-at visible))
+ (and ignored
+ (not (looking-at ignored))))
+ (gnus-article-header-rank)
+ (+ 2 max)))
+ (forward-line 1))
+ (message-sort-headers-1)
+ (when (setq beg (text-property-any
+ (point-min) (point-max) 'message-rank (+ 2 max)))
+ ;; We delete or make invisible the unwanted headers.
+ (gnus-add-wash-type 'headers)
+ (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.
(not gnus-show-all-headers))
(save-excursion
(save-restriction
- (let ((buffer-read-only nil)
- (list gnus-boring-article-headers)
- (inhibit-point-motion-hooks t)
- elem)
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
(article-narrow-to-head)
- (while list
- (setq elem (pop list))
+ (dolist (elem gnus-boring-article-headers)
(goto-char (point-min))
(cond
;; Hide empty headers.
(while (re-search-forward "^[^: \t]+:[ \t]*\n[^ \t]" nil t)
(forward-line -1)
(gnus-article-hide-text-type
- (progn (beginning-of-line) (point))
+ (point-at-bol)
(progn
(end-of-line)
(if (re-search-forward "^[^ \t]" nil t)
'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 'to-list)
+ (let ((to (message-fetch-field "to"))
+ (to-list
+ (gnus-parameter-to-list
+ (if (boundp 'gnus-newsgroup-name)
+ gnus-newsgroup-name ""))))
+ (when (and to to-list
+ (ignore-errors
+ (gnus-string-equal
+ ;; only one address in To
+ (nth 1 (mail-extract-address-components to))
+ to-list)))
+ (gnus-article-hide-header "to"))))
+ ((eq elem 'cc-list)
+ (let ((cc (message-fetch-field "cc"))
+ (to-list
+ (gnus-parameter-to-list
+ (if (boundp 'gnus-newsgroup-name)
+ gnus-newsgroup-name ""))))
+ (when (and cc to-list
+ (ignore-errors
+ (gnus-string-equal
+ ;; only one address in CC
+ (nth 1 (mail-extract-address-components cc))
+ to-list)))
+ (gnus-article-hide-header "cc"))))
((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"))
- (reply-to (message-fetch-field "reply-to")))
- (when (and
+ (if (gnus-group-find-parameter
+ gnus-newsgroup-name 'broken-reply-to)
+ (gnus-article-hide-header "reply-to")
+ (let ((from (message-fetch-field "from"))
+ (reply-to (message-fetch-field "reply-to")))
+ (when
+ (and
from reply-to
(ignore-errors
(equal
- (nth 1 (funcall gnus-extract-address-components from))
- (nth 1 (funcall gnus-extract-address-components reply-to)))))
- (gnus-article-hide-header "reply-to"))))
+ (sort (mapcar
+ (lambda (x) (downcase (cadr x)))
+ (mail-extract-address-components from t))
+ 'string<)
+ (sort (mapcar
+ (lambda (x) (downcase (cadr x)))
+ (mail-extract-address-components reply-to t))
+ 'string<))))
+ (gnus-article-hide-header "reply-to")))))
((eq elem 'date)
(let ((date (message-fetch-field "date")))
(when (and date
4))
(gnus-article-hide-header "date"))))
((eq elem 'long-to)
- (let ((to (message-fetch-field "to")))
+ (let ((to (message-fetch-field "to"))
+ (cc (message-fetch-field "cc")))
(when (> (length to) 1024)
- (gnus-article-hide-header "to"))))
+ (gnus-article-hide-header "to"))
+ (when (> (length cc) 1024)
+ (gnus-article-hide-header "cc"))))
((eq elem 'many-to)
- (let ((to-count 0))
+ (let ((to-count 0)
+ (cc-count 0))
(goto-char (point-min))
(while (re-search-forward "^to:" nil t)
(setq to-count (1+ to-count)))
(forward-line -1)
(narrow-to-region (point) (point-max))
(gnus-article-hide-header "to"))
- (setq to-count (1- to-count)))))))))))))
+ (setq to-count (1- to-count))))
+ (goto-char (point-min))
+ (while (re-search-forward "^cc:" nil t)
+ (setq cc-count (1+ cc-count)))
+ (when (> cc-count 1)
+ (while (> cc-count 0)
+ (goto-char (point-min))
+ (save-restriction
+ (re-search-forward "^cc:" nil nil cc-count)
+ (forward-line -1)
+ (narrow-to-region (point) (point-max))
+ (gnus-article-hide-header "cc"))
+ (setq cc-count (1- cc-count)))))))))))))
(defun gnus-article-hide-header (header)
(save-excursion
(goto-char (point-min))
(when (re-search-forward (concat "^" header ":") nil t)
(gnus-article-hide-text-type
- (progn (beginning-of-line) (point))
+ (point-at-bol)
(progn
(end-of-line)
(if (re-search-forward "^[^ \t]" nil t)
(point-max)))
'boring-headers))))
-(defun article-toggle-headers (&optional arg)
- "Toggle hiding of headers. If given a negative prefix, always show;
-if given a positive prefix, always hide."
- (interactive (gnus-article-hidden-arg))
- (let ((force (when (numberp arg)
- (cond ((> arg 0) 'always-hide)
- ((< arg 0) 'always-show))))
- (window (get-buffer-window gnus-article-buffer))
- (header-end (point-min))
- header-start field-end field-start
- (inhibit-point-motion-hooks t)
- (inhibit-read-only t)
- buffer-read-only)
- (save-restriction
- (widen)
- (while (and (setq header-start
- (text-property-any header-end (point-max)
- 'article-treated-header t))
- (setq header-end
- (text-property-not-all header-start (point-max)
- 'article-treated-header t)))
- (setq field-end header-start)
- (cond
- (;; Hide exposed invisible fields.
- (and (not (eq 'always-show force))
- (setq field-start
- (text-property-any field-end header-end
- 'exposed-invisible-field t)))
- (while (and field-start
- (setq field-end (text-property-not-all
- field-start header-end
- 'exposed-invisible-field t)))
- (add-text-properties field-start field-end gnus-hidden-properties)
- (setq field-start (text-property-any field-end header-end
- 'exposed-invisible-field t)))
- (put-text-property header-start header-end
- 'exposed-invisible-field nil))
- (;; Expose invisible fields.
- (and (not (eq 'always-hide force))
- (setq field-start
- (text-property-any field-end header-end 'invisible t)))
- (while (and field-start
- (setq field-end (text-property-not-all
- field-start header-end
- 'invisible t)))
- ;; If the invisible text is not terminated with newline, we
- ;; won't expose it. Because it may be created by x-face-mule.
- ;; BTW, XEmacs sometimes fail in putting a invisible text
- ;; property with `gnus-article-hide-text' (really?). In that
- ;; case, the invisible text might be started from the middle of
- ;; a line so we will expose the sort of thing.
- (when (or (not (or (eq header-start field-start)
- (eq ?\n (char-before field-start))))
- (eq ?\n (char-before field-end)))
- (remove-text-properties field-start field-end
- gnus-hidden-properties)
- (put-text-property field-start field-end
- 'exposed-invisible-field t))
- (setq field-start (text-property-any field-end header-end
- 'invisible t))))
- (;; Hide fields.
- (not (eq 'always-show force))
- (narrow-to-region header-start header-end)
- (article-hide-headers)
- ;; Re-display X-Face image under XEmacs.
- (when (and gnus-xemacs
- (gnus-functionp gnus-article-x-face-command))
- (let ((func (cadr (assq 'gnus-treat-display-xface
- gnus-treatment-function-alist)))
- (condition 'head))
- (when (and 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.")
(defun article-normalize-headers ()
"Make all header lines 40 characters long."
(interactive)
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
column)
(save-excursion
(save-restriction
(article-narrow-to-head)
(while (not (eobp))
(cond
- ((< (setq column (- (gnus-point-at-eol) (point)))
+ ((< (setq column (- (point-at-eol) (point)))
gnus-article-normalized-header-length)
(end-of-line)
(insert (make-string
(progn
(forward-char gnus-article-normalized-header-length)
(point))
- (gnus-point-at-eol)
+ (point-at-eol)
'invisible t))
(t
;; Do nothing.
(forward-line 1))))))
(defun article-treat-dumbquotes ()
- "Translate M******** sm*rtq**t*s into proper text.
+ "Translate M****s*** sm*rtq**t*s and other symbols into proper text.
Note that this function guesses whether a character is a sm*rtq**t* or
-not, so it should only be used interactively."
+not, so it should only be used interactively.
+
+Sm*rtq**t*s are M****s***'s unilateral extension to the
+iso-8859-1 character map in an attempt to provide more quoting
+characters. If you see something like \\222 or \\264 where
+you're expecting some kind of apostrophe or quotation mark, then
+try this wash."
(interactive)
(article-translate-strings gnus-article-dumbquotes-map))
characters to translate to."
(save-excursion
(when (article-goto-body)
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(x (make-string 225 ?x))
(i -1))
(while (< (incf i) (length x))
MAP is an alist where the elements are on the form (\"from\" \"to\")."
(save-excursion
(when (article-goto-body)
- (let ((buffer-read-only nil)
- elem)
- (while (setq elem (pop map))
+ (let ((inhibit-read-only t))
+ (dolist (elem map)
(save-excursion
(while (search-forward (car elem) nil t)
(replace-match (cadr elem)))))))))
(interactive)
(save-excursion
(when (article-goto-body)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(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-treat-ansi-sequences ()
+ "Translate ANSI SGR control sequences into overlays or extents."
+ (interactive)
+ (save-excursion
+ (when (article-goto-body)
+ (let ((inhibit-read-only t))
+ (ansi-color-apply-on-region (point) (point-max))))))
+
+(defun gnus-article-treat-unfold-headers ()
+ "Unfold folded message headers.
+Only the headers that fit into the current window width will be
+unfolded."
+ (interactive)
+ (gnus-with-article-headers
+ (let (length)
+ (while (not (eobp))
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (let ((header (buffer-string)))
+ (with-temp-buffer
+ (insert header)
+ (goto-char (point-min))
+ (while (re-search-forward "\n[\t ]" nil t)
+ (replace-match " " t t)))
+ (setq length (- (point-max) (point-min) 1)))
+ (when (< length (window-width))
+ (while (re-search-forward "\n[\t ]" nil t)
+ (replace-match " " t t)))
+ (goto-char (point-max)))))))
+
+(defun gnus-article-treat-fold-headers ()
+ "Fold message headers."
+ (interactive)
+ (gnus-with-article-headers
+ (while (not (eobp))
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (mail-header-fold-field)
+ (goto-char (point-max))))))
+
+(defun gnus-treat-smiley ()
+ "Toggle display of textual emoticons (\"smileys\") as small graphical icons."
+ (interactive)
+ (unless (featurep 'xemacs)
+ (when (and (not gnus-article-should-use-smiley-mule)
+ gnus-article-smiley-mule-loaded-p)
+ (load "smiley" nil t)
+ (setq gnus-article-smiley-mule-loaded-p nil))
+ (when (and gnus-article-should-use-smiley-mule
+ (not gnus-article-smiley-mule-loaded-p))
+ (load "smiley-mule" nil t)
+ (setq gnus-article-smiley-mule-loaded-p t)))
+ (gnus-with-article-buffer
+ (if (memq 'smiley gnus-article-wash-types)
+ (gnus-delete-images 'smiley)
+ (article-goto-body)
+ (let ((images (smiley-region (point) (point-max))))
+ (when images
+ (gnus-add-wash-type 'smiley)
+ (dolist (image images)
+ (gnus-add-image 'smiley image)))))))
+
+(defun gnus-article-remove-images ()
+ "Remove all images from the article buffer."
+ (interactive)
+ (gnus-with-article-buffer
+ (dolist (elem gnus-article-image-alist)
+ (gnus-delete-images (car elem)))))
+
+(defun gnus-article-treat-fold-newsgroups ()
+ "Unfold folded message headers.
+Only the headers that fit into the current window width will be
+unfolded."
+ (interactive)
+ (gnus-with-article-headers
+ (while (gnus-article-goto-header "newsgroups\\|followup-to")
+ (save-restriction
+ (mail-header-narrow-to-field)
+ (while (re-search-forward ", *" nil t)
+ (replace-match ", " t t))
+ (mail-header-fold-field)
+ (goto-char (point-max))))))
+
+(defun gnus-article-treat-body-boundary ()
+ "Place a boundary line at the end of the headers."
+ (interactive)
+ (when (and gnus-body-boundary-delimiter
+ (> (length gnus-body-boundary-delimiter) 0))
+ (gnus-with-article-headers
+ (goto-char (point-max))
+ (let ((start (point)))
+ (insert "X-Boundary: ")
+ (gnus-add-text-properties start (point) '(invisible t intangible t))
+ (insert (let (str)
+ (while (>= (1- (window-width)) (length str))
+ (setq str (concat str gnus-body-boundary-delimiter)))
+ (substring str 0 (1- (window-width))))
+ "\n")
+ (gnus-put-text-property start (point) 'gnus-decoration 'header)))))
(defun article-fill-long-lines ()
"Fill lines that are wider than the window width."
(interactive)
(save-excursion
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(width (window-width (get-buffer-window (current-buffer)))))
(save-restriction
(article-goto-body)
- (let ((adaptive-fill-mode nil))
+ (let ((adaptive-fill-mode nil)) ;Why? -sm
(while (not (eobp))
(end-of-line)
(when (>= (current-column) (min fill-column width))
- (narrow-to-region (point) (gnus-point-at-bol))
- (fill-paragraph nil)
- (goto-char (point-max))
+ (narrow-to-region (min (1+ (point)) (point-max))
+ (point-at-bol))
+ (let ((goback (point-marker)))
+ (fill-paragraph nil)
+ (goto-char (marker-position goback)))
(widen))
(forward-line 1)))))))
"Capitalize the first word in each sentence."
(interactive)
(save-excursion
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(paragraph-start "^[\n\^L]"))
(article-goto-body)
(while (not (eobp))
"Remove trailing CRs and then translate remaining CRs into LFs."
(interactive)
(save-excursion
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(goto-char (point-min))
(while (re-search-forward "\r+$" nil t)
(replace-match "" t t))
"Remove all trailing blank lines from the article."
(interactive)
(save-excursion
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(goto-char (point-max))
(delete-region
(point)
(while (and (not (bobp))
(looking-at "^[ \t]*$")
(not (gnus-annotation-in-region-p
- (point) (gnus-point-at-eol))))
+ (point) (point-at-eol))))
(forward-line -1))
(forward-line 1)
(point))))))
+(eval-when-compile
+ (defvar gnus-face-properties-alist))
+
+(defun article-display-face ()
+ "Display any Face headers in the header."
+ (interactive)
+ (let ((wash-face-p buffer-read-only))
+ (gnus-with-article-headers
+ ;; When displaying parts, this function can be called several times on
+ ;; the same article, without any intended toggle semantic (as typing `W
+ ;; D d' would have). So face deletion must occur only when we come from
+ ;; an interactive command, that is when the *Article* buffer is
+ ;; read-only.
+ (if (and wash-face-p (memq 'face gnus-article-wash-types))
+ (gnus-delete-images 'face)
+ (let (face faces)
+ (save-excursion
+ (when (and wash-face-p
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward "^Face:[\t ]*" nil t)))
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ (set-buffer gnus-original-article-buffer))
+ (save-restriction
+ (mail-narrow-to-head)
+ (while (gnus-article-goto-header "Face")
+ (setq faces (nconc faces (list (mail-header-field-value)))))))
+ (dolist (face faces)
+ (let ((png (gnus-convert-face-to-png face))
+ image)
+ (when png
+ (setq image
+ (apply 'gnus-create-image png 'png t
+ (cdr (assq 'png gnus-face-properties-alist))))
+ (gnus-article-goto-header "from")
+ (when (bobp)
+ (insert "From: [no `from' set]\n")
+ (forward-char -17))
+ (gnus-add-wash-type 'face)
+ (gnus-add-image 'face image)
+ (gnus-put-image image nil 'face))))))
+ )))
+
(defun article-display-x-face (&optional force)
"Look for an X-Face header and display it if present."
(interactive (list 'force))
- (save-excursion
- ;; Delete the old process, if any.
- (when (process-status "article-x-face")
- (delete-process "article-x-face"))
- (let ((inhibit-point-motion-hooks t)
- (case-fold-search t)
- from last)
- (save-restriction
- (article-narrow-to-head)
- (goto-char (point-min))
- (setq from (message-fetch-field "from"))
- (goto-char (point-min))
- (while (and gnus-article-x-face-command
- (not last)
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from))))
- ;; Has to be present.
- (re-search-forward "^X-Face: " 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
- ;; multiple faces really something to encourage?
- (when (stringp gnus-article-x-face-command)
- (setq last t))
- ;; We now have the area of the buffer where the X-Face is stored.
+ (let ((wash-face-p buffer-read-only)) ;; When type `W f'
+ (gnus-with-article-headers
+ ;; Delete the old process, if any.
+ (when (process-status "article-x-face")
+ (delete-process "article-x-face"))
+ ;; See the comment in `article-display-face'.
+ (if (and wash-face-p (memq 'xface gnus-article-wash-types))
+ ;; We have already displayed X-Faces, so we remove them
+ ;; instead.
+ (gnus-delete-images 'xface)
+ ;; Display X-Faces.
+ (let (x-faces from face)
(save-excursion
- (let ((beg (point))
- (end (1- (re-search-forward "^\\($\\|[^ \t]\\)" nil t))))
- ;; We display the face.
- (if (symbolp gnus-article-x-face-command)
- ;; The command is a lisp function, so we call it.
- (if (gnus-functionp gnus-article-x-face-command)
- (funcall gnus-article-x-face-command beg end)
- (error "%s is not a function" gnus-article-x-face-command))
- ;; The command is a string, so we interpret the command
- ;; as a, well, command, and fork it off.
- (let ((process-connection-type nil))
- (process-kill-without-query
- (start-process
- "article-x-face" nil shell-file-name shell-command-switch
- gnus-article-x-face-command))
- (process-send-region "article-x-face" beg end)
- (process-send-eof "article-x-face"))))))))))
+ (when (and wash-face-p
+ (progn
+ (goto-char (point-min))
+ (not (re-search-forward
+ "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ ;; If type `W f', use gnus-original-article-buffer,
+ ;; otherwise use the current buffer because displaying
+ ;; RFC822 parts calls this function too.
+ (set-buffer gnus-original-article-buffer))
+ (save-restriction
+ (mail-narrow-to-head)
+ (while (gnus-article-goto-header "X-Face")
+ (push (mail-header-field-value) x-faces))
+ (setq from (message-fetch-field "from"))))
+ ;; Sending multiple EOFs to xv doesn't work, so we only do a
+ ;; single external face.
+ (when (stringp gnus-article-x-face-command)
+ (setq x-faces (list (car x-faces))))
+ (while (and (setq face (pop x-faces))
+ gnus-article-x-face-command
+ (or force
+ ;; Check whether this face is censored.
+ (not gnus-article-x-face-too-ugly)
+ (and gnus-article-x-face-too-ugly from
+ (not (string-match gnus-article-x-face-too-ugly
+ from)))))
+ ;; We display the face.
+ (cond ((stringp gnus-article-x-face-command)
+ ;; The command is a string, so we interpret the command
+ ;; as a, well, command, and fork it off.
+ (let ((process-connection-type nil))
+ (process-kill-without-query
+ (start-process
+ "article-x-face" nil shell-file-name
+ shell-command-switch gnus-article-x-face-command))
+ (with-temp-buffer
+ (insert face)
+ (process-send-region "article-x-face"
+ (point-min) (point-max)))
+ (process-send-eof "article-x-face")))
+ ((functionp gnus-article-x-face-command)
+ ;; The command is a lisp function, so we call it.
+ (funcall gnus-article-x-face-command face))
+ (t
+ (error "%s is not a function"
+ gnus-article-x-face-command)))))))))
(defun article-decode-mime-words ()
"Decode all MIME-encoded words in the article."
(interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (gnus-with-article-buffer
(let ((inhibit-point-motion-hooks t)
- buffer-read-only
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
(mail-decode-encoded-word-region (point-min) (point-max)))))
(defun article-decode-charset (&optional prompt)
"Decode charset-encoded text in the article.
If PROMPT (the prefix), prompt for a coding system to use."
(interactive "P")
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (let* ((inhibit-point-motion-hooks t)
- (case-fold-search t)
- (ct (message-fetch-field "Content-Type" t))
- (cte (message-fetch-field "Content-Transfer-Encoding" t))
- (ctl (and ct (ignore-errors
- (mail-header-parse-content-type ct))))
- (charset (cond
+ (let ((inhibit-point-motion-hooks t) (case-fold-search t)
+ (inhibit-read-only 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))
+ ct cte ctl charset format)
+ (save-excursion
+ (save-restriction
+ (article-narrow-to-head)
+ (setq ct (message-fetch-field "Content-Type" t)
+ cte (message-fetch-field "Content-Transfer-Encoding" t)
+ ctl (and ct (ignore-errors
+ (mail-header-parse-content-type ct)))
+ charset (cond
(prompt
(mm-read-coding-system "Charset to decode: "))
(ctl
- (mail-content-type-get ctl 'charset))))
- (mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets))
- buffer-read-only)
- (goto-char (point-max))
- (widen)
- (forward-line 1)
+ (mail-content-type-get ctl 'charset)))
+ format (and ctl (mail-content-type-get ctl 'format)))
+ (when cte
+ (setq cte (mail-header-strip cte)))
+ (if (and ctl (not (string-match "/" (car ctl))))
+ (setq ctl nil))
+ (goto-char (point-max)))
+ (forward-line 1)
+ (save-restriction
(narrow-to-region (point) (point-max))
+ (when (and (eq mail-parse-charset 'gnus-decoded)
+ (eq (mm-body-7-or-8) '8bit))
+ ;; The text code could have been decoded.
+ (setq charset mail-parse-charset))
(when (and (or (not ctl)
(equal (car ctl) "text/plain"))
- (not (mm-uu-test)))
+ (not format)) ;; article with format will decode later.
(mm-decode-body
charset (and cte (intern (downcase
(gnus-strip-whitespace cte))))
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
- (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)
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset))
+ (inhibit-read-only t))
+ (mime-decode-header-in-buffer charset)))
+
+(defun article-decode-group-name ()
+ "Decode group names in `Newsgroups:'."
+ (let ((inhibit-point-motion-hooks t)
+ (inhibit-read-only t)
+ (method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (when (and (or gnus-group-name-charset-method-alist
+ gnus-group-name-charset-group-alist)
+ (gnus-buffer-live-p gnus-original-article-buffer))
+ (save-restriction
+ (article-narrow-to-head)
+ (with-current-buffer gnus-original-article-buffer
+ (goto-char (point-min)))
+ (while (re-search-forward
+ "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
+ (replace-match (save-match-data
+ (gnus-decode-newsgroups
+ ;; XXX how to use data in article buffer?
+ (with-current-buffer gnus-original-article-buffer
+ (re-search-forward
+ "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
+ nil t)
+ (match-string 1))
+ gnus-newsgroup-name method))
+ t t nil 1))
+ (goto-char (point-min))
+ (with-current-buffer gnus-original-article-buffer
+ (goto-char (point-min)))
+ (while (re-search-forward
+ "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
+ (replace-match (save-match-data
+ (gnus-decode-newsgroups
+ ;; XXX how to use data in article buffer?
+ (with-current-buffer gnus-original-article-buffer
+ (re-search-forward
+ "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
+ nil t)
+ (match-string 1))
+ gnus-newsgroup-name method))
+ t t nil 1))))))
+
+(autoload 'idna-to-unicode "idna")
+
+(defun article-decode-idna-rhs ()
+ "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer."
+ (when gnus-use-idna
+ (save-restriction
+ (let ((inhibit-point-motion-hooks t)
+ (inhibit-read-only t))
+ (article-narrow-to-head)
+ (goto-char (point-min))
+ (while (re-search-forward "@.*\\(xn--[-A-Za-z0-9.]*\\)[ \t\n\r,>]" nil t)
+ (let (ace unicode)
+ (when (save-match-data
+ (and (setq ace (match-string 1))
+ (save-excursion
+ (and (re-search-backward "^[^ \t]" nil t)
+ (looking-at "From\\|To\\|Cc")))
+ (setq unicode (idna-to-unicode ace))))
+ (unless (string= ace unicode)
+ (replace-match unicode nil nil nil 1)))))))))
+
+(defun article-de-quoted-unreadable (&optional force read-charset)
"Translate a quoted-printable-encoded article.
If FORCE, decode the article whether it is marked as quoted-printable
-or not."
- (interactive (list 'force))
+or not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
(save-excursion
- (let ((buffer-read-only nil)
- (type (gnus-fetch-field "content-transfer-encoding"))
- (charset gnus-newsgroup-charset))
+ (let ((inhibit-read-only t) type charset)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (setq type
+ (gnus-fetch-field "content-transfer-encoding"))
+ (let* ((ct (gnus-fetch-field "content-type"))
+ (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)))))))
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
+ (setq charset gnus-newsgroup-charset))
(when (or force
- (and type (string-match "quoted-printable" (downcase type))))
+ (and type (let ((case-fold-search t))
+ (string-match "quoted-printable" type))))
+ (article-goto-body)
+ (quoted-printable-decode-region
+ (point) (point-max) (mm-charset-to-coding-system charset))))))
+
+(defun article-de-base64-unreadable (&optional force read-charset)
+ "Translate a base64 article.
+If FORCE, decode the article whether it is marked as base64 not.
+If READ-CHARSET, ask for a coding system."
+ (interactive (list 'force current-prefix-arg))
+ (save-excursion
+ (let ((inhibit-read-only t) type charset)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (with-current-buffer gnus-original-article-buffer
+ (setq type
+ (gnus-fetch-field "content-transfer-encoding"))
+ (let* ((ct (gnus-fetch-field "content-type"))
+ (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)))))))
+ (if read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
+ (setq charset gnus-newsgroup-charset))
+ (when (or force
+ (and type (let ((case-fold-search t))
+ (string-match "base64" type))))
(article-goto-body)
(save-restriction
(narrow-to-region (point) (point-max))
- (quoted-printable-decode-region (point-min) (point-max))
- (when charset
- (mm-decode-body charset)))))))
+ (base64-decode-region (point-min) (point-max))
+ (mm-decode-coding-region
+ (point-min) (point-max) (mm-charset-to-coding-system charset)))))))
-(defun article-hide-pgp ()
- "Remove any PGP headers and signatures in the current article."
+(eval-when-compile
+ (require 'rfc1843))
+
+(defun article-decode-HZ ()
+ "Translate a HZ-encoded article."
(interactive)
+ (require 'rfc1843)
(save-excursion
- (save-restriction
- (let ((inhibit-point-motion-hooks t)
- buffer-read-only beg end)
- (article-goto-body)
- ;; Hide the "header".
- (when (re-search-forward "^-----BEGIN PGP SIGNED MESSAGE-----\n" nil t)
- (push 'pgp gnus-article-wash-types)
- (delete-region (match-beginning 0) (match-end 0))
- ;; PGP 5 and GNU PG add a `Hash: <>' comment, hide that too
- (when (looking-at "Hash:.*$")
- (delete-region (point) (1+ (gnus-point-at-eol))))
- (setq beg (point))
- ;; Hide the actual signature.
- (and (search-forward "\n-----BEGIN PGP SIGNATURE-----\n" nil t)
- (setq end (1+ (match-beginning 0)))
- (delete-region
- end
- (if (search-forward "\n-----END PGP SIGNATURE-----\n" nil t)
- (match-end 0)
- ;; Perhaps we shouldn't hide to the end of the buffer
- ;; if there is no end to the signature?
- (point-max))))
- ;; Hide "- " PGP quotation markers.
- (when (and beg end)
- (narrow-to-region beg end)
- (goto-char (point-min))
- (while (re-search-forward "^- " nil t)
- (delete-region
- (match-beginning 0) (match-end 0)))
- (widen))
- (gnus-run-hooks 'gnus-article-hide-pgp-hook))))))
+ (let ((inhibit-read-only t))
+ (rfc1843-decode-region (point-min) (point-max)))))
+
+(defun article-unsplit-urls ()
+ "Remove the newlines that some other mailers insert into URLs."
+ (interactive)
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (goto-char (point-min))
+ (while (re-search-forward
+ "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
+ (replace-match "\\1\\3" t)))
+ (when (interactive-p)
+ (gnus-treat-article nil))))
+
+
+(defun article-wash-html (&optional read-charset)
+ "Format an HTML article.
+If READ-CHARSET, ask for a coding system."
+ (interactive "P")
+ (save-excursion
+ (let ((inhibit-read-only t)
+ charset)
+ (when (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
+ (ignore-errors
+ (mail-header-parse-content-type ct)))))
+ (setq charset (and ctl
+ (mail-content-type-get ctl 'charset)))
+ (when (stringp charset)
+ (setq charset (intern (downcase charset)))))))
+ (when read-charset
+ (setq charset (mm-read-coding-system "Charset: " charset)))
+ (unless charset
+ (setq charset gnus-newsgroup-charset))
+ (article-goto-body)
+ (save-window-excursion
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (let* ((func (or gnus-article-wash-function mm-text-html-renderer))
+ (entry (assq func mm-text-html-washer-alist)))
+ (when entry
+ (setq func (cdr entry)))
+ (cond
+ ((functionp func)
+ (funcall func))
+ (t
+ (apply (car func) (cdr func))))))))))
+
+(defun gnus-article-wash-html-with-w3 ()
+ "Wash the current buffer with w3."
+ (mm-setup-w3)
+ (let ((w3-strict-width (window-width))
+ (url-standalone-mode t)
+ (url-gateway-unplugged t)
+ (w3-honor-stylesheets nil))
+ (condition-case ()
+ (w3-region (point-min) (point-max))
+ (error))))
+
+(defun gnus-article-wash-html-with-w3m ()
+ "Wash the current buffer with emacs-w3m."
+ (mm-setup-w3m)
+ (save-restriction
+ (narrow-to-region (point) (point-max))
+ (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
+ w3m-force-redisplay)
+ (w3m-region (point-min) (point-max)))
+ (when (and mm-inline-text-html-with-w3m-keymap
+ (boundp 'w3m-minor-mode-map)
+ w3m-minor-mode-map)
+ (add-text-properties
+ (point-min) (point-max)
+ (list 'keymap w3m-minor-mode-map
+ ;; Put the mark meaning this part was rendered by emacs-w3m.
+ 'mm-inline-text-html-with-w3m t)))))
+
+(defun article-hide-list-identifiers ()
+ "Remove list identifies from the Subject header.
+The `gnus-list-identifiers' variable specifies what to do."
+ (interactive)
+ (let ((inhibit-point-motion-hooks t)
+ (regexp (if (consp gnus-list-identifiers)
+ (mapconcat 'identity gnus-list-identifiers " *\\|")
+ gnus-list-identifiers))
+ (inhibit-read-only t))
+ (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-pem (&optional arg)
"Toggle hiding of any PEM headers and signatures in the current article.
(interactive (gnus-article-hidden-arg))
(unless (gnus-article-check-hidden-text 'pem arg)
(save-excursion
- (let (buffer-read-only end)
+ (let ((inhibit-read-only t) end)
(goto-char (point-min))
;; Hide the horrendously ugly "header".
(when (and (search-forward
"\n-----BEGIN PRIVACY-ENHANCED MESSAGE-----\n"
nil t)
(setq end (1+ (match-beginning 0))))
- (push 'pem gnus-article-wash-types)
+ (gnus-add-wash-type 'pem)
(gnus-article-hide-text-type
end
(if (search-forward "\n\n" nil t)
(match-beginning 0) (match-end 0) 'pem)))))))
(defun article-strip-banner ()
- "Strip the banner specified by the `banner' group parameter."
+ "Strip the banners specified by the `banner' group parameter and by
+`gnus-article-address-banner-alist'."
(interactive)
(save-excursion
(save-restriction
+ (let ((inhibit-point-motion-hooks t))
+ (when (gnus-parameter-banner gnus-newsgroup-name)
+ (article-really-strip-banner
+ (gnus-parameter-banner gnus-newsgroup-name)))
+ (when gnus-article-address-banner-alist
+ ;; It is necessary to encode from fields before checking,
+ ;; because `mail-header-parse-addresses' does not work
+ ;; (reliably) on decoded headers. And more, it is
+ ;; impossible to use `gnus-fetch-original-field' here,
+ ;; because `article-strip-banner' may be called in draft
+ ;; buffers to preview them.
+ (let ((from (save-restriction
+ (widen)
+ (article-narrow-to-head)
+ (mail-fetch-field "from"))))
+ (when (and from
+ (setq from
+ (caar (mail-header-parse-addresses
+ (mail-encode-encoded-word-string from)))))
+ (catch 'found
+ (dolist (pair gnus-article-address-banner-alist)
+ (when (string-match (car pair) from)
+ (throw 'found
+ (article-really-strip-banner (cdr pair)))))))))))))
+
+(defun article-really-strip-banner (banner)
+ "Strip the banner specified by the argument."
+ (save-excursion
+ (save-restriction
(let ((inhibit-point-motion-hooks t)
- (banner (gnus-group-get-parameter gnus-newsgroup-name 'banner))
(gnus-signature-limit nil)
- buffer-read-only beg end)
- (when banner
- (article-goto-body)
- (cond
- ((eq banner 'signature)
- (when (gnus-article-narrow-to-signature)
- (widen)
- (forward-line -1)
- (delete-region (point) (point-max))))
- ((stringp banner)
- (while (re-search-forward banner nil t)
- (delete-region (match-beginning 0) (match-end 0))))))))))
-
-(defun article-babel-prompt ()
- "Prompt for a babel translation."
- (require 'babel)
- (completing-read "Translate from: "
- babel-translations nil t
- (car (car babel-translations))
- babel-history))
-
-(defun article-babel (translation)
- "Translate article according to TRANSLATION using babelfish."
- (interactive (list (article-babel-prompt)))
+ (inhibit-read-only t))
+ (article-goto-body)
+ (cond
+ ((eq banner 'signature)
+ (when (gnus-article-narrow-to-signature)
+ (widen)
+ (forward-line -1)
+ (delete-region (point) (point-max))))
+ ((symbolp banner)
+ (if (setq banner (cdr (assq banner gnus-article-banner-alist)))
+ (while (re-search-forward banner nil t)
+ (delete-region (match-beginning 0) (match-end 0)))))
+ ((stringp banner)
+ (while (re-search-forward banner nil t)
+ (delete-region (match-beginning 0) (match-end 0)))))))))
+
+(defun article-babel ()
+ "Translate article using an online translation service."
+ (interactive)
(require 'babel)
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (gnus-with-article-buffer
(when (article-goto-body)
- (let* ((buffer-read-only nil)
- (start (point))
+ (let* ((start (point))
(end (point-max))
- (msg (buffer-substring start end)))
+ (orig (buffer-substring start end))
+ (trans (babel-as-string orig)))
(save-restriction
(narrow-to-region start end)
(delete-region start end)
- (babel-fetch msg (cdr (assoc translation babel-translations)))
- (save-restriction
- (narrow-to-region start (point-max))
- (babel-wash)))))))
+ (insert trans))))))
(defun article-hide-signature (&optional arg)
"Hide the signature in the current article.
If given a negative prefix, always show; if given a positive prefix,
always hide."
(interactive (gnus-article-hidden-arg))
- (unless (gnus-article-check-hidden-text 'signature arg)
- (save-excursion
- (save-restriction
- (let ((buffer-read-only nil))
- (when (gnus-article-narrow-to-signature)
- (gnus-article-hide-text-type
- (point-min) (point-max) 'signature)))))))
+ (save-excursion
+ (save-restriction
+ (if (interactive-p)
+ (progn
+ (widen)
+ (article-goto-body))
+ (goto-char (point-min)))
+ (unless (gnus-article-check-hidden-text 'signature arg)
+ (let ((inhibit-read-only t)
+ (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)))))))
+ (gnus-set-mode-line 'article))
(defun article-strip-headers-in-body ()
"Strip offensive headers from bodies."
(interactive)
(save-excursion
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ (inhibit-read-only t))
(when (article-goto-body)
(while (and (not (eobp))
(looking-at "[ \t]*$"))
(interactive)
(save-excursion
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ (inhibit-read-only t))
;; First make all blank lines empty.
(article-goto-body)
(while (re-search-forward "^[ \t]+$" nil t)
(replace-match "" nil t)))
;; Then replace multiple empty lines with a single empty line.
(article-goto-body)
- (while (re-search-forward "\n\n\n+" nil t)
+ (while (re-search-forward "\n\n\\(\n+\\)" nil t)
(unless (gnus-annotation-in-region-p
(match-beginning 0) (match-end 0))
- (replace-match "\n\n" t t))))))
+ (delete-region (match-beginning 1) (match-end 1)))))))
(defun article-strip-leading-space ()
"Remove all white space from the beginning of the lines in the article."
(interactive)
(save-excursion
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ (inhibit-read-only t))
(article-goto-body)
(while (re-search-forward "^[ \t]+" nil t)
(replace-match "" t t)))))
(interactive)
(save-excursion
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ (inhibit-read-only t))
(article-goto-body)
(while (re-search-forward "[ \t]+$" nil t)
(replace-match "" t t)))))
(interactive)
(save-excursion
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ (inhibit-read-only t))
(article-goto-body)
(while (re-search-forward "^[ \t]*\n" nil t)
(replace-match "" t t)))))
(< (- (point-max) (point)) limit))
(and (floatp limit)
(< (count-lines (point) (point-max)) limit))
- (and (gnus-functionp limit)
+ (and (functionp limit)
(funcall limit))
(and (stringp limit)
(not (re-search-forward limit nil t))))
(defun gnus-article-check-hidden-text (type arg)
"Return nil if hiding is necessary.
-Arg can be nil or a number. Nil and positive means hide, negative
+Arg can be nil or a number. nil and positive means hide, negative
means show, 0 means toggle."
(save-excursion
(save-restriction
(> arg 0))
nil)
((< arg 0)
- (gnus-article-show-hidden-text type))
+ (gnus-article-show-hidden-text type)
+ t)
(t
(if (eq hide 'hidden)
- (gnus-article-show-hidden-text type)
+ (progn
+ (gnus-article-show-hidden-text type)
+ t)
nil)))))))
(defun gnus-article-hidden-text-p (type)
'hidden
nil)))
-(defun gnus-article-show-hidden-text (type &optional hide)
+(defun gnus-article-show-hidden-text (type &optional dummy)
"Show all hidden text of type TYPE.
-If HIDE, hide the text instead."
- (save-excursion
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (end (point-min))
- beg)
- (while (setq beg (text-property-any end (point-max) 'article-type type))
- (goto-char beg)
- (setq end (or
- (text-property-not-all beg (point-max) 'article-type type)
- (point-max)))
- (if hide
- (gnus-article-hide-text beg end gnus-hidden-properties)
- (gnus-article-unhide-text beg end))
- (goto-char end))
- t)))
+Originally it is hide instead of DUMMY."
+ (let ((inhibit-read-only t)
+ (inhibit-point-motion-hooks t))
+ (gnus-remove-text-properties-when
+ 'article-type type
+ (point-min) (point-max)
+ (cons 'article-type (cons type
+ gnus-hidden-properties)))
+ (gnus-delete-wash-type type)))
(defconst article-time-units
`((year . ,(* 365.25 24 60 60))
(second . 1))
"Mapping from time units to seconds.")
+(defun gnus-article-forward-header ()
+ "Move point to the start of the next header.
+If the current header is a continuation header, this can be several
+lines forward."
+ (let ((ended nil))
+ (while (not ended)
+ (forward-line 1)
+ (if (looking-at "[ \t]+[^ \t]")
+ (forward-line 1)
+ (setq ended t)))))
+
(defun article-date-ut (&optional type highlight header)
"Convert DATE date to universal time in the current article.
If TYPE is `local', convert to local time; if it is `lapsed', output
-how much time has lapsed since DATE. For `lapsed', the value of
+how much time has lapsed since DATE. For `lapsed', the value of
`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
should replace the \"Date:\" one, or should be added below it."
(interactive (list 'ut t))
(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)
- eface (get-text-property (1- (gnus-point-at-eol))
+ (setq bface (get-text-property (point-at-bol) 'face)
+ date (or (get-text-property (point-at-bol)
+ 'original-date)
+ date)
+ eface (get-text-property (1- (point-at-eol))
'face)))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
;; Delete any old X-Sent headers.
(when (setq date-pos
(text-property-any (point-min) (point-max)
(goto-char (point-min)))
(insert (article-make-date-line date type))
(when (eq type 'lapsed)
- (put-text-property (gnus-point-at-bol) (point)
+ (put-text-property (point-at-bol) (point)
'article-date-lapsed t))
(insert "\n")
(forward-line -1)
;; Do highlighting.
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
+ (add-text-properties (match-beginning 1) (1+ (match-end 1))
+ (list 'original-date date 'face bface))
(put-text-property (match-beginning 2) (match-end 2)
'face eface))))))))
(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))))
- (format "Date: %s %s%04d" (current-time-string time)
- (if (> tz 0) "+" "-") (abs (/ tz 36)))))
- ;; 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)))))
- (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)
- (concat
- "Date: "
- (format-time-string "%Y%m%dT%H%M%S" time)))
- ;; 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)
+ (concat "Date: " (message-make-date time)))
+ ;; Convert to Universal Time.
+ ((eq type 'ut)
+ (concat "Date: "
+ (substring
+ (message-make-date
+ (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)))))
+ 0 -5)
+ "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)
+ (let ((format (or (condition-case nil
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-time-format)
+ (error nil))
+ gnus-article-time-format)))
+ (if (functionp format)
+ (funcall format time)
+ (concat "Date: " (format-time-string 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 T-gnus)" 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
(lambda (w)
(set-buffer (window-buffer w))
(when (eq major-mode 'gnus-article-mode)
- (goto-char (point-min))
- (when (re-search-forward "^X-Sent:" nil t)
- (article-date-lapsed t))))
+ (let ((mark (point-marker)))
+ (goto-char (point-min))
+ (when (re-search-forward "^X-Sent:" nil t)
+ (article-date-lapsed t))
+ (goto-char (marker-position mark))
+ (move-marker mark nil))))
nil 'visible)))))
(defun gnus-start-date-timer (&optional n)
(setq n 1))
(gnus-stop-date-timer)
(setq article-lapsed-timer
- (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
+ (run-at-time 1 n 'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
"Stop the X-Sent timer."
(interactive (list t))
(article-date-ut 'iso8601 highlight))
-(defun article-show-all ()
- "Show all hidden text in the article buffer."
+;; (defun article-show-all ()
+;; "Show all hidden text in the article buffer."
+;; (interactive)
+;; (save-excursion
+;; (widen)
+;; (let ((inhibit-read-only t))
+;; (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 ((inhibit-read-only t))
+ (gnus-article-unhide-text (point-min) (point-max))))))
+
+(defun article-remove-leading-whitespace ()
+ "Remove excessive whitespace from all headers."
(interactive)
(save-excursion
- (let ((buffer-read-only nil))
- (gnus-article-unhide-text (point-min) (point-max)))))
+ (save-restriction
+ (let ((inhibit-read-only t))
+ (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 (with-current-buffer gnus-summary-buffer
- gnus-article-emphasis-alist)
- gnus-emphasis-alist))
- (buffer-read-only nil)
+ (let ((alist (or
+ (condition-case nil
+ (with-current-buffer gnus-summary-buffer
+ gnus-article-emphasis-alist)
+ (error))
+ gnus-emphasis-alist))
+ (inhibit-read-only t)
(props (append '(article-type emphasis)
gnus-hidden-properties))
regexp elem beg invisible visible face)
visible (nth 2 elem)
face (nth 3 elem))
(while (re-search-forward regexp nil t)
- (when (and (match-beginning visible) (match-beginning invisible))
- (gnus-article-hide-text
- (match-beginning invisible) (match-end invisible) props)
- (gnus-article-unhide-text-type
- (match-beginning visible) (match-end visible) 'emphasis)
- (gnus-put-text-property-excluding-newlines
- (match-beginning visible) (match-end visible) 'face face)
- (goto-char (match-end invisible)))))))))
+ (when (and (match-beginning visible) (match-beginning invisible))
+ (gnus-article-hide-text
+ (match-beginning invisible) (match-end invisible) props)
+ (gnus-article-unhide-text-type
+ (match-beginning visible) (match-end visible) 'emphasis)
+ (gnus-put-overlay-excluding-newlines
+ (match-beginning visible) (match-end visible) 'face face)
+ (gnus-add-wash-type 'emphasis)
+ (goto-char (match-end invisible)))))))))
(defun gnus-article-setup-highlight-words (&optional highlight-words)
"Setup newsgroup emphasis alist."
(let ((name (and gnus-newsgroup-name
(gnus-group-real-name gnus-newsgroup-name))))
(make-local-variable 'gnus-article-emphasis-alist)
- (setq gnus-article-emphasis-alist
- (nconc
+ (setq gnus-article-emphasis-alist
+ (nconc
(let ((alist gnus-group-highlight-words-alist) elem highlight)
(while (setq elem (pop alist))
(when (and name (string-match (car elem) name))
(setq alist nil
- highlight (copy-list (cdr elem)))))
+ highlight (copy-sequence (cdr elem)))))
highlight)
- (copy-list highlight-words)
+ (copy-sequence highlight-words)
(if gnus-newsgroup-name
- (copy-list (gnus-group-find-parameter
- gnus-newsgroup-name 'highlight-words t)))
+ (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.
(let ((default-name
(funcall function group headers (symbol-value variable)))
result)
- (setq
- result
- (cond
- ((eq filename 'default)
- default-name)
- ((eq filename t)
- default-name)
- (filename filename)
- (t
- (let* ((split-name (gnus-get-split-value gnus-split-methods))
- (prompt
- (format prompt
- (if (and gnus-number-of-articles-to-be-saved
- (> gnus-number-of-articles-to-be-saved 1))
- (format "these %d articles"
- gnus-number-of-articles-to-be-saved)
- "this article")))
- (file
- ;; Let the split methods have their say.
- (cond
- ;; No split name was found.
- ((null split-name)
- (read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
- (file-name-directory default-name)
- default-name))
- ;; A single group name is returned.
- ((stringp split-name)
- (setq default-name
- (funcall function split-name headers
- (symbol-value variable)))
- (read-file-name
- (concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
- (file-name-directory default-name)
- default-name))
- ;; A single split name was found
- ((= 1 (length split-name))
- (let* ((name (expand-file-name
- (car split-name) gnus-article-save-directory))
- (dir (cond ((file-directory-p name)
- (file-name-as-directory name))
- ((file-exists-p name) name)
- (t gnus-article-save-directory))))
- (read-file-name
- (concat prompt " (default " name ") ")
- dir name)))
- ;; A list of splits was found.
- (t
- (setq split-name (nreverse split-name))
- (let (result)
- (let ((file-name-history
- (nconc split-name file-name-history)))
- (setq result
- (expand-file-name
- (read-file-name
- (concat prompt " (`M-p' for defaults) ")
- gnus-article-save-directory
- (car split-name))
- gnus-article-save-directory)))
- (car (push result file-name-history)))))))
- ;; Create the directory.
- (gnus-make-directory (file-name-directory file))
- ;; If we have read a directory, we append the default file name.
- (when (file-directory-p file)
- (setq file (concat (file-name-as-directory file)
- (file-name-nondirectory default-name))))
- ;; Possibly translate some characters.
- (nnheader-translate-file-chars file)))))
+ (setq result
+ (expand-file-name
+ (cond
+ ((eq filename 'default)
+ default-name)
+ ((eq filename t)
+ default-name)
+ (filename filename)
+ (t
+ (let* ((split-name (gnus-get-split-value gnus-split-methods))
+ (prompt
+ (format prompt
+ (if (and gnus-number-of-articles-to-be-saved
+ (> gnus-number-of-articles-to-be-saved 1))
+ (format "these %d articles"
+ gnus-number-of-articles-to-be-saved)
+ "this article")))
+ (file
+ ;; Let the split methods have their say.
+ (cond
+ ;; No split name was found.
+ ((null split-name)
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single group name is returned.
+ ((stringp split-name)
+ (setq default-name
+ (funcall function split-name headers
+ (symbol-value variable)))
+ (read-file-name
+ (concat prompt " (default "
+ (file-name-nondirectory default-name) ") ")
+ (file-name-directory default-name)
+ default-name))
+ ;; A single split name was found
+ ((= 1 (length split-name))
+ (let* ((name (expand-file-name
+ (car split-name)
+ gnus-article-save-directory))
+ (dir (cond ((file-directory-p name)
+ (file-name-as-directory name))
+ ((file-exists-p name) name)
+ (t gnus-article-save-directory))))
+ (read-file-name
+ (concat prompt " (default " name ") ")
+ dir name)))
+ ;; A list of splits was found.
+ (t
+ (setq split-name (nreverse split-name))
+ (let (result)
+ (let ((file-name-history
+ (nconc split-name file-name-history)))
+ (setq result
+ (expand-file-name
+ (read-file-name
+ (concat prompt " (`M-p' for defaults) ")
+ gnus-article-save-directory
+ (car split-name))
+ gnus-article-save-directory)))
+ (car (push result file-name-history)))))))
+ ;; Create the directory.
+ (gnus-make-directory (file-name-directory file))
+ ;; If we have read a directory, we append the default file name.
+ (when (file-directory-p file)
+ (setq file (expand-file-name (file-name-nondirectory
+ default-name)
+ (file-name-as-directory file))))
+ ;; Possibly translate some characters.
+ (nnheader-translate-file-chars file))))))
(gnus-make-directory (file-name-directory result))
(set variable result)))
(save-restriction
(widen)
(if (and (file-readable-p filename)
+ (file-regular-p filename)
(mail-file-babyl-p filename))
(rmail-output-to-rmail-file filename t)
(gnus-output-to-mail filename)))))
filename)
(defun gnus-summary-write-to-file (&optional filename)
- "Write this article to a file.
+ "Write this article to a file, overwriting it if the file exists.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(gnus-summary-save-in-file nil t))
(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)
(shell-command-on-region (point-min) (point-max) command nil)))
(setq gnus-last-shell-command command))
+(defun gnus-summary-pipe-to-muttprint (&optional command)
+ "Pipe this article to muttprint."
+ (setq command (read-string
+ "Print using command: " gnus-summary-muttprint-program
+ nil gnus-summary-muttprint-program))
+ (gnus-summary-save-in-pipe command))
+
;;; Article file names when saving.
(defun gnus-capitalize-newsgroup (newsgroup)
default
(or last-file default))))
-(defun gnus-Plain-save-name (newsgroup headers &optional last-file)
- "Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
-If variable `gnus-use-long-file-name' is non-nil, it is
-~/News/News.group. Otherwise, it is like ~/News/news/group/news."
- (or last-file
- (expand-file-name
- (if (gnus-use-long-file-name 'not-save)
- (gnus-capitalize-newsgroup newsgroup)
- (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
- gnus-article-save-directory)))
-
(defun gnus-plain-save-name (newsgroup headers &optional last-file)
"Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
If variable `gnus-use-long-file-name' is non-nil, it is
(expand-file-name
(if (gnus-use-long-file-name 'not-save)
newsgroup
- (concat (gnus-newsgroup-directory-form newsgroup) "/news"))
+ (file-relative-name
+ (expand-file-name "news" (gnus-newsgroup-directory-form newsgroup))
+ default-directory))
gnus-article-save-directory)))
+(defun gnus-sender-save-name (newsgroup headers &optional last-file)
+ "Generate file name from sender."
+ (let ((from (mail-header-from headers)))
+ (expand-file-name
+ (if (and from (string-match "\\([^ <]+\\)@" from))
+ (match-string 1 from)
+ "nobody")
+ gnus-article-save-directory)))
+
+(defun article-verify-x-pgp-sig ()
+ "Verify X-PGP-Sig."
+ (interactive)
+ (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-substring 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 ((inhibit-read-only t) bface eface)
+ (save-restriction
+ (message-narrow-to-head)
+ (goto-char (point-max))
+ (forward-line -1)
+ (setq bface (get-text-property (point-at-bol) 'face)
+ eface (get-text-property (1- (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)))))))))
+
+(defun article-verify-cancel-lock ()
+ "Verify Cancel-Lock header."
+ (interactive)
+ (if (gnus-buffer-live-p gnus-original-article-buffer)
+ (canlock-verify gnus-original-article-buffer)))
+
+(defun article-monafy ()
+ "Display body part with mona font."
+ (interactive)
+ (unless (if (featurep 'xemacs)
+ (find-face 'gnus-mona-face)
+ (facep 'gnus-mona-face))
+ (require 'navi2ch-mona)
+ (set-face-font (make-face 'gnus-mona-face) navi2ch-mona-font))
+ (save-excursion
+ (let ((inhibit-read-only t))
+ (article-goto-body)
+ (gnus-overlay-put
+ (gnus-make-overlay (point) (point-max))
+ 'face 'gnus-mona-face))))
+
(eval-and-compile
(mapcar
(lambda (func)
gfunc (cdr func))
(setq afunc func
gfunc (intern (format "gnus-%s" func))))
- (fset gfunc
- (if (not (fboundp afunc))
- nil
- `(lambda (&optional interactive &rest args)
- ,(documentation afunc t)
- (interactive (list t))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (if interactive
- (call-interactively ',afunc)
- (apply ',afunc args))))))))
+ (defalias gfunc
+ (when (fboundp afunc)
+ `(lambda (&optional interactive &rest args)
+ ,(documentation afunc t)
+ (interactive (list t))
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (if interactive
+ (call-interactively ',afunc)
+ (apply ',afunc args))))))))
'(article-hide-headers
+ article-verify-x-pgp-sig
+ article-verify-cancel-lock
+ article-monafy
article-hide-boring-headers
- article-toggle-headers
article-treat-overstrike
+ article-treat-ansi-sequences
article-fill-long-lines
article-capitalize-sentences
article-remove-cr
+ article-remove-leading-whitespace
article-display-x-face
+ article-display-face
article-de-quoted-unreadable
- article-hide-pgp
+ article-de-base64-unreadable
+ article-decode-HZ
+ article-wash-html
+ article-unsplit-urls
+ article-hide-list-identifiers
article-strip-banner
article-babel
article-hide-pem
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
"s" gnus-article-show-summary
"\C-c\C-m" gnus-article-mail
"?" gnus-article-describe-briefly
- gnus-mouse-2 gnus-article-push-button
- "\r" gnus-article-press-button
- "\t" gnus-article-next-button
- "\M-\t" gnus-article-prev-button
- "e" gnus-article-edit
+ "e" gnus-summary-edit-article
"<" beginning-of-buffer
">" end-of-buffer
"\C-c\C-i" gnus-info-find-node
"\C-c\C-b" gnus-bug
+ "R" gnus-article-reply-with-original
+ "F" gnus-article-followup-with-original
+ "\C-hk" gnus-article-describe-key
+ "\C-hc" gnus-article-describe-key-briefly
"\C-d" gnus-article-read-summary-keys
"\M-*" gnus-article-read-summary-keys
"\M-g" gnus-article-read-summary-keys)
;; Define almost undefined keys to `gnus-article-read-summary-keys'.
-(mapcar
- (lambda (key)
- (unless (lookup-key gnus-article-mode-map key)
- (define-key gnus-article-mode-map key
- 'gnus-article-read-summary-keys)))
- (delq nil
- (append
- (mapcar
- (lambda (elt)
- (let ((key (car elt)))
- (and (> (length key) 0)
- (not (eq 'menu-bar (aref key 0)))
- (symbolp (lookup-key gnus-summary-mode-map key))
- key)))
- (accessible-keymaps gnus-summary-mode-map))
- (let ((c 127)
- keys)
- (while (>= c 32)
- (push (char-to-string c) keys)
- (decf c))
- keys))))
+(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-toggle-headers t]
+ ["Hide headers" gnus-article-hide-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]))
+ ["Treat ANSI sequences" gnus-article-treat-ansi-sequences t]
+ ["Remove carriage return" gnus-article-remove-cr t]
+ ["Remove leading whitespace" gnus-article-remove-leading-whitespace t]
+ ["Treat html" gnus-article-wash-html t]
+ ["Remove newlines from within URLs" gnus-article-unsplit-urls 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)))
\\[gnus-article-describe-briefly]\t Describe the current mode briefly
\\[gnus-info-find-node]\t Go to the Gnus info node"
(interactive)
- (when (gnus-visual-p 'article-menu 'menu)
- (gnus-article-make-menu-bar))
(gnus-simplify-mode-line)
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(unless (assq 'gnus-show-mime minor-mode-alist)
(push (list 'gnus-show-mime " MIME") minor-mode-alist))
(use-local-map gnus-article-mode-map)
+ (when (gnus-visual-p 'article-menu 'menu)
+ (gnus-article-make-menu-bar)
+ (when gnus-summary-tool-bar-map
+ (set (make-local-variable 'tool-bar-map) gnus-summary-tool-bar-map)))
(gnus-update-format-specifications nil 'article-mode)
(set (make-local-variable 'page-delimiter) gnus-page-delimiter)
- (make-local-variable 'gnus-page-broken)
+ (set (make-local-variable 'gnus-page-broken) nil)
(make-local-variable 'gnus-button-marker-list)
(make-local-variable 'gnus-article-current-summary)
(make-local-variable 'gnus-article-mime-handles)
(make-local-variable 'gnus-article-decoded-p)
(make-local-variable 'gnus-article-mime-handle-alist)
- (make-local-variable 'gnus-article-washed-types)
+ (make-local-variable 'gnus-article-wash-types)
+ (make-local-variable 'gnus-article-image-alist)
+ (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)
+ (setq buffer-read-only t
+ show-trailing-whitespace nil)
(set-syntax-table gnus-article-mode-syntax-table)
(gnus-run-hooks 'gnus-article-mode-hook))
;; Init original article buffer.
(save-excursion
(set-buffer (gnus-get-buffer-create gnus-original-article-buffer))
+ (set-buffer-multibyte t)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
(if (get-buffer name)
(save-excursion
(set-buffer name)
+ (when (and gnus-article-edit-mode
+ (buffer-modified-p)
+ (not
+ (y-or-n-p "Article mode edit in progress; discard? ")))
+ (error "Action aborted"))
+ (set (make-local-variable 'gnus-article-edit-mode) nil)
(buffer-disable-undo)
(setq buffer-read-only t)
+ ;; This list just keeps growing if we don't reset it.
+ (setq gnus-button-marker-list nil)
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(current-buffer))
;; from the head of the article.
(defun gnus-article-set-window-start (&optional line)
(set-window-start
- (get-buffer-window gnus-article-buffer t)
+ (gnus-get-buffer-window gnus-article-buffer t)
(save-excursion
(set-buffer gnus-article-buffer)
(goto-char (point-min))
(mime-display-message mime-message-structure
gnus-article-buffer nil gnus-article-mode-map)
(when all-headers
- (gnus-article-hide-headers nil -1))
- )
- ;; `mime-display-message' changes current buffer to `gnus-article-buffer'.
- (make-local-variable 'mime-button-mother-dispatcher)
- (setq mime-button-mother-dispatcher
- (function gnus-article-push-button))
+ (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)
+ (let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring gnus-original-article-buffer)))
result)
(save-excursion
(gnus-article-setup-buffer)
- (set-buffer gnus-original-article-buffer)
+ (set-buffer gnus-article-buffer)
;; Deactivate active regions.
(when (and (boundp 'transient-mark-mode)
transient-mark-mode)
(setq mark-active nil))
- (if (not (setq result (let ((buffer-read-only nil))
+ (if (not (setq result (let ((inhibit-read-only t))
(gnus-request-article-this-buffer
article group))))
;; There is no such article.
(cons gnus-newsgroup-name article))
(set-buffer gnus-summary-buffer)
(setq gnus-current-article article)
- (if (eq (gnus-article-mark article) gnus-undownloaded-mark)
+ (if (and (memq article gnus-newsgroup-undownloaded)
+ (not (gnus-online (gnus-find-method-for-group
+ gnus-newsgroup-name))))
(progn
(gnus-summary-set-agent-mark article)
(message "Message marked for downloading"))
(gnus-summary-mark-article article gnus-canceled-mark)
(unless (memq article gnus-newsgroup-sparse)
- (gnus-error 1
- "No such article (may have expired or been canceled)")))))
+ (gnus-error 1 "No such article (may have expired or been canceled)")))))
(if (or (eq result 'pseudo)
(eq result 'nneething))
(progn
(gnus-set-global-variables)
(setq gnus-have-all-headers
(or all-headers gnus-show-all-headers))))
+ (save-excursion
+ (gnus-configure-windows 'article))
(when (or (numberp article)
(stringp article))
(gnus-article-prepare-display)
;; Do page break.
(goto-char (point-min))
- (setq gnus-page-broken
- (when gnus-break-pages
- (gnus-narrow-to-page)
- t)))
+ (when gnus-break-pages
+ (gnus-narrow-to-page)))
(let ((gnus-article-mime-handle-alist-1
gnus-article-mime-handle-alist))
(gnus-set-mode-line 'article))
(article-goto-body)
+ (unless (bobp)
+ (forward-line -1))
(set-window-point (get-buffer-window (current-buffer)) (point))
(gnus-configure-windows 'article)
t))))))
(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)))
- (number (or number 0))
- next type ids)
+ (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)
(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 (next-single-property-change (point)
- 'mime-view-entity)))
- (setq type (mime-entity-content-type entity)
- type (format "%s/%s"
- (mime-content-type-primary-type type)
- (mime-content-type-subtype type)))
+ (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")
- (save-restriction
- (narrow-to-region (point) (point-max))
- (gnus-article-prepare-mime-display number)
- (goto-char (point-max)))
- (setq ids (length (mime-entity-node-id entity))
- entity (get-text-property next 'mime-view-entity)
- number (1+ number))
+ (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)
- (if (or (null entity)
- (< (length (mime-entity-node-id entity)) ids))
- (gnus-treat-article 'last number number type)
- (gnus-treat-article t number nil type))
- (goto-char (point-max)))))
- (unless (eobp)
- (save-restriction
- (narrow-to-region (point) (point-max))
- (if entity
- (progn
- (setq type (mime-entity-content-type entity)
- type (format "%s/%s"
- (mime-content-type-primary-type type)
- (mime-content-type-subtype type)))
- (if (string-equal type "message/rfc822")
- (gnus-article-prepare-mime-display number)
- (incf number)
- (gnus-treat-article 'last number number type)))
- (gnus-treat-article t))))))
+ ;; 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."
- (gnus-run-hooks 'gnus-tmp-internal-hook)
- (gnus-run-hooks 'gnus-article-prepare-hook)
- ;; Display message.
- (let (mime-display-header-hook)
- (funcall (if gnus-show-mime
- (progn
- (setq mime-message-structure gnus-current-headers)
- gnus-article-display-method-for-mime)
- gnus-article-display-method-for-traditional)))
- ;; Associate this article with the current summary buffer.
- (setq gnus-article-current-summary gnus-summary-buffer)
- ;; Call the treatment functions.
- (let ((inhibit-read-only t)
- buffer-read-only)
+ (let ((gnus-article-buffer (current-buffer))
+ buffer-read-only
+ (inhibit-read-only t))
+ (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-article-image-alist nil)
(save-restriction
(widen)
- (if gnus-show-mime
+ (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))
+ (let ((show-mime (unless (member gnus-newsgroup-name '("nndraft:delayed"
+ "nndraft:drafts"))
+ gnus-show-mime))
+ (inhibit-read-only t))
+ (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 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.
+ (save-restriction
+ (widen)
+ (if show-mime
(gnus-article-prepare-mime-display)
(narrow-to-region (goto-char (point-min))
(if (search-forward "\n\n" nil t)
(goto-char (point-max))
(widen)
(narrow-to-region (point) (point-max))
- (gnus-treat-article t))
+ (gnus-treat-article nil))
(put-text-property (point-min) (point-max) 'read-only nil)))
- ;; Perform the article display hooks. Incidentally, this hook is
- ;; an obsolete variable by now.
- (gnus-run-hooks 'gnus-article-display-hook))
+ (gnus-run-hooks 'gnus-article-prepare-hook))
(defun gnus-article-decode-article-as-default-mime-charset ()
"Decode an article as `default-mime-charset'. It won't work if the
value of the variable `gnus-show-mime' is non-nil."
- (unless gnus-show-mime
+ (unless (or gnus-show-mime
+ (member gnus-newsgroup-name '("nndraft:delayed"
+ "nndraft:drafts")))
+ (set (make-local-variable 'default-mime-charset)
+ (with-current-buffer gnus-summary-buffer
+ default-mime-charset))
(decode-mime-charset-region (point-min) (point-max)
- (with-current-buffer gnus-summary-buffer
- default-mime-charset))))
-
-;; The following procedures will be abolished in the future.
-(autoload 'x-face-mule-x-face-decode-message-header "x-face-mule")
-(defvar x-face-mule-version-number)
-(defun gnus-article-display-x-face-with-x-face-mule (&rest args)
- "Decode and show X-Face with the function
-`x-face-mule-x-face-decode-message-header'. The buffer is expected to be
-narrowed to just the headers of the article."
- (when gnus-xemacs
- (error "`%s' won't work under XEmacs."
- 'gnus-article-display-x-face-with-x-face-mule))
- (when window-system
- (when (and (boundp 'x-face-mule-version-number)
- (> (string-to-number x-face-mule-version-number) 0.24)
- (not (gnus-buffer-live-p "*X-Face-Mule WARNING*")))
- (let ((buffer (generate-new-buffer "*X-Face-Mule WARNING*")))
- (save-window-excursion
- (pop-to-buffer buffer)
- (insert (format
- "WARNING:
-`%s' is an obsolete function.
-You have no use for setting the variable `%s',
-however, it will be set suitably by X-Face-Mule %s.
-Type any key: "
- 'gnus-article-display-x-face-with-x-face-mule
- 'gnus-article-x-face-command
- x-face-mule-version-number))
- (let ((inhibit-quit t) (echo-keystrokes 0) cursor-in-echo-area)
- (read-char-exclusive))
- (beginning-of-line)
- (delete-region (point) (point-max)))))
- (condition-case err
- (x-face-mule-x-face-decode-message-header)
- (error (error "%s"
- (if (featurep 'x-face-mule)
- "Please install x-face-mule 0.25 or later."
- err))))))
+ default-mime-charset)))
;;;
;;; Gnus MIME viewing functions
;;;
(defvar gnus-mime-button-line-format "%{%([%p. %d%T]%)%}%e\n"
- "The following specs can be used:
+ "Format of the MIME buttons.
+
+Valid specifiers include:
%t The MIME type
%T MIME type, along with additional info
%n The `name' parameter
%d The description, if any
%l The length of the encoded part
%p The part identifier number
-%e Dots if the part isn't displayed")
+%e Dots if the part isn't displayed
+
+General format specifiers can also be used. See Info node
+`(gnus)Formatting Variables'.")
(defvar gnus-mime-button-line-format-alist
'((?t gnus-tmp-type ?s)
(?e gnus-tmp-dots ?s)))
(defvar gnus-mime-button-commands
- '((gnus-article-press-button "\r" "Toggle Display")
- (gnus-mime-view-part "v" "View Interactively...")
- (gnus-mime-save-part "o" "Save...")
- (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
- (gnus-mime-inline-part "i" "View As Text, In This Buffer")
- (gnus-mime-internalize-part "E" "View Internally")
- (gnus-mime-externalize-part "e" "View Externally")
- (gnus-mime-pipe-part "|" "Pipe To Command...")))
+ '((gnus-article-press-button "\r" "Toggle Display")
+ (gnus-mime-view-part "v" "View Interactively...")
+ (gnus-mime-view-part-as-type "t" "View As Type...")
+ (gnus-mime-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-delete-part "d" "Delete part")
+ (gnus-mime-copy-part "c" "View As Text, In Other Buffer")
+ (gnus-mime-inline-part "i" "View As Text, In This Buffer")
+ (gnus-mime-view-part-internally "E" "View Internally")
+ (gnus-mime-view-part-externally "e" "View Externally")
+ (gnus-mime-print-part "p" "Print")
+ (gnus-mime-pipe-part "|" "Pipe To Command...")
+ (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))
- ""))
-
-(defvar gnus-mime-button-map nil)
-(unless gnus-mime-button-map
- (setq gnus-mime-button-map (make-sparse-keymap))
- (set-keymap-parent gnus-mime-button-map gnus-article-mode-map)
- (define-key gnus-mime-button-map gnus-mouse-2 'gnus-article-push-button)
- (define-key gnus-mime-button-map gnus-down-mouse-3 'gnus-mime-button-menu)
- (mapcar (lambda (c)
- (define-key gnus-mime-button-map (cadr c) (car c)))
- gnus-mime-button-commands))
-
-(defun gnus-mime-button-menu (event)
- "Construct a context-sensitive menu of MIME commands."
- (interactive "e")
- (save-excursion
- (let ((pos (event-start event)))
- (set-buffer (window-buffer (posn-window pos)))
- (goto-char (posn-point pos))
- (gnus-article-check-buffer)
- (let ((response (x-popup-menu
- t `("MIME Part"
- ("" ,@(mapcar (lambda (c)
- (cons (caddr c) (car c)))
- gnus-mime-button-commands))))))
- (if response
- (funcall response))))))
+ (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)))
+ (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)
+ (define-key map (cadr c) (car c)))
+ map))
+
+(easy-menu-define
+ gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
+ `("MIME Part"
+ ,@(mapcar (lambda (c)
+ (vector (caddr c) (car c) :enable t))
+ gnus-mime-button-commands)))
+
+(defun gnus-mime-button-menu (event prefix)
+ "Construct a context-sensitive menu of MIME commands."
+ (interactive "e\nP")
+ (save-window-excursion
+ (let ((pos (event-start event)))
+ (select-window (posn-window pos))
+ (goto-char (posn-point pos))
+ (gnus-article-check-buffer)
+ (popup-menu gnus-mime-button-menu nil prefix))))
(defun gnus-mime-view-all-parts (&optional handles)
"View all the MIME parts."
(interactive)
- (save-current-buffer
- (set-buffer gnus-article-buffer)
+ (with-current-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 ((inhibit-read-only t))
+ (delete-region (point) (point-max))
+ (mm-display-parts handles))))))
+
+(eval-when-compile
+ (defsubst gnus-article-edit-part (handles)
+ "Edit an article in order to delete a mime part.
+This function is exclusively used by `gnus-mime-save-part-and-strip'
+and `gnus-mime-delete-part', and not provided at run-time normally."
+ (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 ',handles)
+ (setq gnus-article-mime-handles nil)
+ (let ((mbl1 mml-buffer-list))
+ (setq mml-buffer-list mbl)
+ (set (make-local-variable 'mml-buffer-list) mbl1))
+ (gnus-make-local-hook 'kill-buffer-hook)
+ (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
+ `(lambda (no-highlight)
+ (let ((mail-parse-charset (or gnus-article-charset
+ ',gnus-newsgroup-charset))
+ (message-options message-options)
+ (message-options-set-recipient)
+ (mail-parse-ignored-charsets
+ (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)))
+ (gnus-article-edit-done)
+ (gnus-summary-expand-window)
+ (gnus-summary-show-article)))
+
+(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)
+ (when (gnus-group-read-only-p)
+ (error "The current group does not support deleting of parts"))
+ (when (mm-complicated-handles gnus-article-mime-handles)
+ (error "\
+The current article has a complicated MIME structure, giving up..."))
+ (when (gnus-yes-or-no-p "\
+Deleting parts may malfunction or destroy the article; continue? ")
+ (let* ((data (get-text-property (point) 'gnus-data))
+ file param
+ (handles gnus-article-mime-handles))
+ (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-part handles)))))
+
+(defun gnus-mime-delete-part ()
+ "Delete the MIME part under point.
+Replace it with some information about the removed part."
+ (interactive)
+ (gnus-article-check-buffer)
+ (when (gnus-group-read-only-p)
+ (error "The current group does not support deleting of parts"))
+ (when (mm-complicated-handles gnus-article-mime-handles)
+ (error "\
+The current article has a complicated MIME structure, giving up..."))
+ (when (gnus-yes-or-no-p "\
+Deleting parts may malfunction or destroy the article; continue? ")
+ (let* ((data (get-text-property (point) 'gnus-data))
+ (handles gnus-article-mime-handles)
+ (none "(none)")
+ (description
+ (or
+ (mail-decode-encoded-word-string (or (mm-handle-description data)
+ none))))
+ (filename
+ (or (mail-content-type-get (mm-handle-disposition data) 'filename)
+ none))
+ (type (mm-handle-media-type data)))
+ (unless data
+ (error "No MIME part under point"))
+ (with-current-buffer (mm-handle-buffer data)
+ (let ((bsize (format "%s" (buffer-size))))
+ (erase-buffer)
+ (insert
+ (concat
+ ",----\n"
+ "| The following attachment has been deleted:\n"
+ "|\n"
+ "| Type: " type "\n"
+ "| Filename: " filename "\n"
+ "| Size (encoded): " bsize " Byte\n"
+ "| Description: " description "\n"
+ "`----\n"))
+ (setcdr data
+ (cdr (mm-make-handle
+ nil `("text/plain") nil nil
+ (list "attachment")
+ (format "Deleted attachment (%s bytes)" bsize))))))
+ (set-buffer gnus-summary-buffer)
+ (gnus-article-edit-part handles))))
(defun gnus-mime-save-part ()
"Save the MIME part under point."
(interactive)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
- (mm-save-part data)))
+ (when data
+ (mm-save-part data))))
(defun gnus-mime-pipe-part ()
"Pipe the MIME part under point to a process."
(interactive)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
- (mm-pipe-part data)))
+ (when data
+ (mm-pipe-part data))))
(defun gnus-mime-view-part ()
"Interactively choose a viewing method for the MIME part under point."
(interactive)
(gnus-article-check-buffer)
(let ((data (get-text-property (point) 'gnus-data)))
- (mm-interactively-view-part data)))
+ (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 ()
+ (gnus-article-check-buffer)
+ (let* ((name (mail-content-type-get
+ (mm-handle-type (get-text-property (point) 'gnus-data))
+ 'name))
+ (def-type (and name (mm-default-file-encoding name))))
+ (and def-type (cons def-type 0))))
+
+(defun gnus-mime-view-part-as-type (&optional mime-type)
+ "Choose a MIME media type, and view the part as such."
+ (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
+ (setq handle
+ (mm-make-handle (mm-handle-buffer handle)
+ (cons mime-type (cdr (mm-handle-type handle)))
+ (mm-handle-encoding handle)
+ (mm-handle-undisplayer handle)
+ (mm-handle-disposition handle)
+ (mm-handle-description handle)
+ nil
+ (mm-handle-id handle)))
+ (setq gnus-article-mime-handles
+ (mm-merge-handles gnus-article-mime-handles handle))
+ (gnus-mm-display-part handle))))
+
+(eval-when-compile
+ (require 'jka-compr))
+
+;; jka-compr.el uses a "sh -c" to direct stderr to err-file, but these days
+;; emacs can do that itself.
+;;
+(defun gnus-mime-jka-compr-maybe-uncompress ()
+ "Uncompress the current buffer if `auto-compression-mode' is enabled.
+The uncompress method used is derived from `buffer-file-name'."
+ (when (and (fboundp 'jka-compr-installed-p)
+ (jka-compr-installed-p))
+ (let ((info (jka-compr-get-compression-info buffer-file-name)))
+ (when info
+ (let ((basename (file-name-nondirectory buffer-file-name))
+ (args (jka-compr-info-uncompress-args info))
+ (prog (jka-compr-info-uncompress-program info))
+ (message (jka-compr-info-uncompress-message info))
+ (err-file (jka-compr-make-temp-name)))
+ (if message
+ (message "%s %s..." message basename))
+ (unwind-protect
+ (unless (memq (apply 'call-process-region
+ (point-min) (point-max)
+ prog
+ t (list t err-file) nil
+ args)
+ jka-compr-acceptable-retval-list)
+ (jka-compr-error prog args basename message err-file))
+ (jka-compr-delete-temp-file err-file)))))))
(defun gnus-mime-copy-part (&optional handle)
- "Put the the MIME part under point into a new buffer."
+ "Put the MIME part under point into a new buffer.
+If `auto-compression-mode' is enabled, compressed files like .gz and .bz2
+are decompressed."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (contents (mm-get-part handle))|
- (base (file-name-nondirectory
- (or
- (mail-content-type-get (mm-handle-type handle) 'name)
- (mail-content-type-get (mm-handle-type handle)
- 'filename)
- "*decoded*")))
- (buffer (generate-new-buffer base)))
- (switch-to-buffer buffer)
- (insert contents)
- ;; We do it this way to make `normal-mode' set the appropriate mode.
- (unwind-protect
- (progn
- (setq buffer-file-name (expand-file-name base))
- (normal-mode))
- (setq buffer-file-name nil))
- (goto-char (point-min))))
-
-(defun gnus-mime-inline-part (&optional handle)
- "Insert the MIME part under point into the current buffer."
- (interactive)
+ (contents (and handle (mm-get-part handle)))
+ (base (and handle
+ (file-name-nondirectory
+ (or
+ (mail-content-type-get (mm-handle-type handle) 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename)
+ "*decoded*"))))
+ (buffer (and base (generate-new-buffer base))))
+ (when contents
+ (switch-to-buffer buffer)
+ (insert contents)
+ ;; We do it this way to make `normal-mode' set the appropriate mode.
+ (unwind-protect
+ (progn
+ (setq buffer-file-name (expand-file-name base))
+ (gnus-mime-jka-compr-maybe-uncompress)
+ (normal-mode))
+ (setq buffer-file-name nil))
+ (goto-char (point-min)))))
+
+(defun gnus-mime-print-part (&optional handle filename)
+ "Print the MIME part under point."
+ (interactive (list nil (ps-print-preprint current-prefix-arg)))
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ (contents (and handle (mm-get-part handle)))
+ (file (mm-make-temp-file (expand-file-name "mm." mm-tmp-directory)))
+ (printer (mailcap-mime-info (mm-handle-media-type handle) "print")))
+ (when contents
+ (if printer
+ (unwind-protect
+ (progn
+ (mm-save-part-to-file handle file)
+ (call-process shell-file-name nil
+ (generate-new-buffer " *mm*")
+ nil
+ shell-command-switch
+ (mm-mailcap-command
+ printer file (mm-handle-type handle))))
+ (delete-file file))
+ (with-temp-buffer
+ (insert contents)
+ (gnus-print-buffer))
+ (ps-despool filename)))))
+
+(defun gnus-mime-inline-part (&optional handle arg)
+ "Insert the MIME part under point into the current buffer."
+ (interactive (list nil current-prefix-arg))
+ (gnus-article-check-buffer)
+ (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
+ contents charset
+ (b (point))
+ (inhibit-read-only t))
+ (when handle
+ (if (and (not arg) (mm-handle-undisplayer handle))
+ (mm-remove-part handle)
+ (setq contents (mm-get-part handle))
+ (cond
+ ((not arg)
+ (setq charset (or (mail-content-type-get
+ (mm-handle-type handle) 'charset)
+ gnus-newsgroup-charset)))
+ ((numberp arg)
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle))
+ (setq charset
+ (or (cdr (assq arg
+ gnus-summary-show-article-charset-alist))
+ (mm-read-coding-system "Charset: ")))))
+ (forward-line 2)
+ (mm-insert-inline handle
+ (if (and charset
+ (setq charset (mm-charset-to-coding-system
+ charset))
+ (not (eq charset 'ascii)))
+ (mm-decode-coding-string contents charset)
+ contents))
+ (goto-char b)))))
+
+(defun gnus-mime-view-part-as-charset (&optional handle arg)
+ "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)))
- contents
+ contents charset
(b (point))
- buffer-read-only)
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (setq contents (mm-get-part handle))
- (forward-line 2)
- (mm-insert-inline handle contents)
- (goto-char b))))
-
-(defun gnus-mime-externalize-part (&optional handle)
+ (inhibit-read-only t))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle))
+ (let ((gnus-newsgroup-charset
+ (or (cdr (assq arg
+ gnus-summary-show-article-charset-alist))
+ (mm-read-coding-system "Charset: ")))
+ (gnus-newsgroup-ignored-charsets 'gnus-all))
+ (gnus-article-press-button)))))
+
+(defun gnus-mime-view-part-externally (&optional handle)
"View the MIME part under point with an external viewer."
(interactive)
(gnus-article-check-buffer)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
(mm-user-display-methods nil)
- (mm-inline-large-images nil)
+ (mm-inlined-types nil)
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle))))
-
-(defun gnus-mime-internalize-part (&optional handle)
- "View the MIME part under point with an internal viewer."
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle)))))
+
+(defun gnus-mime-view-part-internally (&optional handle)
+ "View the MIME part under point with an internal 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-user-display-methods '((".*" . inline)))
+ (mm-inlined-types '(".*"))
(mm-inline-large-images t)
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle))))
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets))
+ (inhibit-read-only t))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle)))))
+
+(defun gnus-mime-action-on-part (&optional action)
+ "Do something with the MIME attachment at \(point\)."
+ (interactive
+ (list (completing-read "Action: " gnus-mime-action-alist nil t)))
+ (gnus-article-check-buffer)
+ (let ((action-pair (assoc action gnus-mime-action-alist)))
+ (if action-pair
+ (funcall (cdr action-pair)))))
(defun gnus-article-part-wrapper (n function)
- (save-current-buffer
- (set-buffer gnus-article-buffer)
+ (with-current-buffer gnus-article-buffer
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part"))
(gnus-article-goto-part n)
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-copy-part))
-(defun gnus-article-externalize-part (n)
+(defun gnus-article-view-part-as-charset (n)
+ "View MIME part N using a specified charset.
+N is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
+
+(defun gnus-article-view-part-externally (n)
"View MIME part N externally, which is the numerical prefix."
(interactive "p")
- (gnus-article-part-wrapper n 'gnus-mime-externalize-part))
+ (gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
(defun gnus-article-inline-part (n)
"Inline MIME part N, which is the numerical prefix."
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-inline-part))
-(defun gnus-article-view-part (n)
+(defun gnus-article-mime-match-handle-first (condition)
+ (if condition
+ (let (n)
+ (dolist (ihandle gnus-article-mime-handle-alist)
+ (if (and (cond
+ ((functionp condition)
+ (funcall condition (cdr ihandle)))
+ ((eq condition 'undisplayed)
+ (not (or (mm-handle-undisplayer (cdr ihandle))
+ (equal (mm-handle-media-type (cdr ihandle))
+ "multipart/alternative"))))
+ ((eq condition 'undisplayed-alternative)
+ (not (mm-handle-undisplayer (cdr ihandle))))
+ (t t))
+ (gnus-article-goto-part (car ihandle))
+ (or (not n) (< (car ihandle) n)))
+ (setq n (car ihandle))))
+ (or n 1))
+ 1))
+
+(defun gnus-article-view-part (&optional n)
"View MIME part N, which is the numerical prefix."
- (interactive "p")
- (save-current-buffer
- (set-buffer gnus-article-buffer)
+ (interactive "P")
+ (with-current-buffer gnus-article-buffer
+ (or (numberp n) (setq n (gnus-article-mime-match-handle-first
+ gnus-article-mime-match-handle-function)))
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part"))
(let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
(when (eq (gnus-mm-display-part handle) 'internal)
(gnus-set-window-start)))))))
+(defsubst gnus-article-mime-total-parts ()
+ (if (bufferp (car gnus-article-mime-handles))
+ 1 ;; single part
+ (1- (length gnus-article-mime-handles))))
+
(defun gnus-mm-display-part (handle)
"Display HANDLE and fix MIME button."
(let ((id (get-text-property (point) 'gnus-part))
(point (point))
- buffer-read-only)
+ (inhibit-read-only t))
(forward-line 1)
(prog1
(let ((window (selected-window))
(mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
+ (mail-parse-ignored-charsets
+ (if (gnus-buffer-live-p gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)
+ nil)))
(save-excursion
(unwind-protect
- (let ((win (get-buffer-window (current-buffer) t))
+ (let ((win (gnus-get-buffer-window (current-buffer) t))
(beg (point)))
(when win
(select-window win))
;; This will remove the part.
(mm-display-part handle)
(save-restriction
- (narrow-to-region (point) (1+ (point)))
+ (narrow-to-region (point)
+ (if (eobp) (point) (1+ (point))))
(mm-display-part handle)
;; We narrow to the part itself and
;; then call the treatment functions.
(narrow-to-region (point) (point-max))
(gnus-treat-article
nil id
- (1- (length gnus-article-mime-handles))
- (car (mm-handle-type handle))))))
- (select-window window))))
+ (gnus-article-mime-total-parts)
+ (mm-handle-media-type handle)))))
+ (if (window-live-p window)
+ (select-window window)))))
(goto-char point)
- (delete-region (gnus-point-at-bol) (progn (forward-line 1) (point)))
+ (gnus-delete-line)
(gnus-insert-mime-button
handle id (list (mm-handle-displayed-p handle)))
(goto-char point))))
(defun gnus-article-goto-part (n)
"Go to MIME part N."
- (let ((point (text-property-any (point-min) (point-max) 'gnus-part n)))
- (when point
- (goto-char point))))
+ (gnus-goto-char (text-property-any (point-min) (point-max) 'gnus-part n)))
(defun gnus-insert-mime-button (handle gnus-tmp-id &optional displayed)
(let ((gnus-tmp-name
- (or (mail-content-type-get (mm-handle-type handle)
- 'name)
- (mail-content-type-get (mm-handle-disposition handle)
- 'filename)
+ (or (mail-content-type-get (mm-handle-type handle) 'name)
+ (mail-content-type-get (mm-handle-disposition handle) 'filename)
+ (mail-content-type-get (mm-handle-type handle) 'url)
""))
- (gnus-tmp-type (car (mm-handle-type handle)))
+ (gnus-tmp-type (mm-handle-media-type handle))
(gnus-tmp-description
(mail-decode-encoded-word-string (or (mm-handle-description handle)
"")))
(setq gnus-tmp-type-long (concat gnus-tmp-type
(and (not (equal gnus-tmp-name ""))
(concat "; " gnus-tmp-name))))
- (or (equal gnus-tmp-description "")
- (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
+ (unless (equal gnus-tmp-description "")
+ (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long)))
(unless (bolp)
(insert "\n"))
(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))
- (setq e (point))
- (widget-convert-button 'link b e
- :mime-handle handle
- :action 'gnus-widget-press-button
- :button-keymap gnus-mime-button-map
- :help-echo
- (lambda (widget)
- ;; Needed to properly clear the message
- ;; due to a bug in wid-edit
- (setq help-echo-owns-message t)
- (format
- "Click to %s the MIME part; %s for more options"
- (if (mm-handle-displayed-p
- (widget-get widget :mime-handle))
- "hide" "show")
- (if gnus-xemacs "button3" "mouse-3"))))))
+ `(keymap ,gnus-mime-button-map
+ gnus-callback gnus-mm-display-part
+ gnus-part ,gnus-tmp-id
+ article-type annotation
+ gnus-data ,handle))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point)))
+ (widget-convert-button
+ 'link b e
+ :mime-handle handle
+ :action 'gnus-widget-press-button
+ :button-keymap gnus-mime-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: %s the MIME part; %S: more options"
+ (aref gnus-mouse-2 0)
+ ;; XEmacs will get a single widget arg; Emacs 21 will get
+ ;; window, overlay, position.
+ (if (mm-handle-displayed-p
+ (if overlay
+ (with-current-buffer (gnus-overlay-buffer overlay)
+ (widget-get (widget-at (gnus-overlay-start overlay))
+ :mime-handle))
+ (widget-get widget/window :mime-handle)))
+ "hide" "show")
+ (aref gnus-down-mouse-3 0))))))
(defun gnus-widget-press-button (elems el)
(goto-char (widget-get elems :from))
;; We have to do this since selecting the window
;; may change the point. So we set the window point.
(set-window-point window point)))
- (let* ((handles (or ihandles (mm-dissect-buffer) (mm-uu-dissect)))
- buffer-read-only handle name type b e display)
+ (let ((handles ihandles)
+ (inhibit-read-only t)
+ handle name type b e display)
+ (cond (handles)
+ ((setq handles (mm-dissect-buffer nil gnus-article-loose-mime))
+ (when gnus-article-emulate-mime
+ (mm-uu-dissect-text-parts handles)))
+ (gnus-article-emulate-mime
+ (setq handles (mm-uu-dissect))))
(when (and (not ihandles)
(not gnus-displaying-mime))
;; Top-level call; we clean up.
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
- (setq gnus-article-mime-handle-alist nil)) ;; A trick.
+ (setq gnus-article-mime-handle-alist nil));; A trick.
(setq gnus-article-mime-handles handles)
;; We allow users to glean info from the handles.
(when gnus-article-mime-part-function
(narrow-to-region (point) (point-max))
(gnus-treat-article nil 1 1)
(widen)))
- (if (not ihandles)
- ;; Highlight the headers.
- (save-excursion
- (save-restriction
- (article-goto-body)
- (narrow-to-region (point-min) (point))
- (gnus-treat-article 'head))))))))
+ (unless ihandles
+ ;; Highlight the headers.
+ (save-excursion
+ (save-restriction
+ (article-goto-body)
+ (narrow-to-region (point-min) (point))
+ (gnus-treat-article 'head))))))))
+
+(defcustom gnus-mime-display-multipart-as-mixed nil
+ "Display \"multipart\" parts as \"multipart/mixed\".
+
+If t, it overrides nil values of
+`gnus-mime-display-multipart-alternative-as-mixed' and
+`gnus-mime-display-multipart-related-as-mixed'."
+ :group 'gnus-article-mime
+ :type 'boolean)
-(defvar gnus-mime-display-multipart-as-mixed nil)
+(defcustom gnus-mime-display-multipart-alternative-as-mixed nil
+ "Display \"multipart/alternative\" parts as \"multipart/mixed\"."
+ :version "21.4"
+ :group 'gnus-article-mime
+ :type 'boolean)
+
+(defcustom gnus-mime-display-multipart-related-as-mixed nil
+ "Display \"multipart/related\" parts as \"multipart/mixed\".
+
+If displaying \"text/html\" is discouraged \(see
+`mm-discouraged-alternatives'\) images or other material inside a
+\"multipart/related\" part might be overlooked when this variable is nil."
+ :version "21.4"
+ :group 'gnus-article-mime
+ :type 'boolean)
(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")
+ (gnus-add-wash-type 'signed)
+ (gnus-mime-display-security handle))
+ ((equal (car handle) "multipart/encrypted")
+ (gnus-add-wash-type 'encrypted)
+ (gnus-mime-display-security handle))
;; Other multiparts are handled like multipart/mixed.
(t
(gnus-mime-display-mixed (cdr handle)))))
(mapcar 'gnus-mime-display-part handles))
(defun gnus-mime-display-single (handle)
- (let ((type (car (mm-handle-type handle)))
+ (let ((type (mm-handle-media-type handle))
(ignored gnus-ignored-mime-types)
(not-attachment t)
(move nil)
(when (string-match (pop ignored) type)
(throw 'ignored nil)))
(if (and (setq not-attachment
- (or (not (mm-handle-disposition handle))
- (equal (car (mm-handle-disposition handle))
- "inline")
- (mm-attachment-override-p handle)))
+ (and (not (mm-inline-override-p handle))
+ (or (not (mm-handle-disposition handle))
+ (equal (car (mm-handle-disposition handle))
+ "inline")
+ (mm-attachment-override-p handle))))
(mm-automatic-display-p handle)
- (or (mm-inlined-p handle)
+ (or (and
+ (mm-inlinable-p handle)
+ (mm-inlined-p handle))
(mm-automatic-external-display-p type)))
(setq display t)
- (when (equal (car (split-string type "/"))
- "text")
+ (when (equal (mm-handle-media-supertype handle) "text")
(setq text t)))
- (let ((id (1+ (length gnus-article-mime-handle-alist))))
+ (let ((id (1+ (length gnus-article-mime-handle-alist)))
+ beg)
(push (cons id handle) gnus-article-mime-handle-alist)
(when (or (not display)
(not (gnus-unbuttonized-mime-type-p type)))
- (gnus-article-insert-newline)
(gnus-insert-mime-button
handle id (list (or display (and not-attachment text))))
(gnus-article-insert-newline)
- (gnus-article-insert-newline)
- (setq move t)))
- (let ((beg (point)))
+ ;; Remember modify the number of forward lines.
+ (setq move t))
+ (setq beg (point))
(cond
(display
(when move
- (forward-line -2))
+ (forward-line -1)
+ (setq beg (point)))
(let ((mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
+ (mail-parse-ignored-charsets
+ (save-excursion (condition-case ()
+ (set-buffer gnus-summary-buffer)
+ (error))
gnus-newsgroup-ignored-charsets)))
(mm-display-part handle t))
(goto-char (point-max)))
((and text not-attachment)
(when move
- (forward-line -2))
+ (forward-line -1)
+ (setq beg (point)))
(gnus-article-insert-newline)
- (mm-insert-inline handle (mm-get-part handle))
+ (mm-display-inline handle)
(goto-char (point-max))))
;; Do highlighting.
(save-excursion
(save-restriction
(narrow-to-region beg (point))
(gnus-treat-article
- nil (length gnus-article-mime-handle-alist)
- (1- (length gnus-article-mime-handles))
- (car (mm-handle-type handle))))))))))
+ nil id
+ (gnus-article-mime-total-parts)
+ (mm-handle-media-type handle)))))))))
(defun gnus-unbuttonized-mime-type-p (type)
"Say whether TYPE is to be unbuttonized."
(unless gnus-inhibit-mime-unbuttonizing
- (catch 'found
- (let ((types gnus-unbuttonized-mime-types))
- (while types
- (when (string-match (pop types) type)
- (throw 'found t)))))))
+ (when (catch 'found
+ (let ((types gnus-unbuttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))
+ (not (catch 'found
+ (let ((types gnus-buttonized-mime-types))
+ (while types
+ (when (string-match (pop types) type)
+ (throw 'found t)))))))))
(defun gnus-article-insert-newline ()
"Insert a newline, but mark it as undeletable."
(let* ((preferred (or preferred (mm-preferred-alternative handles)))
(ihandles handles)
(point (point))
- handle buffer-read-only from props begend not-pref)
+ handle (inhibit-read-only t) from props begend not-pref)
(save-window-excursion
(save-restriction
(when ibegend
(unless (setq not-pref (cadr (member preferred ihandles)))
(setq not-pref (car ihandles)))
(when (or ibegend
+ (not preferred)
(not (gnus-unbuttonized-mime-type-p
"multipart/alternative")))
(gnus-add-text-properties
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',not-pref ',begend ,id))
- local-map ,gnus-mime-button-map
+ keymap ,gnus-mime-button-map
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
- keymap ,gnus-mime-button-map
gnus-part ,id
gnus-data ,handle))
(widget-convert-button 'link from (point)
(progn
(insert (format "(%c) %-18s"
(if (equal handle preferred) ?* ? )
- (if (stringp (car handle))
- (car handle)
- (car (mm-handle-type handle)))))
+ (mm-handle-media-type handle)))
(point))
`(gnus-callback
(lambda (handles)
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',handle ',begend ,id))
- local-map ,gnus-mime-button-map
+ keymap ,gnus-mime-button-map
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
- keymap ,gnus-mime-button-map
gnus-part ,id
gnus-data ,handle))
(widget-convert-button 'link from (point)
(if (stringp (car preferred))
(gnus-display-mime preferred)
(let ((mail-parse-charset gnus-newsgroup-charset)
- (mail-parse-ignored-charsets
- (save-excursion (set-buffer gnus-summary-buffer)
- gnus-newsgroup-ignored-charsets)))
- (mm-display-part preferred)))
+ (mail-parse-ignored-charsets
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
+ (mm-display-part preferred)
+ ;; Do highlighting.
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (car begend) (point-max))
+ (gnus-treat-article
+ nil (length gnus-article-mime-handle-alist)
+ (gnus-article-mime-total-parts)
+ (mm-handle-media-type handle))))))
(goto-char (point-max))
(setcdr begend (point-marker)))))
(when ibegend
(goto-char point))))
+(defconst gnus-article-wash-status-strings
+ (let ((alist '((cite "c" "Possible hidden citation text"
+ " " "All citation text visible")
+ (headers "h" "Hidden headers"
+ " " "All headers visible.")
+ (pgp "p" "Encrypted or signed message status hidden"
+ " " "No hidden encryption nor digital signature status")
+ (signature "s" "Signature has been hidden"
+ " " "Signature is visible")
+ (overstrike "o" "Overstrike (^H) characters applied"
+ " " "No overstrike characters applied")
+ (gnus-show-mime "m" "Mime processing is activated"
+ " " "Mime processing is not activated")
+ (emphasis "e" "/*_Emphasis_*/ characters applied"
+ " " "No /*_emphasis_*/ characters applied")))
+ result)
+ (dolist (entry alist result)
+ (let ((key (nth 0 entry))
+ (on (copy-sequence (nth 1 entry)))
+ (on-help (nth 2 entry))
+ (off (copy-sequence (nth 3 entry)))
+ (off-help (nth 4 entry)))
+ (put-text-property 0 1 'help-echo on-help on)
+ (put-text-property 0 1 'help-echo off-help off)
+ (push (list key on off) result))))
+ "Alist of strings describing wash status in the mode line.
+Each entry has the form (KEY ON OF), where the KEY is a symbol
+representing the particular washing function, ON is the string to use
+in the article mode line when the washing function is active, and OFF
+is the string to use when it is inactive.")
+
+(defun gnus-article-wash-status-entry (key value)
+ (let ((entry (assoc key gnus-article-wash-status-strings)))
+ (if value (nth 1 entry) (nth 2 entry))))
+
(defun gnus-article-wash-status ()
"Return a string which display status of article washing."
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((cite (gnus-article-hidden-text-p 'cite))
- (headers (gnus-article-hidden-text-p 'headers))
- (boring (gnus-article-hidden-text-p 'boring-headers))
- (pgp (gnus-article-hidden-text-p 'pgp))
- (pem (gnus-article-hidden-text-p 'pem))
- (signature (gnus-article-hidden-text-p 'signature))
- (overstrike (gnus-article-hidden-text-p 'overstrike))
- (emphasis (gnus-article-hidden-text-p 'emphasis))
- (mime gnus-show-mime))
- (format "%c%c%c%c%c%c%c"
- (if cite ?c ? )
- (if (or headers boring) ?h ? )
- (if (or pgp pem) ?p ? )
- (if signature ?s ? )
- (if overstrike ?o ? )
- (if mime ?m ? )
- (if emphasis ?e ? )))))
-
-(fset 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
+ (with-current-buffer gnus-article-buffer
+ (let ((cite (memq 'cite gnus-article-wash-types))
+ (headers (memq 'headers gnus-article-wash-types))
+ (boring (memq 'boring-headers gnus-article-wash-types))
+ (pgp (memq 'pgp gnus-article-wash-types))
+ (pem (memq 'pem gnus-article-wash-types))
+ (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)))
+ (concat
+ (gnus-article-wash-status-entry 'cite cite)
+ (gnus-article-wash-status-entry 'headers (or headers boring))
+ (gnus-article-wash-status-entry 'pgp (or pgp pem signed encrypted))
+ (gnus-article-wash-status-entry 'signature signature)
+ (gnus-article-wash-status-entry 'overstrike overstrike)
+ (gnus-article-wash-status-entry 'gnus-show-mime gnus-show-mime)
+ (gnus-article-wash-status-entry 'emphasis emphasis)))))
+
+(defun gnus-add-wash-type (type)
+ "Add a washing of TYPE to the current status."
+ (add-to-list 'gnus-article-wash-types type))
+
+(defun gnus-delete-wash-type (type)
+ "Add a washing of TYPE to the current status."
+ (setq gnus-article-wash-types (delq type gnus-article-wash-types)))
+
+(defun gnus-add-image (category image)
+ "Add IMAGE of CATEGORY to the list of displayed images."
+ (let ((entry (assq category gnus-article-image-alist)))
+ (unless entry
+ (setq entry (list category))
+ (push entry gnus-article-image-alist))
+ (nconc entry (list image))))
+
+(defun gnus-delete-images (category)
+ "Delete all images in CATEGORY."
+ (let ((entry (assq category gnus-article-image-alist)))
+ (dolist (image (cdr entry))
+ (gnus-remove-image image category))
+ (setq gnus-article-image-alist (delq entry gnus-article-image-alist))
+ (gnus-delete-wash-type category)))
+
+(defalias 'gnus-article-hide-headers-if-wanted 'gnus-article-maybe-hide-headers)
(defun gnus-article-maybe-hide-headers ()
"Hide unwanted headers if `gnus-have-all-headers' is nil.
Provided for backwards compatibility."
(when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
- (not (save-excursion (set-buffer gnus-summary-buffer)
- gnus-have-all-headers)))
+ (not (with-current-buffer gnus-summary-buffer
+ gnus-have-all-headers)))
(not gnus-inhibit-hiding))
(gnus-article-hide-headers)))
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (append-to-file (point-min) (point-max) file-name)
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
+ (write-region-as-binary (point-min) (point-max) file-name 'append))
t)))
(defun gnus-narrow-to-page (&optional arg)
(widen)
;; Remove any old next/prev buttons.
(when (gnus-visual-p 'page-marker)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(gnus-remove-text-with-property 'gnus-prev)
(gnus-remove-text-with-property 'gnus-next)))
- (when
+ (if
(cond ((< arg 0)
(re-search-backward page-delimiter nil 'move (1+ (abs arg))))
((> arg 0)
(re-search-forward page-delimiter nil 'move arg)))
- (goto-char (match-end 0)))
- (narrow-to-region
- (point)
- (if (re-search-forward page-delimiter nil 'move)
- (match-beginning 0)
- (point)))
- (when (and (gnus-visual-p 'page-marker)
- (not (= (point-min) 1)))
+ (goto-char (match-end 0))
(save-excursion
(goto-char (point-min))
- (gnus-insert-prev-page-button)))
- (when (and (gnus-visual-p 'page-marker)
- (< (+ (point-max) 2) (buffer-size)))
- (save-excursion
- (goto-char (point-max))
- (gnus-insert-next-page-button)))))
+ (setq gnus-page-broken
+ (and (re-search-forward page-delimiter nil t) t))))
+ (when gnus-page-broken
+ (narrow-to-region
+ (point)
+ (if (re-search-forward page-delimiter nil 'move)
+ (match-beginning 0)
+ (point)))
+ (when (and (gnus-visual-p 'page-marker)
+ (> (point-min) (save-restriction (widen) (point-min))))
+ (save-excursion
+ (goto-char (point-min))
+ (gnus-insert-prev-page-button)))
+ (when (and (gnus-visual-p 'page-marker)
+ (< (+ (point-max) 2) (buffer-size)))
+ (save-excursion
+ (goto-char (point-max))
+ (gnus-insert-next-page-button))))))
;; Article mode commands
(goto-char (point-min))
(gnus-article-read-summary-keys nil (gnus-character-to-event ?n))))
+
(defun gnus-article-goto-prev-page ()
- "Show the next page of the article."
+ "Show the previous page of the article."
(interactive)
- (if (bobp) (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
+ (if (bobp)
+ (gnus-article-read-summary-keys nil (gnus-character-to-event ?p))
(gnus-article-prev-page nil)))
+;; This is cleaner but currently breaks `gnus-pick-mode':
+;;
+;; (defun gnus-article-goto-next-page ()
+;; "Show the next page of the article."
+;; (interactive)
+;; (gnus-eval-in-buffer-window gnus-summary-buffer
+;; (gnus-summary-next-page)))
+;;
+;; (defun gnus-article-goto-prev-page ()
+;; "Show the next page of the article."
+;; (interactive)
+;; (gnus-eval-in-buffer-window gnus-summary-buffer
+;; (gnus-summary-prev-page)))
+
(defun gnus-article-next-page (&optional lines)
"Show the next page of the current article.
If end of article, return non-nil. Otherwise return nil.
(if (save-excursion
(end-of-line)
(and (pos-visible-in-window-p) ;Not continuation line.
- (eobp)))
+ (>= (1+ (point)) (point-max)))) ;Allow for trailing newline.
;; 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.
+ (widen)
+ (forward-line)
+ (eobp)))) ;Real end-of-buffer?
+ (progn
+ (when gnus-article-over-scroll
+ (gnus-article-next-page-1 lines))
+ 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)
+ (gnus-article-next-page-1 lines)
nil))
+(defun gnus-article-next-page-1 (lines)
+ (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))
+
(defun gnus-article-prev-page (&optional lines)
"Show previous page of current article.
Argument LINES specifies lines to be scrolled down."
(goto-char (point-min))))
(move-to-window-line 0)))))
+(defun gnus-article-only-boring-p ()
+ "Decide whether there is only boring text remaining in the article.
+Something \"interesting\" is a word of at least two letters that does
+not have a face in `gnus-article-boring-faces'."
+ (when (and gnus-article-skip-boring
+ (boundp 'gnus-article-boring-faces)
+ (symbol-value 'gnus-article-boring-faces))
+ (save-excursion
+ (catch 'only-boring
+ (while (re-search-forward "\\b\\w\\w" nil t)
+ (forward-char -1)
+ (when (not (gnus-intersection
+ (gnus-faces-at (point))
+ (symbol-value 'gnus-article-boring-faces)))
+ (throw 'only-boring nil)))
+ (throw 'only-boring t)))))
+
(defun gnus-article-refer-article ()
"Read article specified by message-id around point."
(interactive)
- (let ((point (point)))
- (search-forward ">" nil t) ;Move point to end of "<....>".
- (if (re-search-backward "\\(<[^<> \t\n]+>\\)" nil t)
- (let ((message-id (match-string 1)))
- (goto-char point)
+ (save-excursion
+ (re-search-backward "[ \t]\\|^" (point-at-bol) t)
+ (re-search-forward "<?news:<?\\|<" (point-at-eol) t)
+ (if (re-search-forward "[^@ ]+@[^ \t>]+" (point-at-eol) t)
+ (let ((msg-id (concat "<" (match-string 0) ">")))
(set-buffer gnus-summary-buffer)
- (gnus-summary-refer-article message-id))
- (goto-char (point))
+ (gnus-summary-refer-article msg-id))
(error "No references around point"))))
(defun gnus-article-show-summary ()
(interactive "P")
(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"
- "=" "^" "\M-^" "|"))
- (nosave-but-article
- '("A\r"))
- (nosave-in-article
- '("\C-d"))
- (up-to-top
- '("n" "Gn" "p" "Gp"))
- keys new-sum-point)
+ '("q" "Q" "c" "r" "\C-c\C-f" "m" "a" "f"
+ "Zc" "ZC" "ZE" "ZJ" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP"
+ "=" "^" "\M-^" "|"))
+ (nosave-but-article
+ '("A\r"))
+ (nosave-in-article
+ '("\C-d"))
+ (up-to-top
+ '("n" "Gn" "p" "Gp"))
+ keys new-sum-point)
(save-excursion
(set-buffer gnus-article-current-summary)
(let (gnus-pick-mode)
- (push (or key last-command-event) unread-command-events)
- (setq keys (if gnus-xemacs
+ (push (or key last-command-event) unread-command-events)
+ (setq keys (static-if (featurep 'xemacs)
(events-to-keys (read-key-sequence nil))
(read-key-sequence nil)))))
-
(message "")
(if (or (member keys nosaves)
- (member keys nosave-but-article)
- (member keys nosave-in-article))
- (let (func)
- (save-window-excursion
- (pop-to-buffer gnus-article-current-summary 'norecord)
- ;; We disable the pick minor mode commands.
- (let (gnus-pick-mode)
- (setq func (lookup-key (current-local-map) keys))))
- (if (not func)
- (ding)
- (unless (member keys nosave-in-article)
- (set-buffer gnus-article-current-summary))
- (call-interactively func)
- (setq new-sum-point (point)))
- (when (member keys nosave-but-article)
- (pop-to-buffer gnus-article-buffer 'norecord)))
+ (member keys nosave-but-article)
+ (member keys nosave-in-article))
+ (let (func)
+ (save-window-excursion
+ (pop-to-buffer gnus-article-current-summary 'norecord)
+ ;; We disable the pick minor mode commands.
+ (let (gnus-pick-mode)
+ (setq func (lookup-key (current-local-map) keys))))
+ (if (or (not func)
+ (numberp func))
+ (ding)
+ (unless (member keys nosave-in-article)
+ (set-buffer gnus-article-current-summary))
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (when (member keys nosave-but-article)
+ (pop-to-buffer gnus-article-buffer 'norecord)))
;; These commands should restore window configuration.
(let ((obuf (current-buffer))
- (owin (current-window-configuration))
- (opoint (point))
- (summary gnus-article-current-summary)
- func in-buffer selected)
- (if not-restore-window
- (pop-to-buffer summary 'norecord)
- (switch-to-buffer summary 'norecord))
- (setq in-buffer (current-buffer))
- ;; We disable the pick minor mode commands.
- (if (setq func (let (gnus-pick-mode)
- (lookup-key (current-local-map) keys)))
- (progn
- (call-interactively func)
- (setq new-sum-point (point)))
- (ding))
- (when (eq in-buffer (current-buffer))
- (setq selected (gnus-summary-select-article))
- (set-buffer obuf)
- (unless not-restore-window
- (set-window-configuration owin))
- (when (eq selected 'old)
- (article-goto-body)
- (set-window-start (get-buffer-window (current-buffer))
- 1)
- (set-window-point (get-buffer-window (current-buffer))
- (point)))
- (let ((win (get-buffer-window gnus-article-current-summary)))
- (when win
- (set-window-point win new-sum-point))))))))
+ (owin (current-window-configuration))
+ (opoint (point))
+ win func in-buffer selected new-sum-start new-sum-hscroll)
+ (cond (not-restore-window
+ (pop-to-buffer gnus-article-current-summary 'norecord))
+ ((setq win (get-buffer-window gnus-article-current-summary))
+ (select-window win))
+ (t
+ (switch-to-buffer gnus-article-current-summary 'norecord)))
+ (setq in-buffer (current-buffer))
+ ;; We disable the pick minor mode commands.
+ (if (and (setq func (let (gnus-pick-mode)
+ (lookup-key (current-local-map) keys)))
+ (functionp func))
+ (progn
+ (call-interactively func)
+ (when (eq win (selected-window))
+ (setq new-sum-point (point)
+ new-sum-start (window-start win)
+ new-sum-hscroll (window-hscroll win))
+ (when (eq in-buffer (current-buffer))
+ (setq selected (gnus-summary-select-article))
+ (set-buffer obuf)
+ (unless not-restore-window
+ (set-window-configuration owin))
+ (when (eq selected 'old)
+ (article-goto-body)
+ (set-window-start (get-buffer-window (current-buffer))
+ 1)
+ (set-window-point (get-buffer-window (current-buffer))
+ (point)))
+ (when (and (not not-restore-window)
+ new-sum-point)
+ (set-window-point win new-sum-point)
+ (set-window-start win new-sum-start)
+ (set-window-hscroll win new-sum-hscroll)))))
+ (set-window-configuration owin)
+ (ding))))))
+
+(defun gnus-article-describe-key (key)
+ "Display documentation of the function invoked by KEY. KEY is a string."
+ (interactive "kDescribe key: ")
+ (gnus-article-check-buffer)
+ (if (eq (key-binding key) 'gnus-article-read-summary-keys)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (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)))
+
+(defun gnus-article-describe-key-briefly (key &optional insert)
+ "Display documentation of the function invoked by KEY. KEY is a string."
+ (interactive "kDescribe key: \nP")
+ (gnus-article-check-buffer)
+ (if (eq (key-binding key) 'gnus-article-read-summary-keys)
+ (save-excursion
+ (set-buffer gnus-article-current-summary)
+ (let (gnus-pick-mode)
+ (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)))
+
+(defun gnus-article-reply-with-original (&optional wide)
+ "Start composing a reply mail to the current message.
+The text in the region will be yanked. If the region isn't active,
+the entire article will be yanked."
+ (interactive "P")
+ (let ((article (cdr gnus-article-current))
+ contents)
+ (if (not (gnus-region-active-p))
+ (with-current-buffer gnus-summary-buffer
+ (gnus-summary-reply (list (list article)) wide))
+ (setq contents (buffer-substring (point) (mark t)))
+ ;; Deactivate active regions.
+ (when (and (boundp 'transient-mark-mode)
+ transient-mark-mode)
+ (setq mark-active nil))
+ (with-current-buffer gnus-summary-buffer
+ (gnus-summary-reply
+ (list (list article contents)) wide)))))
+
+(defun gnus-article-followup-with-original ()
+ "Compose a followup to the current article.
+The text in the region will be yanked. If the region isn't active,
+the entire article will be yanked."
+ (interactive)
+ (let ((article (cdr gnus-article-current))
+ contents)
+ (if (not (gnus-region-active-p))
+ (with-current-buffer gnus-summary-buffer
+ (gnus-summary-followup (list (list article))))
+ (setq contents (buffer-substring (point) (mark t)))
+ ;; Deactivate active regions.
+ (when (and (boundp 'transient-mark-mode)
+ transient-mark-mode)
+ (setq mark-active nil))
+ (with-current-buffer gnus-summary-buffer
+ (gnus-summary-followup
+ (list (list article contents)))))))
(defun gnus-article-hide (&optional arg force)
"Hide all the gruft in the current article.
-This means that PGP stuff, signatures, cited text and (some)
-headers will be hidden.
+This means that signatures, cited text and (some) headers will be
+hidden.
If given a prefix, show the hidden text instead."
(interactive (append (gnus-article-hidden-arg) (list 'force)))
(gnus-article-hide-headers arg)
- (gnus-article-hide-pgp arg)
+ (gnus-article-hide-list-identifiers arg)
(gnus-article-hide-citation-maybe arg force)
(gnus-article-hide-signature arg))
(gnus-check-server (gnus-find-method-for-group gnus-newsgroup-name))
(gnus-request-group gnus-newsgroup-name t)))
+(eval-when-compile
+ (autoload 'nneething-get-file-name "nneething"))
+
(defun gnus-request-article-this-buffer (article group)
"Get an article and insert it into this buffer."
(let (do-update-line sparse-header)
;; We only request an article by message-id when we do not have the
;; headers for it, so we'll have to get those.
(when (stringp article)
- (let ((gnus-override-method gnus-refer-article-method))
- (gnus-read-header article)))
+ (gnus-read-header article))
;; If the article number is negative, that means that this article
;; doesn't belong in this newsgroup (possibly), so we find its
;; This is a sparse gap article.
(setq do-update-line article)
(setq article (mail-header-id header))
- (let ((gnus-override-method gnus-refer-article-method))
- (setq sparse-header (gnus-read-header article)))
+ (setq sparse-header (gnus-read-header article))
(setq gnus-newsgroup-sparse
(delq article gnus-newsgroup-sparse)))
((vectorp header)
gnus-newsgroup-name)))
(when (and (eq (car method) 'nneething)
(vectorp header))
- (let ((dir (concat
- (file-name-as-directory
- (or (cadr (assq 'nneething-address method))
- (nth 1 method)))
- (mail-header-subject header))))
- (when (file-directory-p dir)
+ (let ((dir (nneething-get-file-name
+ (mail-header-id header))))
+ (when (and (stringp dir)
+ (file-directory-p dir))
(setq article 'nneething)
(gnus-group-enter-directory dir))))))))
gnus-summary-buffer
(get-buffer gnus-summary-buffer)
(gnus-buffer-exists-p gnus-summary-buffer)
- (eq (cdr (save-excursion
- (set-buffer gnus-summary-buffer)
+ (eq (cdr (with-current-buffer gnus-summary-buffer
(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)
+ (with-current-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)))
(numberp article)
(gnus-cache-request-article article group))
'article)
+ ;; Check the agent cache.
+ ((gnus-agent-request-article article group)
+ 'article)
;; Get the article and put into the article buffer.
- ((or (stringp article) (numberp article))
- (let ((gnus-override-method
- (and (stringp article) gnus-refer-article-method))
- (buffer-read-only nil))
- (erase-buffer)
- (gnus-kill-all-overlays)
- (gnus-check-group-server)
- (when (gnus-request-article article group (current-buffer))
- (when (numberp article)
- (gnus-async-prefetch-next group article gnus-summary-buffer)
- (when gnus-keep-backlog
- (gnus-backlog-enter-article
- group article (current-buffer))))
- 'article)))
+ ((or (stringp article)
+ (numberp article))
+ (let ((gnus-override-method gnus-override-method)
+ (methods (and (stringp article)
+ gnus-refer-article-method))
+ (backend (car (gnus-find-method-for-group
+ gnus-newsgroup-name)))
+ result
+ (inhibit-read-only t))
+ (if (or (not (listp methods))
+ (and (symbolp (car methods))
+ (assq (car methods) nnoo-definition-alist)))
+ (setq methods (list methods)))
+ (when (and (null gnus-override-method)
+ methods)
+ (setq gnus-override-method (pop methods)))
+ (while (not result)
+ (when (eq gnus-override-method 'current)
+ (setq gnus-override-method
+ (with-current-buffer gnus-summary-buffer
+ gnus-current-select-method)))
+ (erase-buffer)
+ (gnus-kill-all-overlays)
+ (let ((gnus-newsgroup-name group))
+ (gnus-check-group-server))
+ (cond
+ ((gnus-request-article article group (current-buffer))
+ (when (numberp article)
+ (gnus-async-prefetch-next group article
+ gnus-summary-buffer)
+ (when gnus-keep-backlog
+ (gnus-backlog-enter-article
+ group article (current-buffer))))
+ (setq result 'article))
+ (methods
+ (setq gnus-override-method (pop methods)))
+ ((not (string-match "^400 "
+ (nnheader-get-report backend)))
+ ;; If we get 400 server disconnect, reconnect and
+ ;; retry; otherwise, assume the article has expired.
+ (setq result 'done))))
+ (and (eq result 'article) 'article)))
;; It was a pseudo.
(t article)))
(buffer-disable-undo)
(setq major-mode 'gnus-original-article-mode)
(setq buffer-read-only t))
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring gnus-article-buffer))
(setq gnus-original-article (cons group article)))
(set-buffer gnus-summary-buffer)
(gnus-summary-update-article do-update-line sparse-header)
(gnus-summary-goto-subject do-update-line nil t)
- (set-window-point (get-buffer-window (current-buffer) t)
+ (set-window-point (gnus-get-buffer-window (current-buffer) t)
(point))
(set-buffer buf))))))
;; Should we be using derived.el for this?
(unless gnus-article-edit-mode-map
- (setq gnus-article-edit-mode-map (make-sparse-keymap))
+ (setq gnus-article-edit-mode-map (make-keymap))
(set-keymap-parent gnus-article-edit-mode-map text-mode-map)
(gnus-define-keys gnus-article-edit-mode-map
+ "\C-c?" describe-mode
"\C-c\C-c" gnus-article-edit-done
- "\C-c\C-k" gnus-article-edit-exit)
+ "\C-c\C-k" gnus-article-edit-exit
+ "\C-c\C-f\C-t" message-goto-to
+ "\C-c\C-f\C-o" message-goto-from
+ "\C-c\C-f\C-b" message-goto-bcc
+ ;;"\C-c\C-f\C-w" message-goto-fcc
+ "\C-c\C-f\C-c" message-goto-cc
+ "\C-c\C-f\C-s" message-goto-subject
+ "\C-c\C-f\C-r" message-goto-reply-to
+ "\C-c\C-f\C-n" message-goto-newsgroups
+ "\C-c\C-f\C-d" message-goto-distribution
+ "\C-c\C-f\C-f" message-goto-followup-to
+ "\C-c\C-f\C-m" message-goto-mail-followup-to
+ "\C-c\C-f\C-k" message-goto-keywords
+ "\C-c\C-f\C-u" message-goto-summary
+ "\C-c\C-f\C-i" message-insert-or-toggle-importance
+ "\C-c\C-f\C-a" message-generate-unsubscribed-mail-followup-to
+ "\C-c\C-b" message-goto-body
+ "\C-c\C-i" message-goto-signature
+
+ "\C-c\C-t" message-insert-to
+ "\C-c\C-n" message-insert-newsgroups
+ "\C-c\C-o" message-sort-headers
+ "\C-c\C-e" message-elide-region
+ "\C-c\C-v" message-delete-not-region
+ "\C-c\C-z" message-kill-to-signature
+ "\M-\r" message-newline-and-reformat
+ "\C-c\C-a" mml-attach-file
+ "\C-a" message-beginning-of-line
+ "\t" message-tab
+ "\M-;" comment-region)
(gnus-define-keys (gnus-article-edit-wash-map
"\C-c\C-w" gnus-article-edit-mode-map)
"f" gnus-article-edit-full-stops))
-(defun gnus-article-edit-mode ()
+(easy-menu-define
+ gnus-article-edit-mode-field-menu gnus-article-edit-mode-map ""
+ '("Field"
+ ["Fetch To" message-insert-to t]
+ ["Fetch Newsgroups" message-insert-newsgroups t]
+ "----"
+ ["To" message-goto-to t]
+ ["From" message-goto-from t]
+ ["Subject" message-goto-subject t]
+ ["Cc" message-goto-cc t]
+ ["Reply-To" message-goto-reply-to t]
+ ["Summary" message-goto-summary t]
+ ["Keywords" message-goto-keywords t]
+ ["Newsgroups" message-goto-newsgroups t]
+ ["Followup-To" message-goto-followup-to t]
+ ["Mail-Followup-To" message-goto-mail-followup-to t]
+ ["Distribution" message-goto-distribution t]
+ ["Body" message-goto-body t]
+ ["Signature" message-goto-signature t]))
+
+(define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
"Major mode for editing articles.
This is an extended text-mode.
\\{gnus-article-edit-mode-map}"
- (interactive)
- (setq major-mode 'gnus-article-edit-mode)
- (setq mode-name "Article Edit")
- (use-local-map gnus-article-edit-mode-map)
(make-local-variable 'gnus-article-edit-done-function)
(make-local-variable 'gnus-prev-winconf)
+ (set (make-local-variable 'font-lock-defaults)
+ '(message-font-lock-keywords t))
+ (set (make-local-variable 'mail-header-separator) "")
+ (set (make-local-variable 'gnus-article-edit-mode) t)
+ (easy-menu-add message-mode-field-menu message-mode-map)
(setq buffer-read-only nil)
(buffer-enable-undo)
- (widen)
- (gnus-run-hooks 'text-mode-hook 'gnus-article-edit-mode-hook))
+ (widen))
(defun gnus-article-edit (&optional force)
"Edit the current article.
"Start editing the contents of the current article buffer."
(let ((winconf (current-window-configuration)))
(set-buffer gnus-article-buffer)
- (gnus-article-edit-mode)
+ (let ((message-auto-save-directory
+ ;; Don't associate the article buffer with a draft file.
+ nil))
+ (gnus-article-edit-mode))
(funcall start-func)
- ;;(gnus-article-delete-text-of-type 'annotation)
- ;;(gnus-set-text-properties (point-min) (point-max) nil)
+ (set-buffer-modified-p nil)
(gnus-configure-windows 'edit-article)
(setq gnus-article-edit-done-function exit-func)
(setq gnus-prev-winconf winconf)
(when gnus-article-edit-article-setup-function
(funcall gnus-article-edit-article-setup-function))
- (gnus-message 6 "C-c C-c to end edits")))
+ (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit")))
(defun gnus-article-edit-done (&optional arg)
"Update the article edits and exit."
(interactive "P")
- (save-excursion
- (save-restriction
- (widen)
- (when (article-goto-body)
- (let ((lines (count-lines (point) (point-max)))
- (length (- (point-max) (point)))
- (case-fold-search t)
- (body (copy-marker (point))))
- (goto-char (point-min))
- (when (re-search-forward "^content-length:[ \t]\\([0-9]+\\)" body t)
- (delete-region (match-beginning 1) (match-end 1))
- (insert (number-to-string length)))
- (goto-char (point-min))
- (when (re-search-forward
- "^x-content-length:[ \t]\\([0-9]+\\)" body t)
- (delete-region (match-beginning 1) (match-end 1))
- (insert (number-to-string length)))
- (goto-char (point-min))
- (when (re-search-forward "^lines:[ \t]\\([0-9]+\\)" body t)
- (delete-region (match-beginning 1) (match-end 1))
- (insert (number-to-string lines)))))))
(let ((func gnus-article-edit-done-function)
(buf (current-buffer))
- (start (window-start)))
+ (start (window-start))
+ (p (point))
+ (winconf gnus-prev-winconf))
(remove-hook 'gnus-article-mode-hook
'gnus-article-mime-edit-article-unwind)
- (gnus-article-edit-exit)
+ (widen) ;; Widen it in case that users narrowed the buffer.
+ (funcall func arg)
+ (set-buffer buf)
+ ;; The cache and backlog have to be flushed somewhat.
+ (when gnus-keep-backlog
+ (gnus-backlog-remove-article
+ (car gnus-article-current) (cdr gnus-article-current)))
+ ;; Flush original article as well.
(save-excursion
- (set-buffer buf)
- (let ((buffer-read-only nil))
- (funcall func arg))
- ;; The cache and backlog have to be flushed somewhat.
- (when gnus-keep-backlog
- (gnus-backlog-remove-article
- (car gnus-article-current) (cdr gnus-article-current)))
- ;; Flush original article as well.
- (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))))
+ (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)))
+ ;; We remove all text props from the article buffer.
+ (kill-all-local-variables)
+ (set-text-properties (point-min) (point-max) nil)
+ (gnus-article-mode)
+ (set-window-configuration winconf)
(set-buffer buf)
(set-window-start (get-buffer-window buf) start)
- (set-window-point (get-buffer-window buf) (point))))
+ (set-window-point (get-buffer-window buf) (point)))
+ (gnus-summary-show-article))
(defun gnus-article-edit-exit ()
"Exit the article editing without updating."
(interactive)
- ;; We remove all text props from the article buffer.
- (let ((buf (format "%s" (buffer-string)))
- (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-substring gnus-original-article-buffer))
+ (let ((winconf gnus-prev-winconf))
+ (kill-all-local-variables)
+ (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))))
+ (gnus-summary-show-article)))
(defun gnus-article-edit-full-stops ()
"Interactively repair spacing at end of sentences."
(defun gnus-article-mime-edit-article-unwind ()
"Unwind `gnus-article-buffer' if article editing was given up."
(remove-hook 'gnus-article-mode-hook 'gnus-article-mime-edit-article-unwind)
- (when mime-edit-mode-flag
- (mime-edit-exit 'nomime 'no-error)
- (message ""))
(when (featurep 'font-lock)
(setq font-lock-defaults nil)
- (font-lock-mode 0)))
+ (font-lock-mode -1))
+ (when mime-edit-mode-flag
+ (mime-edit-exit 'nomime 'no-error)
+ (message "")))
(defun gnus-article-mime-edit-article-setup ()
"Convert current buffer to MIME-Edit buffer and turn on MIME-Edit mode
(setq gnus-article-edit-done-function
`(lambda (&rest args)
(when mime-edit-mode-flag
- (mime-edit-exit)
+ (let (mime-edit-insert-user-agent-field)
+ (mime-edit-exit))
(message ""))
(goto-char (point-min))
(let (case-fold-search)
(format "^%s$" (regexp-quote mail-header-separator))
nil t)
(replace-match "")))
- (when (featurep 'font-lock)
- (setq font-lock-defaults nil)
- (font-lock-mode 0))
(apply ,gnus-article-edit-done-function args)
- (set-buffer gnus-original-article-buffer)
- (erase-buffer)
- (insert-buffer gnus-article-buffer)
+ (insert
+ (prog1
+ (buffer-substring-no-properties (point-min) (point-max))
+ (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (erase-buffer)))
(setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (set-buffer gnus-article-buffer)
(gnus-article-prepare-display)))
- (substitute-key-definition
- 'gnus-article-edit-exit 'gnus-article-mime-edit-exit
- gnus-article-edit-mode-map)
+ (substitute-key-definition 'gnus-article-edit-done
+ 'gnus-article-mime-edit-done
+ gnus-article-edit-mode-map)
+ (substitute-key-definition 'gnus-article-edit-exit
+ 'gnus-article-mime-edit-exit
+ gnus-article-edit-mode-map)
(erase-buffer)
- (insert-buffer gnus-original-article-buffer)
- (mime-edit-again)
+ (insert-buffer-substring gnus-original-article-buffer)
+ (unless (member (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-name)
+ '("nndraft:delayed" "nndraft:drafts"))
+ (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))
+ (let ((inhibit-read-only t))
+ (gnus-article-edit-done arg)))
+
(defun gnus-article-mime-edit-exit ()
"Exit the article MIME editing without updating."
(interactive)
- (let ((winconf gnus-prev-winconf)
- buf)
+ (when (or (not (buffer-modified-p))
+ (yes-or-no-p "Article modified; kill anyway? "))
+ (when (featurep 'font-lock)
+ (setq font-lock-defaults nil)
+ (font-lock-mode -1))
(when mime-edit-mode-flag
- (mime-edit-exit)
+ (let (mime-edit-insert-user-agent-field)
+ (mime-edit-exit))
(message ""))
(goto-char (point-min))
(let (case-fold-search)
(when (re-search-forward
(format "^%s$" (regexp-quote mail-header-separator)) nil t)
(replace-match "")))
- (when (featurep 'font-lock)
- (setq font-lock-defaults nil)
- (font-lock-mode 0))
- ;; We remove all text props from the article buffer.
- (setq buf (format "%s" (buffer-string)))
- (set-buffer (get-buffer-create gnus-original-article-buffer))
- (erase-buffer)
- (insert buf)
- (setq gnus-current-headers (gnus-article-make-full-mail-header))
- (gnus-article-prepare-display)
- (set-window-configuration winconf)))
+ (let ((winconf gnus-prev-winconf))
+ (insert (prog1
+ (buffer-substring-no-properties (point-min) (point-max))
+ (set-buffer (get-buffer-create gnus-original-article-buffer))
+ (erase-buffer)))
+ (setq gnus-current-headers (gnus-article-make-full-mail-header))
+ (set-buffer gnus-article-buffer)
+ (gnus-article-prepare-display)
+ (set-window-configuration winconf))))
;;;
;;; Article highlights
;;; Internal Variables:
-(defcustom gnus-button-url-regexp "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?\\([-a-zA-Z0-9_=!?#$@~`%&*+|\\/:;.,]\\|\\w\\)+\\([-a-zA-Z0-9_=#$@~`%&*+|\\/]\\|\\w\\)"
+(defcustom gnus-button-url-regexp
+ (if (string-match "[[:digit:]]" "1") ;; support POSIX?
+ "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)"
+ "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)")
"Regular expression that matches URLs."
:group 'gnus-article-buttons
:type 'regexp)
+(defcustom gnus-button-valid-fqdn-regexp
+ message-valid-fqdn-regexp
+ "Regular expression that matches a valid FQDN."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
+(defcustom gnus-button-man-handler 'manual-entry
+ "Function to use for displaying man pages.
+The function must take at least one argument with a string naming the
+man page."
+ :version "21.4"
+ :type '(choice (function-item :tag "Man" manual-entry)
+ (function-item :tag "Woman" woman)
+ (function :tag "Other"))
+ :group 'gnus-article-buttons)
+
+(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/"
+ "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive.
+If the default site is too slow, try to find a CTAN mirror, see
+<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also
+the variable `gnus-button-handle-ctan'."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :link '(custom-manual "(gnus)Group Parameters")
+ :type '(choice (const "http://www.tex.ac.uk/tex-archive/")
+ (const "http://tug.ctan.org/tex-archive/")
+ (const "http://www.dante.de/CTAN/")
+ (string :tag "Other")))
+
+(defcustom gnus-button-ctan-handler 'browse-url
+ "Function to use for displaying CTAN links.
+The function must take one argument, the string naming the URL."
+ :version "21.4"
+ :type '(choice (function-item :tag "Browse Url" browse-url)
+ (function :tag "Other"))
+ :group 'gnus-article-buttons)
+
+(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/"
+ "Bogus strings removed from CTAN URLs."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type '(choice (const "^/?tex-archive/\\|/")
+ (regexp :tag "Other")))
+
+(defcustom gnus-button-ctan-directory-regexp
+ (concat
+ "\\(?:"
+ "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|"
+ "indexing\\|info\\|language\\|macros\\|support\\|systems\\|"
+ "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete"
+ "\\)")
+ "Regular expression for ctan directories.
+It should match all directories in the top level of `gnus-ctan-url'."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
+(defcustom gnus-button-mid-or-mail-regexp
+ (concat "\\b\\(<?[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*@"
+ ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
+ gnus-button-valid-fqdn-regexp
+ ">?\\)\\b")
+ "Regular expression that matches a message ID or a mail address."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
+(defcustom gnus-button-prefer-mid-or-mail 'gnus-button-mid-or-mail-heuristic
+ "What to do when the button on a string as \"foo123@bar.invalid\" is pushed.
+Strings like this can be either a message ID or a mail address. If it is one
+of the symbols `mid' or `mail', Gnus will always assume that the string is a
+message ID or a mail address, respectively. If this variable is set to the
+symbol `ask', always query the user what do do. If it is a function, this
+function will be called with the string as it's only argument. The function
+must return `mid', `mail', `invalid' or `ask'."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type '(choice (function-item :tag "Heuristic function"
+ gnus-button-mid-or-mail-heuristic)
+ (const ask)
+ (const mid)
+ (const mail)))
+
+(defcustom gnus-button-mid-or-mail-heuristic-alist
+ '((-10.0 . ".+\\$.+@")
+ (-10.0 . "#")
+ (-10.0 . "\\*")
+ (-5.0 . "\\+[^+]*\\+.*@") ;; # two plus signs
+ (-5.0 . "@[Nn][Ee][Ww][Ss]") ;; /\@news/i
+ (-5.0 . "@.*[Dd][Ii][Aa][Ll][Uu][Pp]") ;; /\@.*dialup/i;
+ (-1.0 . "^[^a-z]+@")
+ ;;
+ (-5.0 . "\\.[0-9][0-9]+.*@") ;; "\.[0-9]{2,}.*\@"
+ (-5.0 . "[a-z].*[A-Z].*[a-z].*[A-Z].*@") ;; "([a-z].*[A-Z].*){2,}\@"
+ (-3.0 . "[A-Z][A-Z][a-z][a-z].*@")
+ (-5.0 . "\\...?.?@") ;; (-5.0 . "\..{1,3}\@")
+ ;;
+ (-2.0 . "^[0-9]")
+ (-1.0 . "^[0-9][0-9]")
+ ;;
+ ;; -3.0 /^[0-9][0-9a-fA-F]{2,2}/;
+ (-3.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
+ ;; -5.0 /^[0-9][0-9a-fA-F]{3,3}/;
+ (-5.0 . "^[0-9][0-9a-fA-F][0-9a-fA-F][0-9a-fA-F][^0-9a-fA-F]")
+ ;;
+ (-3.0 . "[0-9][0-9][0-9][0-9][0-9][^0-9].*@") ;; "[0-9]{5,}.*\@"
+ (-3.0 . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][^0-9].*@")
+ ;; "[0-9]{8,}.*\@"
+ (-3.0
+ . "[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9].*@")
+ ;; "[0-9]{12,}.*\@"
+ ;; compensation for TDMA dated mail addresses:
+ (25.0 . "-dated-[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]+.*@")
+ ;;
+ (-20.0 . "\\.fsf@") ;; Gnus
+ (-20.0 . "^slrn")
+ (-20.0 . "^Pine")
+ (-20.0 . "_-_") ;; Subject change in thread
+ ;;
+ (-20.0 . "\\.ln@") ;; leafnode
+ (-30.0 . "@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de")
+ (-30.0 . "@4[Aa][Xx]\\.com") ;; Forte Agent
+ ;;
+ ;; (5.0 . "") ;; $local_part_len <= 7
+ (10.0 . "^[^0-9]+@")
+ (3.0 . "^[^0-9]+[0-9][0-9]?[0-9]?@")
+ ;; ^[^0-9]+[0-9]{1,3}\@ digits only at end of local part
+ (3.0 . "\@stud")
+ ;;
+ (2.0 . "[a-z][a-z][._-][A-Z][a-z].*@")
+ ;;
+ (0.5 . "^[A-Z][a-z]")
+ (0.5 . "^[A-Z][a-z][a-z]")
+ (1.5 . "^[A-Z][a-z][A-Z][a-z][^a-z]") ;; ^[A-Z][a-z]{3,3}
+ (2.0 . "^[A-Z][a-z][A-Z][a-z][a-z][^a-z]")) ;; ^[A-Z][a-z]{4,4}
+ "An alist of \(RATE . REGEXP\) pairs for `gnus-button-mid-or-mail-heuristic'.
+
+A negative RATE indicates a message IDs, whereas a positive indicates a mail
+address. The REGEXP is processed with `case-fold-search' set to nil."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type '(repeat (cons (number :tag "Rate")
+ (regexp :tag "Regexp"))))
+
+(defun gnus-button-mid-or-mail-heuristic (mid-or-mail)
+ "Guess whether MID-OR-MAIL is a message ID or a mail address.
+Returns `mid' if MID-OR-MAIL is a message IDs, `mail' if it's a mail
+address, `ask' if unsure and `invalid' if the string is invalid."
+ (let ((case-fold-search nil)
+ (list gnus-button-mid-or-mail-heuristic-alist)
+ (result 0) rate regexp lpartlen elem)
+ (setq lpartlen
+ (length (gnus-replace-in-string mid-or-mail "^\\(.*\\)@.*$" "\\1")))
+ (gnus-message 8 "`%s', length of local part=`%s'." mid-or-mail lpartlen)
+ ;; Certain special cases...
+ (when (string-match
+ (concat
+ "^0[0-9]+-[0-9][0-9][0-9][0-9]@t-online\\.de$\\|"
+ "^[0-9]+\\.[0-9]+@compuserve\\|"
+ "@public\\.gmane\\.org")
+ mid-or-mail)
+ (gnus-message 8 "`%s' is a known mail address." mid-or-mail)
+ (setq result 'mail))
+ (when (string-match "@.*@\\| " mid-or-mail)
+ (gnus-message 8 "`%s' is invalid." mid-or-mail)
+ (setq result 'invalid))
+ ;; Nothing more to do, if result is not a number here...
+ (when (numberp result)
+ (while list
+ (setq elem (car list)
+ rate (car elem)
+ regexp (cdr elem)
+ list (cdr list))
+ (when (string-match regexp mid-or-mail)
+ (setq result (+ result rate))
+ (gnus-message
+ 9 "`%s' matched `%s', rate `%s', result `%s'."
+ mid-or-mail regexp rate result)))
+ (when (<= lpartlen 7)
+ (setq result (+ result 5.0))
+ (gnus-message 9 "`%s' matched (<= lpartlen 7), result `%s'."
+ mid-or-mail result))
+ (when (>= lpartlen 12)
+ (gnus-message 9 "`%s' matched (>= lpartlen 12)" mid-or-mail)
+ (cond
+ ((string-match "[0-9][^0-9]+[0-9].*@" mid-or-mail)
+ ;; Long local part should contain realname if e-mail address,
+ ;; too many digits: message-id.
+ ;; $score -= 5.0 + 0.1 * $local_part_len;
+ (setq rate (* -1.0 (+ 5.0 (* 0.1 lpartlen))))
+ (setq result (+ result rate))
+ (gnus-message
+ 9 "Many digits in `%s', rate `%s', result `%s'."
+ mid-or-mail rate result))
+ ((string-match "[^aeiouy][^aeiouy][^aeiouy][^aeiouy]+.*\@"
+ mid-or-mail)
+ ;; Too few vowels [^aeiouy]{4,}.*\@
+ (setq result (+ result -5.0))
+ (gnus-message
+ 9 "Few vowels in `%s', rate `%s', result `%s'."
+ mid-or-mail -5.0 result))
+ (t
+ (setq result (+ result 5.0))
+ (gnus-message
+ 9 "`%s', rate `%s', result `%s'." mid-or-mail 5.0 result)))))
+ (gnus-message 8 "`%s': Final rate is `%s'." mid-or-mail result)
+ ;; Maybe we should make this a customizable alist: (condition . 'result)
+ (cond
+ ((symbolp result) result)
+ ;; Now convert number into proper results:
+ ((< result -10.0) 'mid)
+ ((> result 10.0) 'mail)
+ (t 'ask))))
+
+(defun gnus-button-handle-mid-or-mail (mid-or-mail)
+ (let* ((pref gnus-button-prefer-mid-or-mail) guessed
+ (url-mid (concat "news" ":" mid-or-mail))
+ (url-mailto (concat "mailto" ":" mid-or-mail)))
+ (gnus-message 9 "mid-or-mail=%s" mid-or-mail)
+ (when (fboundp pref)
+ (setq guessed
+ ;; get rid of surrounding angles...
+ (funcall pref
+ (gnus-replace-in-string mid-or-mail "^<\\|>$" "")))
+ (if (or (eq 'mid guessed) (eq 'mail guessed))
+ (setq pref guessed)
+ (setq pref 'ask)))
+ (if (eq pref 'ask)
+ (save-window-excursion
+ (if (y-or-n-p (concat "Is <" mid-or-mail "> a mail address? "))
+ (setq pref 'mail)
+ (setq pref 'mid))))
+ (cond ((eq pref 'mid)
+ (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
+ (gnus-button-handle-news url-mid))
+ ((eq pref 'mail)
+ (gnus-message 8 "calling `gnus-url-mailto' %s" url-mailto)
+ (gnus-url-mailto url-mailto))
+ (t (gnus-message 3 "Invalid string.")))))
+
+(defun gnus-button-handle-custom (url)
+ "Follow a Custom URL."
+ (customize-apropos (gnus-url-unhex-string url)))
+
+(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
+
+;; FIXME: Maybe we should merge some of the functions that do quite similar
+;; stuff?
+
+(defun gnus-button-handle-describe-function (url)
+ "Call `describe-function' when pushing the corresponding URL button."
+ (describe-function
+ (intern
+ (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
+
+(defun gnus-button-handle-describe-variable (url)
+ "Call `describe-variable' when pushing the corresponding URL button."
+ (describe-variable
+ (intern
+ (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))))
+
+(defun gnus-button-handle-symbol (url)
+"Display help on variable or function.
+Calls `describe-variable' or `describe-function'."
+ (let ((sym (intern url)))
+ (cond
+ ((fboundp sym) (describe-function sym))
+ ((boundp sym) (describe-variable sym))
+ (t (gnus-message 3 "`%s' is not a known function of variable." url)))))
+
+(defun gnus-button-handle-describe-key (url)
+ "Call `describe-key' when pushing the corresponding URL button."
+ (let* ((key-string
+ (gnus-replace-in-string url gnus-button-handle-describe-prefix ""))
+ (keys (ignore-errors (eval `(kbd ,key-string)))))
+ (if keys
+ (describe-key keys)
+ (gnus-message 3 "Invalid key sequence in button: %s" key-string))))
+
+(defun gnus-button-handle-apropos (url)
+ "Call `apropos' when pushing the corresponding URL button."
+ (apropos (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
+
+(defun gnus-button-handle-apropos-command (url)
+ "Call `apropos' when pushing the corresponding URL button."
+ (apropos-command
+ (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
+
+(defun gnus-button-handle-apropos-variable (url)
+ "Call `apropos' when pushing the corresponding URL button."
+ (funcall
+ (if (fboundp 'apropos-variable) 'apropos-variable 'apropos)
+ (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
+
+(defun gnus-button-handle-apropos-documentation (url)
+ "Call `apropos' when pushing the corresponding URL button."
+ (funcall
+ (if (fboundp 'apropos-documentation) 'apropos-documentation 'apropos)
+ (gnus-replace-in-string url gnus-button-handle-describe-prefix "")))
+
+(defun gnus-button-handle-library (url)
+ "Call `locate-library' when pushing the corresponding URL button."
+ (gnus-message 9 "url=`%s'" url)
+ (let* ((lib (locate-library url))
+ (file (gnus-replace-in-string (or lib "") "\.elc" ".el")))
+ (if (not lib)
+ (gnus-message 1 "Cannot locale library `%s'." url)
+ (find-file-read-only file))))
+
+(defun gnus-button-handle-ctan (url)
+ "Call `browse-url' when pushing a CTAN URL button."
+ (funcall
+ gnus-button-ctan-handler
+ (concat
+ gnus-ctan-url
+ (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp ""))))
+
+(defcustom gnus-button-tex-level 5
+ "*Integer that says how many TeX-related buttons Gnus will show.
+The higher the number, the more buttons will appear and the more false
+positives are possible. Note that you can set this variable local to
+specific groups. Setting it higher in TeX groups is probably a good idea.
+See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
+how to set variables in specific groups."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :link '(custom-manual "(gnus)Group Parameters")
+ :type 'integer)
+
+(defcustom gnus-button-man-level 5
+ "*Integer that says how many man-related buttons Gnus will show.
+The higher the number, the more buttons will appear and the more false
+positives are possible. Note that you can set this variable local to
+specific groups. Setting it higher in Unix groups is probably a good idea.
+See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on
+how to set variables in specific groups."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :link '(custom-manual "(gnus)Group Parameters")
+ :type 'integer)
+
+(defcustom gnus-button-emacs-level 5
+ "*Integer that says how many emacs-related buttons Gnus will show.
+The higher the number, the more buttons will appear and the more false
+positives are possible. Note that you can set this variable local to
+specific groups. Setting it higher in Emacs or Gnus related groups is
+probably a good idea. See Info node `(gnus)Group Parameters' and the variable
+`gnus-parameters' on how to set variables in specific groups."
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :link '(custom-manual "(gnus)Group Parameters")
+ :type 'integer)
+
+(defcustom gnus-button-message-level 5
+ "*Integer that says how many buttons for news or mail messages will appear.
+The higher the number, the more buttons will appear and the more false
+positives are possible."
+ ;; mail addresses, MIDs, URLs for news, ...
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type 'integer)
+
+(defcustom gnus-button-browse-level 5
+ "*Integer that says how many buttons for browsing will appear.
+The higher the number, the more buttons will appear and the more false
+positives are possible."
+ ;; stuff handled by `browse-url' or `gnus-button-embedded-url'
+ :version "21.4"
+ :group 'gnus-article-buttons
+ :type 'integer)
+
(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)
- ("\\(\\b<\\(url:[>\n\t ]*\\)?news:[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
- 1 t
- gnus-button-fetch-group 4)
- ("\\bnews:\\(//\\)?\\([^'\">\n\t ]+\\)" 0 t gnus-button-fetch-group 2)
- ("\\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)
- ("\\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)
+ '(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
+ 0 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
+ ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
+ gnus-button-handle-news 2)
+ ("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
+ 1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
+ ("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
+ 0 (>= gnus-button-message-level 0) gnus-button-fetch-group 3)
+ ;; RFC 2392 (Don't allow `/' in domain part --> CID)
+ ("\\bmid:\\(//\\)?\\([^'\">\n\t ]+@[^'\">\n\t /]+\\)"
+ 0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
+ ("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
+ 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
+ ("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
+ 0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
+ ;; RFC 2368 (The mailto URL scheme)
+ ("\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
+ 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
+ ("\\bmailto:\\([^ \n\t]+\\)"
+ 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
+ ;; CTAN
+ ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\("
+ gnus-button-ctan-directory-regexp
+ "[^][>)!;:,'\n\t ]+\\)")
+ 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1)
+ ((concat "\\btex-archive/\\("
+ gnus-button-ctan-directory-regexp
+ "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)")
+ 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1)
+ ((concat
+ "\\b\\("
+ gnus-button-ctan-directory-regexp
+ "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)")
+ 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1)
+ ;; This is info (home-grown style) <info://foo/bar+baz>
+ ("\\binfo://\\([^'\">\n\t ]+\\)"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1)
+ ;; Info GNOME style <info:foo#bar_baz>
+ ("\\binfo:\\([^('\n\t\r \"><][^'\n\t\r \"><]*\\)"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-gnome 1)
+ ;; Info KDE style <info:(foo)bar baz>
+ ("<\\(info:\\(([^)]+)[^>\n\r]*\\)\\)>"
+ 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2)
+ ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0
+ (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2)
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET"
+ ;; Info links like `C-h i d m CC Mode RET'
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2)
+ ;; This is custom
+ ("\\bcustom:\\(//\\)?\\([^'\">\n\t ]+\\)"
+ 0 (>= gnus-button-emacs-level 5) gnus-button-handle-custom 2)
+ ("M-x[ \t\n]customize-[^ ]+[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0
+ (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1)
+ ;; Emacs help commands
+ ("M-x[ \t\n]+apropos[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ ;; regexp doesn't match arguments containing ` '.
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos 1)
+ ("M-x[ \t\n]+apropos-command[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-command 1)
+ ("M-x[ \t\n]+apropos-variable[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1)
+ ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1)
+ ;; The following entries may lead to many false positives so don't enable
+ ;; them by default (use a high button level).
+ ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]"
+ ;; Exclude [.?] for URLs in gmane.emacs.cvs
+ 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
+ ("`\\([a-z][-a-z0-9]+\\.el\\)'"
+ 1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
+ ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
+ 0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
+ ("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
+ 0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
+ ("(setq[ \t\n]+\\([a-z][a-z0-9]+-[-a-z0-9]+\\)[ \t\n]+.+)"
+ 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-variable 1)
+ ("\\bM-x[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ 1 (>= gnus-button-emacs-level 7) gnus-button-handle-describe-function 1)
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+f[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
+ ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
+ 0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
+ ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
+ ;; Unlike the other regexps we really have to require quoting
+ ;; here to determine where it ends.
+ 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
+ ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)...
+ ("<URL: *\\([^<>]*\\)>"
+ 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
+ ;; RFC 2396 (2.4.3., delims) ...
+ ("\"URL: *\\([^\"]*\\)\""
+ 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
+ ;; RFC 2396 (2.4.3., delims) ...
+ ("\"URL: *\\([^\"]*\\)\""
+ 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1)
;; Raw URLs.
- (,gnus-button-url-regexp 0 t gnus-button-url 0))
+ (gnus-button-url-regexp
+ 0 (>= gnus-button-browse-level 0) browse-url 0)
+ ;; man pages
+ ("\\b\\([a-z][a-z]+([1-9])\\)\\W"
+ 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3))
+ gnus-button-handle-man 1)
+ ;; more man pages: resolv.conf(5), iso_8859-1(7), xterm(1x)
+ ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W"
+ 0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
+ gnus-button-handle-man 1)
+ ;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
+ ;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
+ ("\\b\\(\\(?:[a-z][-+_.:a-z0-9]+([1-9][X1a-z]*)\\)\\|\\b\\(?:X([1-9])\\)\\)\\W"
+ 0 (>= gnus-button-man-level 5) gnus-button-handle-man 1)
+ ;; MID or mail: To avoid too many false positives we don't try to catch
+ ;; all kind of allowed MIDs or mail addresses. Domain part must contain
+ ;; at least one dot. TLD must contain two or three chars or be a know TLD
+ ;; (info|name|...). Put this entry near the _end_ of `gnus-button-alist'
+ ;; so that non-ambiguous entries (see above) match first.
+ (gnus-button-mid-or-mail-regexp
+ 0 (>= gnus-button-message-level 5) gnus-button-handle-mid-or-mail 1))
"*Alist of regexps matching buttons in article bodies.
Each entry has the form (REGEXP BUTTON FORM CALLBACK PAR...), where
-REGEXP: is the string matching text around the button,
+REGEXP: is the string (case insensitive) matching text around the button (can
+also be Lisp expression evaluating to a string),
BUTTON: is the number of the regexp grouping actually matching the button,
-FORM: is a lisp expression which must eval to true for the button to
+FORM: is a Lisp expression which must eval to true for the button to
be added,
CALLBACK: is the function to call when the user push this button, and each
PAR: is a number of a regexp grouping whose text will be passed to CALLBACK.
CALLBACK can also be a variable, in that case the value of that
variable it the real callback function."
:group 'gnus-article-buttons
- :type '(repeat (list regexp
+ :type '(repeat (list (choice regexp variable sexp)
(integer :tag "Button")
(sexp :tag "Form")
(function :tag "Callback")
(integer :tag "Regexp group")))))
(defcustom gnus-header-button-alist
- `(("^\\(References\\|Message-I[Dd]\\):" "<[^>]+>"
- 0 t gnus-button-message-id 0)
- ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$" 1 t gnus-button-reply 1)
+ '(("^\\(References\\|Message-I[Dd]\\|^In-Reply-To\\):" "<[^<>]+>"
+ 0 (>= gnus-button-message-level 0) gnus-button-message-id 0)
+ ("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
+ 1 (>= gnus-button-message-level 0) gnus-button-reply 1)
("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
- 0 t gnus-button-mailto 0)
- ("^X-[Uu][Rr][Ll]:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
- ("^Subject:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
- ("^[^:]+:" ,gnus-button-url-regexp 0 t gnus-button-url 0)
- ("^[^:]+:" "\\(<\\(url: \\)?news:\\([^>\n ]*\\)>\\)" 1 t
- gnus-button-message-id 3))
+ 0 (>= gnus-button-message-level 0) gnus-button-mailto 0)
+ ("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
+ 0 (>= gnus-button-browse-level 0) browse-url 0)
+ ("^Subject:" gnus-button-url-regexp
+ 0 (>= gnus-button-browse-level 0) browse-url 0)
+ ("^[^:]+:" gnus-button-url-regexp
+ 0 (>= gnus-button-browse-level 0) browse-url 0)
+ ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&/]+\\)"
+ 0 (>= gnus-button-message-level 0) gnus-url-mailto 1)
+ ("^[^:]+:" "\\(<\\(url: \\)?\\(nntp\\|news\\):\\([^>\n ]*\\)>\\)"
+ 1 (>= gnus-button-message-level 0) gnus-button-message-id 4))
"*Alist of headers and regexps to match buttons in article heads.
This alist is very similar to `gnus-button-alist', except that each
:group 'gnus-article-buttons
:group 'gnus-article-headers
:type '(repeat (list (regexp :tag "Header")
- regexp
+ (choice regexp variable)
(integer :tag "Button")
(sexp :tag "Form")
(function :tag "Callback")
:inline t
(integer :tag "Regexp group")))))
-(defvar gnus-button-regexp nil)
-(defvar gnus-button-marker-list nil)
-;; Regexp matching any of the regexps from `gnus-button-alist'.
-
-(defvar gnus-button-last nil)
-;; The value of `gnus-button-alist' when `gnus-button-regexp' was build.
-
;;; Commands:
(defun gnus-article-push-button (event)
(interactive "e")
(set-buffer (window-buffer (posn-window (event-start event))))
(let* ((pos (posn-point (event-start event)))
- (data (get-text-property pos 'gnus-data))
+ (data (get-text-property pos 'gnus-data))
(fun (get-text-property pos 'gnus-callback)))
(goto-char pos)
(when fun
If the text at point has a `gnus-callback' property,
call it with the value of the `gnus-data' text property."
(interactive)
- (let* ((data (get-text-property (point) 'gnus-data))
- (fun (get-text-property (point) 'gnus-callback)))
+ (let ((data (get-text-property (point) 'gnus-data))
+ (fun (get-text-property (point) 'gnus-callback)))
(when fun
(funcall fun data))))
(defun gnus-article-highlight-headers ()
"Highlight article headers as specified by `gnus-header-face-alist'."
(interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (let ((alist gnus-header-face-alist)
- (buffer-read-only nil)
- (case-fold-search t)
- (inhibit-point-motion-hooks t)
- entry regexp header-face field-face from hpoints fpoints)
- (article-narrow-to-head)
- (while (setq entry (pop alist))
- (goto-char (point-min))
- (setq regexp (concat "^\\("
- (if (string-equal "" (nth 0 entry))
- "[^\t ]"
- (nth 0 entry))
- "\\)")
- header-face (nth 1 entry)
- field-face (nth 2 entry))
- (while (and (re-search-forward regexp nil t)
- (not (eobp)))
- (beginning-of-line)
- (setq from (point))
- (unless (search-forward ":" nil t)
- (forward-char 1))
- (when (and header-face
- (not (memq (point) hpoints)))
- (push (point) hpoints)
- (gnus-put-text-property from (point) 'face header-face))
- (when (and field-face
- (not (memq (setq from (point)) fpoints)))
- (push from fpoints)
- (if (re-search-forward "^[^ \t]" nil t)
- (forward-char -2)
- (goto-char (point-max)))
- (gnus-put-text-property from (point) 'face field-face))))))))
+ (gnus-with-article-headers
+ (let (regexp header-face field-face from hpoints fpoints)
+ (dolist (entry gnus-header-face-alist)
+ (goto-char (point-min))
+ (setq regexp (concat "^\\("
+ (if (string-equal "" (nth 0 entry))
+ "[^\t ]"
+ (nth 0 entry))
+ "\\)")
+ header-face (nth 1 entry)
+ field-face (nth 2 entry))
+ (while (and (re-search-forward regexp nil t)
+ (not (eobp)))
+ (beginning-of-line)
+ (setq from (point))
+ (unless (search-forward ":" nil t)
+ (forward-char 1))
+ (when (and header-face
+ (not (memq (point) hpoints)))
+ (push (point) hpoints)
+ (gnus-put-text-property from (point) 'face header-face))
+ (when (and field-face
+ (not (memq (setq from (point)) fpoints)))
+ (push from fpoints)
+ (if (re-search-forward "^[^ \t]" nil t)
+ (forward-char -2)
+ (goto-char (point-max)))
+ (gnus-put-text-property from (point) 'face field-face)))))))
(defun gnus-article-highlight-signature ()
"Highlight the signature in an article.
It does this by highlighting everything after
`gnus-signature-separator' using `gnus-signature-face'."
(interactive)
+ (when gnus-signature-face
+ (gnus-with-article-buffer
+ (let ((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)
+ (let ((inhibit-read-only t)
(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."
\"External references\" are things like Message-IDs and URLs, as
specified by `gnus-button-alist'."
(interactive (list 'force))
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
+ (gnus-with-article-buffer
+ (let ((inhibit-point-motion-hooks t)
(case-fold-search t)
(alist gnus-button-alist)
beg entry regexp)
;; Remove all old markers.
- (let (marker entry)
+ (let (marker entry new-list)
(while (setq marker (pop gnus-button-marker-list))
- (goto-char marker)
- (when (setq entry (gnus-button-entry))
- (put-text-property (match-beginning (nth 1 entry))
- (match-end (nth 1 entry))
- 'gnus-callback nil))
- (set-marker marker nil)))
+ (if (or (< marker (point-min)) (>= marker (point-max)))
+ (push marker new-list)
+ (goto-char marker)
+ (when (setq entry (gnus-button-entry))
+ (put-text-property (match-beginning (nth 1 entry))
+ (match-end (nth 1 entry))
+ 'gnus-callback nil))
+ (set-marker marker nil)))
+ (setq gnus-button-marker-list new-list))
;; We skip the headers.
(article-goto-body)
(setq beg (point))
(while (setq entry (pop alist))
- (setq regexp (car entry))
+ (setq regexp (eval (car entry)))
(goto-char beg)
(while (re-search-forward regexp nil t)
(let* ((start (and entry (match-beginning (nth 1 entry))))
(defun gnus-article-add-buttons-to-head ()
"Add buttons to the head of the article."
(interactive)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (save-restriction
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
- (case-fold-search t)
- (alist gnus-header-button-alist)
- entry beg end)
- (article-narrow-to-head)
- (while alist
- ;; Each alist entry.
- (setq entry (car alist)
- alist (cdr alist))
- (goto-char (point-min))
- (while (re-search-forward (car entry) nil t)
- ;; Each header matching the entry.
- (setq beg (match-beginning 0))
- (setq end (or (and (re-search-forward "^[^ \t]" nil t)
- (match-beginning 0))
- (point-max)))
- (goto-char beg)
- (while (re-search-forward (nth 1 entry) end t)
- ;; Each match within a header.
- (let* ((entry (cdr entry))
- (start (match-beginning (nth 1 entry)))
- (end (match-end (nth 1 entry)))
- (form (nth 2 entry)))
- (goto-char (match-end 0))
- (when (eval form)
- (gnus-article-add-button
- start end (nth 3 entry)
- (buffer-substring (match-beginning (nth 4 entry))
- (match-end (nth 4 entry)))))))
- (goto-char end)))))))
+ (gnus-with-article-headers
+ (let (beg end)
+ (dolist (entry gnus-header-button-alist)
+ ;; Each alist entry.
+ (goto-char (point-min))
+ (while (re-search-forward (car entry) nil t)
+ ;; Each header matching the entry.
+ (setq beg (match-beginning 0))
+ (setq end (or (and (re-search-forward "^[^ \t]" nil t)
+ (match-beginning 0))
+ (point-max)))
+ (goto-char beg)
+ (while (re-search-forward (eval (nth 1 entry)) end t)
+ ;; Each match within a header.
+ (let* ((entry (cdr entry))
+ (start (match-beginning (nth 1 entry)))
+ (end (match-end (nth 1 entry)))
+ (form (nth 2 entry)))
+ (goto-char (match-end 0))
+ (when (eval form)
+ (gnus-article-add-button
+ start end (nth 3 entry)
+ (buffer-substring (match-beginning (nth 4 entry))
+ (match-end (nth 4 entry)))))))
+ (goto-char end))))))
;;; External functions:
(nconc (and gnus-article-mouse-face
(list gnus-mouse-face-prop gnus-article-mouse-face))
(list 'gnus-callback fun)
- (and data (list 'gnus-data data)))))
+ (and data (list 'gnus-data data))))
+ (widget-convert-button 'link from to :action 'gnus-widget-press-button
+ :button-keymap gnus-widget-button-keymap))
;;; Internal functions:
(defun gnus-article-set-globals ()
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-set-global-variables)))
(defun gnus-signature-toggle (end)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t))
- (if (get-text-property end 'invisible)
- (gnus-article-unhide-text end (point-max))
- (gnus-article-hide-text end (point-max) gnus-hidden-properties)))))
+ (gnus-with-article-buffer
+ (let ((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)
+ (progn
+ (gnus-delete-wash-type 'signature)
+ (gnus-remove-text-properties-when
+ 'article-type 'signature end limit
+ (cons 'article-type (cons 'signature
+ gnus-hidden-properties))))
+ (gnus-add-wash-type 'signature)
+ (gnus-add-text-properties-when
+ 'article-type nil end limit
+ (cons 'article-type (cons 'signature
+ gnus-hidden-properties)))))
+ (let ((gnus-article-mime-handle-alist-1 gnus-article-mime-handle-alist))
+ (gnus-set-mode-line 'article))))
(defun gnus-button-entry ()
;; Return the first entry in `gnus-button-alist' matching this place.
(entry nil))
(while alist
(setq entry (pop alist))
- (if (looking-at (car entry))
+ (if (looking-at (eval (car entry)))
(setq alist nil)
(setq entry nil)))
entry))
(fun (nth 3 entry))
(args (mapcar (lambda (group)
(let ((string (match-string group)))
- (gnus-set-text-properties
+ (set-text-properties
0 (length string) nil string)
string))
(nthcdr 4 entry))))
(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-handle-man (url)
+ "Fetch a man page."
+ (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
+ (when (eq gnus-button-man-handler 'woman)
+ (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" "")))
+ (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
+ (funcall gnus-button-man-handler url))
+
+(defun gnus-button-handle-info-url (url)
+ "Fetch an info URL."
+ (setq url (mm-subst-char-in-string ?+ ?\ url))
+ (cond
+ ((string-match "^\\([^:/]+\\)?/\\(.*\\)" url)
+ (gnus-info-find-node
+ (concat "(" (or (gnus-url-unhex-string (match-string 1 url))
+ "Gnus")
+ ")" (gnus-url-unhex-string (match-string 2 url)))))
+ ((string-match "([^)\"]+)[^\"]+" url)
+ (setq url
+ (gnus-replace-in-string
+ (gnus-replace-in-string url "[\n\t ]+" " ") "\"" ""))
+ (gnus-info-find-node url))
+ (t (error "Can't parse %s" url))))
+
+(defun gnus-button-handle-info-url-gnome (url)
+ "Fetch GNOME style info URL."
+ (setq url (mm-subst-char-in-string ?_ ?\ url))
+ (if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
+ (gnus-info-find-node
+ (concat "("
+ (gnus-url-unhex-string
+ (match-string 1 url))
+ ")"
+ (or (gnus-url-unhex-string
+ (match-string 2 url))
+ "Top")))
+ (error "Can't parse %s" url)))
+
+(defun gnus-button-handle-info-url-kde (url)
+ "Fetch KDE style info URL."
+ (gnus-info-find-node (gnus-url-unhex-string url)))
+
+(defun gnus-button-handle-info-keystrokes (url)
+ "Call `info' when pushing the corresponding URL button."
+ ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'.
+ (info)
+ (Info-directory)
+ (Info-menu url))
+
(defun gnus-button-message-id (message-id)
"Fetch MESSAGE-ID."
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-summary-refer-article message-id)))
(defun gnus-button-fetch-group (address)
(if (not (string-match "[:/]" address))
;; This is just a simple group url.
(gnus-group-read-ephemeral-group address gnus-select-method)
- (if (not (string-match "^\\([^:/]+\\)\\(:\\([^/]+\\)/\\)?\\(.*\\)$"
- address))
+ (if (not
+ (string-match
+ "^\\([^:/]+\\)\\(:\\([^/]+\\)\\)?/\\([^/]+\\)\\(/\\([0-9]+\\)\\)?"
+ address))
(error "Can't parse %s" address)
(gnus-group-read-ephemeral-group
(match-string 4 address)
(nntp-address ,(match-string 1 address))
(nntp-port-number ,(if (match-end 3)
(match-string 3 address)
- "nntp")))))))
+ "nntp")))
+ nil nil nil
+ (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
(setq pairs (split-string query "&"))
(while pairs
(setq cur (car pairs)
- pairs (cdr pairs))
+ pairs (cdr pairs))
(if (not (string-match "=" cur))
- nil ; Grace
- (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
- val (gnus-url-unhex-string (substring cur (match-end 0) nil)))
- (if downcase
- (setq key (downcase key)))
- (setq cur (assoc key retval))
- (if cur
- (setcdr cur (cons val (cdr cur)))
- (setq retval (cons (list key val) retval)))))
+ nil ; Grace
+ (setq key (gnus-url-unhex-string (substring cur 0 (match-beginning 0)))
+ val (gnus-url-unhex-string (substring cur (match-end 0) nil) t))
+ (if downcase
+ (setq key (downcase key)))
+ (setq cur (assoc key retval))
+ (if cur
+ (setcdr cur (cons val (cdr cur)))
+ (setq retval (cons (list key val) retval)))))
retval))
-(defun gnus-url-unhex (x)
- (if (> x ?9)
- (if (>= x ?a)
- (+ 10 (- x ?a))
- (+ 10 (- x ?A)))
- (- x ?0)))
-
-(defun gnus-url-unhex-string (str &optional allow-newlines)
- "Remove %XXX embedded spaces, etc in a url.
-If optional second argument ALLOW-NEWLINES is non-nil, then allow the
-decoding of carriage returns and line feeds in the string, which is normally
-forbidden in URL encoding."
- (setq str (or str ""))
- (let ((tmp "")
- (case-fold-search t))
- (while (string-match "%[0-9a-f][0-9a-f]" str)
- (let* ((start (match-beginning 0))
- (ch1 (gnus-url-unhex (elt str (+ start 1))))
- (code (+ (* 16 ch1)
- (gnus-url-unhex (elt str (+ start 2))))))
- (setq tmp (concat
- tmp (substring str 0 start)
- (cond
- (allow-newlines
- (char-to-string code))
- ((or (= code ?\n) (= code ?\r))
- " ")
- (t (char-to-string code))))
- str (substring str (match-end 0)))))
- (setq tmp (concat tmp str))
- tmp))
-
(defun gnus-url-mailto (url)
;; Send mail to someone
(when (string-match "mailto:/*\\(.*\\)" url)
(setq url (substring url (match-beginning 1) nil)))
(let (to args subject func)
- (if (string-match (regexp-quote "?") url)
- (setq to (gnus-url-unhex-string (substring url 0 (match-beginning 0)))
- args (gnus-url-parse-query-string
- (substring url (match-end 0) nil) t))
- (setq to (gnus-url-unhex-string url)))
- (setq args (cons (list "to" to) args)
- subject (cdr-safe (assoc "subject" args)))
- (gnus-setup-message 'reply
- (message-mail)
- (while args
- (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
- (if (fboundp func)
- (funcall func)
- (message-position-on-field (caar args)))
- (insert (mapconcat 'identity (cdar args) ", "))
- (setq args (cdr args)))
- (if subject
- (message-goto-body)
- (message-goto-subject)))))
-
-(defun gnus-button-mailto (address)
- ;; Mail to ADDRESS.
- (set-buffer (gnus-copy-article-buffer))
- (gnus-setup-message 'reply
- (message-reply address)))
-
-(defun gnus-button-reply (address)
- ;; Reply to ADDRESS.
- (gnus-setup-message 'reply
- (message-reply address)))
-
-(defun gnus-button-url (address)
- "Browse ADDRESS."
- ;; In Emacs 20, `browse-url-browser-function' may be an alist.
- (if (listp browse-url-browser-function)
- (browse-url address)
- (funcall browse-url-browser-function address)))
+ (setq args (gnus-url-parse-query-string
+ (if (string-match "^\\?" url)
+ (substring url 1)
+ (if (string-match "^\\([^?]+\\)\\?\\(.*\\)" url)
+ (concat "to=" (match-string 1 url) "&"
+ (match-string 2 url))
+ (concat "to=" url)))
+ t)
+ subject (cdr-safe (assoc "subject" args)))
+ (gnus-msg-mail)
+ (while args
+ (setq func (intern-soft (concat "message-goto-" (downcase (caar args)))))
+ (if (fboundp func)
+ (funcall func)
+ (message-position-on-field (caar args)))
+ (insert (gnus-replace-in-string
+ (mapconcat 'identity (reverse (cdar args)) ", ")
+ "\r\n" "\n" t))
+ (setq args (cdr args)))
+ (if subject
+ (message-goto-body)
+ (message-goto-subject))))
(defun gnus-button-embedded-url (address)
- "Browse ADDRESS."
- ;; In Emacs 20, `browse-url-browser-function' may be an alist.
- (if (listp browse-url-browser-function)
- (browse-url (gnus-strip-whitespace address))
- (funcall browse-url-browser-function (gnus-strip-whitespace address))))
+ "Activate ADDRESS with `browse-url'."
+ (browse-url (gnus-strip-whitespace address)))
;;; Next/prev buttons in the article buffer.
(defvar gnus-next-page-line-format "%{%(Next page...%)%}\n")
(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
-(defvar gnus-prev-page-map nil)
-(unless gnus-prev-page-map
- (setq gnus-prev-page-map (make-sparse-keymap))
- (define-key gnus-prev-page-map gnus-mouse-2 'gnus-button-prev-page)
- (define-key gnus-prev-page-map "\r" 'gnus-button-prev-page))
+(defvar gnus-prev-page-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map gnus-mouse-2 'gnus-button-prev-page)
+ (define-key map "\r" 'gnus-button-prev-page)
+ map))
+
+(defvar gnus-next-page-map
+ (let ((map (make-sparse-keymap)))
+ (unless (>= emacs-major-version 21)
+ ;; XEmacs doesn't care.
+ (set-keymap-parent map gnus-article-mode-map))
+ (define-key map gnus-mouse-2 'gnus-button-next-page)
+ (define-key map "\r" 'gnus-button-next-page)
+ map))
(defun gnus-insert-prev-page-button ()
- (let ((buffer-read-only nil))
+ (let ((b (point))
+ (inhibit-read-only t)
+ (situation (get-text-property (point-min) 'mime-view-situation)))
(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))))
-
-(defvar gnus-next-page-map nil)
-(unless gnus-next-page-map
- (setq gnus-next-page-map (make-keymap))
- (suppress-keymap gnus-prev-page-map)
- (define-key gnus-next-page-map gnus-mouse-2 'gnus-button-next-page)
- (define-key gnus-next-page-map "\r" 'gnus-button-next-page))
-
-(defun gnus-button-next-page ()
+ `(keymap ,gnus-prev-page-map
+ gnus-prev t
+ gnus-callback gnus-article-button-prev-page
+ article-type annotation
+ mime-view-situation ,situation))
+ (widget-convert-button
+ 'link b (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point))
+ :action 'gnus-button-prev-page
+ :button-keymap gnus-prev-page-map)))
+
+(defun gnus-button-next-page (&optional args more-args)
"Go to the next page."
(interactive)
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-next-page)
(select-window win)))
-(defun gnus-button-prev-page ()
+(defun gnus-button-prev-page (&optional args more-args)
"Go to the prev page."
(interactive)
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-prev-page)
(select-window win)))
(defun gnus-insert-next-page-button ()
- (let ((buffer-read-only nil))
+ (let ((b (point))
+ (inhibit-read-only t)
+ (situation (get-text-property (point-min) 'mime-view-situation)))
(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))))
+ `(keymap ,gnus-next-page-map
+ gnus-next t
+ gnus-callback gnus-article-button-next-page
+ article-type annotation
+ mime-view-situation ,situation))
+ (widget-convert-button
+ 'link b (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point))
+ :action 'gnus-button-next-page
+ :button-keymap gnus-next-page-map)))
(defun gnus-article-button-next-page (arg)
"Go to the next page."
(interactive "P")
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-next-page)
(select-window win)))
"Go to the prev page."
(interactive "P")
(let ((win (selected-window)))
- (select-window (get-buffer-window gnus-article-buffer t))
+ (select-window (gnus-get-buffer-window gnus-article-buffer t))
(gnus-article-prev-page)
(select-window win)))
'(mail-decode-encoded-word-region)
"List of methods used to decode headers.
-This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item is
-FUNCTION, FUNCTION will be apply to all newsgroups. If item is a
-(REGEXP . FUNCTION), FUNCTION will be only apply to thes newsgroups
+This variable is a list of FUNCTION or (REGEXP . FUNCTION). If item
+is FUNCTION, FUNCTION will be applied to all newsgroups. If item is a
+\(REGEXP . FUNCTION), FUNCTION will be only apply to the newsgroups
whose names match REGEXP.
For example:
-((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
+\((\"chinese\" . gnus-decode-encoded-word-region-by-guess)
mail-decode-encoded-word-region
(\"chinese\" . rfc1843-decode-region))
")
(eq gnus-newsgroup-name
(car gnus-decode-header-methods-cache)))
(setq gnus-decode-header-methods-cache (list gnus-newsgroup-name))
- (mapc '(lambda (x)
- (if (symbolp x)
- (nconc gnus-decode-header-methods-cache (list x))
- (if (and gnus-newsgroup-name
- (string-match (car x) gnus-newsgroup-name))
- (nconc gnus-decode-header-methods-cache
- (list (cdr x))))))
- gnus-decode-header-methods))
+ (mapcar (lambda (x)
+ (if (symbolp x)
+ (nconc gnus-decode-header-methods-cache (list x))
+ (if (and gnus-newsgroup-name
+ (string-match (car x) gnus-newsgroup-name))
+ (nconc gnus-decode-header-methods-cache
+ (list (cdr x))))))
+ gnus-decode-header-methods))
(let ((xlist gnus-decode-header-methods-cache))
(pop xlist)
(save-restriction
(when (string-match (pop list) type)
(throw 'found t)))))))
(highlightp (gnus-visual-p 'article-highlight 'highlight))
- val elem)
+ (entity (static-unless (featurep 'xemacs)
+ (when (eq 'head condition)
+ (get-text-property (point-min) 'mime-view-entity))))
+ val elem buttonized)
(gnus-run-hooks 'gnus-part-display-hook)
- (while (setq elem (pop alist))
- (setq val (symbol-value (car elem)))
- (when (and (or (consp val)
- treated-type)
- (gnus-treat-predicate val)
- (or (not (get (car elem) 'highlight))
- highlightp))
- (save-restriction
- (funcall (cadr elem)))))))
+ (unless gnus-inhibit-treatment
+ (dolist (elem alist)
+ (setq val
+ (save-excursion
+ (when (gnus-buffer-live-p gnus-summary-buffer)
+ (set-buffer gnus-summary-buffer))
+ (symbol-value (car elem))))
+ (when (and (or (consp val)
+ treated-type)
+ (gnus-treat-predicate val)
+ (or (not (get (car elem) 'highlight))
+ highlightp))
+ (when (and (not buttonized)
+ (memq (car elem)
+ '(gnus-treat-hide-signature
+ gnus-treat-highlight-signature)))
+ (gnus-article-buttonize-signature)
+ (setq buttonized t))
+ (save-restriction
+ (funcall (cadr elem)))))
+ ;; FSF Emacsen does not inherit the existing text properties
+ ;; in the new text, so we should do it for `mime-view-entity'.
+ (static-unless (featurep 'xemacs)
+ (when entity
+ (put-text-property (point-min) (point-max)
+ 'mime-view-entity entity))))))
;; Dynamic variables.
-(defvar part-number)
-(defvar total-parts)
-(defvar type)
-(defvar condition)
-(defvar length)
+(eval-when-compile
+ (defvar part-number)
+ (defvar total-parts)
+ (defvar type)
+ (defvar condition)
+ (defvar length))
+
(defun gnus-treat-predicate (val)
(cond
- ((eq val 'mime)
- (not (not gnus-show-mime)))
((null val)
nil)
+ ((and (listp val)
+ (stringp (car val)))
+ (apply 'gnus-or (mapcar `(lambda (s)
+ (string-match s ,(or gnus-newsgroup-name "")))
+ val)))
((listp val)
(let ((pred (pop val)))
(cond
((eq pred 'and)
(apply 'gnus-and (mapcar 'gnus-treat-predicate val)))
((eq pred 'not)
- (not (gnus-treat-predicate val)))
+ (not (gnus-treat-predicate (car val))))
((eq pred 'typep)
- (equal (cadr val) type))
+ (equal (car val) type))
(t
- (gnus-treat-predicate pred)))))
+ (error "%S is not a valid predicate" pred)))))
+ ((eq val 'mime)
+ gnus-show-mime)
(condition
(eq condition val))
((eq val t)
(eq part-number total-parts))
((numberp val)
(< length val))
- ((and (listp val)
- (stringp (car val)))
- (apply 'gnus-or (mapcar `(lambda (s)
- (string-match s ,(or gnus-newsgroup-name "")))
- val)))
(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 (member gnus-newsgroup-name '("nndraft:delayed"
+ "nndraft:drafts"
+ "nndraft:queue"))
+ (error "Can't encrypt the article in group %s"
+ gnus-newsgroup-name))
+ (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* ((inhibit-read-only t)
+ (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-string)
+ (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)))
+ (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))
+ point (inhibit-read-only t))
+ (if region
+ (goto-char (car region)))
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (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))))
+ (setq point (point))
+ (gnus-mime-display-security handle)
+ (goto-char (point-max)))
+ (when region
+ (delete-region (point) (cdr region))
+ (set-marker (car region) nil)
+ (set-marker (cdr region) nil))
+ (goto-char point)))
+
+(defun gnus-mime-security-show-details (handle)
+ (let ((details (mm-handle-multipart-ctl-parameter handle 'gnus-details)))
+ (if (not details)
+ (gnus-message 5 "No details.")
+ (if gnus-mime-security-show-details-inline
+ (let ((gnus-mime-security-button-pressed
+ (not (get-text-property (point) 'gnus-mime-details)))
+ (gnus-mime-security-button-line-format
+ (get-text-property (point) 'gnus-line-format))
+ (inhibit-read-only t))
+ (forward-char -1)
+ (while (eq (get-text-property (point) 'gnus-line-format)
+ gnus-mime-security-button-line-format)
+ (forward-char -1))
+ (forward-char)
+ (save-restriction
+ (narrow-to-region (point) (point))
+ (gnus-insert-mime-security-button handle))
+ (delete-region (point)
+ (or (text-property-not-all
+ (point) (point-max)
+ 'gnus-line-format
+ gnus-mime-security-button-line-format)
+ (point-max))))
+ ;; Not inlined.
+ (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)))))
+
+(defun gnus-mime-security-press-button (handle)
+ (save-excursion
+ (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
+ gnus-callback gnus-mime-security-press-button
+ gnus-line-format ,gnus-mime-security-button-line-format
+ gnus-mime-details ,gnus-mime-security-button-pressed
+ article-type annotation
+ gnus-data ,handle))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (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).
+ (when (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))
+ (unless (gnus-unbuttonized-mime-type-p (car handle))
+ (gnus-insert-mime-security-button handle))
+ (gnus-mime-display-mixed (cdr handle))
+ (unless (bolp)
+ (insert "\n"))
+ (unless (gnus-unbuttonized-mime-type-p (car handle))
+ (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)
- )
+ (article-decode-group-name))
(set-alist 'mime-header-presentation-method-alist
'gnus-original-article-mode
(set-alist 'mime-preview-quitting-method-alist
'gnus-original-article-mode #'gnus-mime-preview-quitting-method)
-(defun gnus-following-method (buf)
- (set-buffer buf)
- (message-followup)
- (message-yank-original)
- (kill-buffer buf)
- (goto-char (point-min))
- )
-
(set-alist 'mime-preview-following-method-alist
'gnus-original-article-mode #'gnus-following-method)
(set-alist 'mime-preview-over-to-previous-method-alist
'gnus-original-article-mode
(lambda ()
- (gnus-article-read-summary-keys
- nil (gnus-character-to-event ?P))))
+ (if (> (point-min) 1)
+ (gnus-article-prev-page)
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?P)))))
(set-alist 'mime-preview-over-to-next-method-alist
'gnus-original-article-mode'
(lambda ()
- (gnus-article-read-summary-keys
- nil (gnus-character-to-event ?N))))
+ (if (< (point-max) (buffer-size))
+ (gnus-article-next-page)
+ (gnus-article-read-summary-keys
+ nil (gnus-character-to-event ?N)))))
;;; @ end