;;; gnus-art.el --- article mode commands for Gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005
;; Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;;; Code:
-(eval-when-compile (require 'cl))
+(eval-when-compile
+ (require 'cl)
+ (defvar tool-bar-map))
(require 'gnus)
(require 'gnus-sum)
(require 'mm-view)
(require 'wid-edit)
(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
"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-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."
'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.
:type '(set (const :tag "Headers with no content." empty)
(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 "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 "22.1"
+ :type 'boolean
+ :group 'gnus-article-hiding)
+
(defcustom gnus-signature-separator '("^-- $" "^-- *$")
"Regexp matching signature separator.
This can also be a list of regexps. In that case, it will be checked
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 and
-;; non-graphical frames in a session.
+;; Fixme: This isn't the right thing for mixed graphical and non-graphical
+;; frames in a session.
(defcustom gnus-article-x-face-command
(if (featurep 'xemacs)
(if (or (gnus-image-type-available-p 'xface)
(symbol :tag "Item in `gnus-article-banner-alist'" none)
regexp
(const :tag "None" nil))))
+ :version "22.1"
:group 'gnus-article-washing)
+(defmacro gnus-emphasis-custom-with-format (&rest body)
+ `(let ((format "\
+\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\
+\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)"))
+ ,@body))
+
+(defun gnus-emphasis-custom-value-to-external (value)
+ (gnus-emphasis-custom-with-format
+ (if (consp (car value))
+ (list (format format (car (car value)) (cdr (car value)))
+ 2
+ (if (nth 1 value) 2 3)
+ (nth 2 value))
+ value)))
+
+(defun gnus-emphasis-custom-value-to-internal (value)
+ (gnus-emphasis-custom-with-format
+ (let ((regexp (concat "\\`"
+ (format (regexp-quote format)
+ "\\([^()]+\\)" "\\([^()]+\\)")
+ "\\'"))
+ pattern)
+ (if (string-match regexp (setq pattern (car value)))
+ (list (cons (match-string 1 pattern) (match-string 2 pattern))
+ (= (nth 2 value) 2)
+ (nth 3 value))
+ value))))
+
(defcustom gnus-emphasis-alist
- (let ((format
- "\\(\\s-\\|^\\|\\=\\|[-\"]\\|\\s(\\)\\(%s\\(\\w+\\(\\s-+\\w+\\)*[.,]?\\)%s\\)\\(\\([-,.;:!?\"]\\|\\s)\\)+\\s-\\|[?!.]\\s-\\|\\s)\\|\\s-\\)")
- (types
- '(("\\*" "\\*" bold)
+ (let ((types
+ '(("\\*" "\\*" bold nil 2)
("_" "_" underline)
("/" "/" italic)
("_/" "/_" underline-italic)
("_\\*" "\\*_" underline-bold)
("\\*/" "/\\*" bold-italic)
("_\\*/" "/\\*_" underline-bold-italic))))
- `(,@(mapcar
- (lambda (spec)
- (list
- (format format (car spec) (cadr spec))
- 2 3 (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
- types)
- ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
- 2 3 gnus-emphasis-strikethru)
- ("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
- 2 3 gnus-emphasis-underline)))
+ (nconc
+ (gnus-emphasis-custom-with-format
+ (mapcar (lambda (spec)
+ (list (format format (car spec) (cadr spec))
+ (or (nth 3 spec) 2)
+ (or (nth 4 spec) 3)
+ (intern (format "gnus-emphasis-%s" (nth 2 spec)))))
+ types))
+ '(("\\(\\s-\\|^\\)\\(_\\(\\(\\w\\|_[^_]\\)+\\)_\\)\\(\\s-\\|[?!.,;]\\)"
+ 2 3 gnus-emphasis-underline))))
"*Alist that says how to fontify certain phrases.
Each item looks like this:
the entire emphasized word. The third is a number that says what
regexp grouping should be displayed and highlighted. The fourth
is the face used for highlighting."
- :type '(repeat (list :value ("" 0 0 default)
- regexp
- (integer :tag "Match group")
- (integer :tag "Emphasize group")
- face))
+ :type
+ '(repeat
+ (menu-choice
+ :format "%[Customizing Style%]\n%v"
+ :indent 2
+ (group :tag "Default"
+ :value ("" 0 0 default)
+ :value-create
+ (lambda (widget)
+ (let ((value (widget-get
+ (cadr (widget-get (widget-get widget :parent)
+ :args))
+ :value)))
+ (if (not (eq (nth 2 value) 'default))
+ (widget-put
+ widget
+ :value
+ (gnus-emphasis-custom-value-to-external value))))
+ (widget-group-value-create widget))
+ regexp
+ (integer :format "Match group: %v")
+ (integer :format "Emphasize group: %v")
+ face)
+ (group :tag "Simple"
+ :value (("_" . "_") nil default)
+ (cons :format "%v"
+ (regexp :format "Start regexp: %v")
+ (regexp :format "End regexp: %v"))
+ (boolean :format "Show start and end patterns: %[%v%]\n"
+ :on " On " :off " Off ")
+ face)))
+ :get (lambda (symbol)
+ (mapcar 'gnus-emphasis-custom-value-to-internal
+ (default-value symbol)))
+ :set (lambda (symbol value)
+ (set-default symbol (mapcar 'gnus-emphasis-custom-value-to-external
+ value)))
:group 'gnus-article-emphasis)
(defcustom gnus-emphasize-whitespace-regexp "^[ \t]+\\|[ \t]*\n"
Example: (_/*word*/_)."
:group 'gnus-article-emphasis)
-(defface gnus-emphasis-strikethru '((t (:strikethru t)))
+(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)
"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)
'((\"^Subject:.*gnus\\|^Newsgroups:.*gnus\" \"gnus-stuff\")
(\"^Subject:.*vm\\|^Xref:.*vm\" \"vm-stuff\"))
-This variable is an alist where the where the key is the match and the
-value is a list of possible files to save in if the match is non-nil.
+This variable is an alist where the key is the match and the
+value is a list of possible files to save in if the match is
+non-nil.
If the match is a string, it is used as a regexp match on the
article. If the match is a symbol, that symbol will be funcalled
-from the buffer of the article to be saved with the newsgroup as the
-parameter. If it is a list, it will be evaled in the same buffer.
+from the buffer of the article to be saved with the newsgroup as
+the parameter. If it is a list, it will be evaled in the same
+buffer.
-If this form or function returns a string, this string will be used as
-a possible file name; and if it returns a non-nil list, that list will
-be used as possible file names."
+If this form or function returns a string, this string will be
+used as a possible file name; and if it returns a non-nil list,
+that list will be used as possible file names."
:group 'gnus-article-saving
:type '(repeat (choice (list :value (fun) function)
(cons :value ("" "") regexp (repeat string))
:type 'hook
:group 'gnus-article-various)
-(defvar gnus-article-hide-pgp-hook nil)
-(make-obsolete-variable 'gnus-article-hide-pgp-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
(: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)
("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")
(defcustom gnus-article-decode-hook
'(article-decode-charset article-decode-encoded-words
- article-decode-group-name)
+ article-decode-group-name article-decode-idna-rhs)
"*Hook run to decode charsets in articles."
:group 'gnus-article-headers
:type 'hook)
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.1"
+ :version "22.1"
:group 'gnus-article-mime
:type '(repeat regexp))
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.3"
+ :version "22.1"
+ :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 "22.1"
:group 'gnus-article-various
:type '(choice (item :tag "None" :value nil)
string))
-(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
+(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 "22.1"
:type '(repeat directory)
:link '(url-link :tag "download"
"http://www.cs.indiana.edu/picons/ftp/index.html")
"An alist of MIME types to functions to display them."
:version "21.1"
:group 'gnus-article-mime
- :type 'alist)
+ :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.
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
+the function return t is used. For nil, the first part is
used."
:version "21.1"
:group 'gnus-article-mime
(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)
(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 Info node `(gnus)Customizing Articles'."
(defcustom gnus-treat-emphasize
(and (or window-system
- (featurep 'xemacs)
- (>= (string-to-number emacs-version) 21))
+ (featurep 'xemacs))
50000)
"Emphasize text.
Valid values are nil, t, `head', `last', an integer or a predicate.
"Remove carriage returns.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"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 "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"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 "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
-(make-obsolete-variable 'gnus-treat-strip-pgp
+(make-obsolete-variable 'gnus-treat-strip-pgp
"This option is obsolete in Gnus 5.10.")
(defcustom gnus-treat-strip-pem 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 "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-head-custom)
"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 "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Fold headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
"Fold the Newsgroups and Followup-To headers.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
:type gnus-article-treat-custom)
(put 'gnus-treat-overstrike 'highlight t)
-(defcustom gnus-treat-display-xface
+(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 (and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm)
- (string-match "^0x" (shell-command-to-string "uncompface")))
+ (string-match "^0x" (shell-command-to-string "uncompface"))
+ (executable-find "icontopbm"))
(and (featurep 'xemacs)
(featurep 'xface)))
'head)
:version "21.1"
: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)
+ :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-treat-display-face
(and (not noninteractive)
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)X-Face' for details."
:group 'gnus-article-treat
- :version "21.1"
+ :version "22.1"
: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)
+(put 'gnus-treat-display-face 'highlight t)
(defcustom gnus-treat-display-smileys
(if (or (and (featurep 'xemacs)
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 "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
:link '(custom-manual "(gnus)Customizing Articles")
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 "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
:link '(custom-manual "(gnus)Customizing Articles")
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 "22.1"
:group 'gnus-article-treat
:group 'gnus-picon
:link '(custom-manual "(gnus)Customizing Articles")
(put 'gnus-treat-newsgroups-picon 'highlight t)
(defcustom gnus-treat-body-boundary
- (if (or gnus-treat-newsgroups-picon
- gnus-treat-mail-picon
- gnus-treat-from-picon)
+ (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, t, `head', `last', an integer or a predicate.
+Valid values are nil and `head'.
See Info node `(gnus)Customizing Articles' for details."
- :version "21.1"
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
- :type gnus-article-treat-custom)
+ :type gnus-article-treat-head-custom)
(defcustom gnus-treat-capitalize-sentences nil
"Capitalize sentence-starting words.
"Format as HTML.
Valid values are nil, t, `head', `last', an integer or a predicate.
See Info node `(gnus)Customizing Articles' for details."
+ :version "22.1"
:group 'gnus-article-treat
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
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 "22.1"
:group 'gnus-article-treat
:group 'mime-security
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-article-encrypt-protocol "PGP"
"The protocol used for encrypt articles.
It is a string, such as \"PGP\". If nil, ask user."
+ :version "22.1"
: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 "22.1"
+ :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 "22.1"
+ :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)
(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-xface gnus-article-display-x-face)
+ (gnus-treat-display-x-face gnus-article-display-x-face)
(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-strip-multiple-blank-lines
gnus-article-strip-multiple-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)
(gnus-treat-fold-newsgroups gnus-article-treat-fold-newsgroups)
(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 ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(inhibit-point-motion-hooks t)
(case-fold-search t))
(article-narrow-to-head)
(defmacro gnus-with-article-buffer (&rest forms)
`(save-excursion
(set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
,@forms)))
(put 'gnus-with-article-buffer 'lisp-indent-function 0)
(interactive)
;; This function might be inhibited.
(unless gnus-inhibit-hiding
- (save-excursion
- (save-restriction
- (let ((buffer-read-only nil)
- (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)
+ (let ((inhibit-read-only nil)
+ (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.
(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)
(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 (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
- (gnus-string-equal
- (nth 1 (mail-extract-address-components from))
- (nth 1 (mail-extract-address-components reply-to)))))
- (gnus-article-hide-header "reply-to"))))
+ (equal
+ (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
(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)
(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****s*** 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.
-Sm*rtq**t*s are M****s***'s unilateral extension to the 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."
+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))))
(put-text-property
(point) (1+ (point)) '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
(while (not (eobp))
(save-restriction
(mail-header-narrow-to-field)
- (let ((header (buffer-substring (point-min) (point-max))))
+ (let ((header (buffer-string)))
(with-temp-buffer
(insert header)
(goto-char (point-min))
"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)
(while (not (eobp))
(end-of-line)
(when (>= (current-column) (min fill-column width))
- (narrow-to-region (min (1+ (point)) (point-max)) (gnus-point-at-bol))
+ (narrow-to-region (min (1+ (point)) (point-max))
+ (point-at-bol))
(let ((goback (point-marker)))
(fill-paragraph nil)
(goto-char (marker-position goback)))
"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)
- (gnus-with-article-headers
- (let ((face nil))
- (save-excursion
- (when (gnus-buffer-live-p gnus-original-article-buffer)
- (set-buffer gnus-original-article-buffer)
- (setq face (message-fetch-field "face"))))
- (when face
- (let ((png (gnus-convert-face-to-png face))
- image)
- (when png
- (setq image (gnus-create-image png 'png t))
- (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)))))))
+ (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."
;; Delete the old process, if any.
(when (process-status "article-x-face")
(delete-process "article-x-face"))
- (if (memq 'xface gnus-article-wash-types)
+ ;; 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)
(not (string-match gnus-article-x-face-too-ugly
from)))))
;; 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 face)
- (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))
- (with-temp-buffer
- (insert face)
- (process-send-region "article-x-face"
- (point-min) (point-max)))
- (process-send-eof "article-x-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)))
+ (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)
If PROMPT (the prefix), prompt for a coding system to use."
(interactive "P")
(let ((inhibit-point-motion-hooks t) (case-fold-search t)
- buffer-read-only
+ (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))
- buffer-read-only)
+ (inhibit-read-only t))
(save-restriction
(article-narrow-to-head)
(funcall gnus-decode-header-function (point-min) (point-max)))))
(defun article-decode-group-name ()
"Decode group names in `Newsgroups:'."
(let ((inhibit-point-motion-hooks t)
- buffer-read-only
+ (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))
- (when (nnmail-fetch-field "Newsgroups")
- (nnheader-replace-header "Newsgroups"
- (gnus-decode-newsgroups
- (with-current-buffer
- gnus-original-article-buffer
- (nnmail-fetch-field "Newsgroups"))
- gnus-newsgroup-name method)))
- (when (nnmail-fetch-field "Followup-To")
- (nnheader-replace-header "Followup-To"
- (gnus-decode-newsgroups
- (with-current-buffer
- gnus-original-article-buffer
- (nnmail-fetch-field "Followup-To"))
- gnus-newsgroup-name method))))))
+ (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 READ-CHARSET, ask for a coding system."
(interactive (list 'force current-prefix-arg))
(save-excursion
- (let ((buffer-read-only nil) type 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
If READ-CHARSET, ask for a coding system."
(interactive (list 'force current-prefix-arg))
(save-excursion
- (let ((buffer-read-only nil) type 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
(interactive)
(require 'rfc1843)
(save-excursion
- (let ((buffer-read-only nil))
+ (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 ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(goto-char (point-min))
(while (re-search-forward
- "^\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
+ "\\(\\(https?\\|ftp\\)://\\S-+\\) *\n\\(\\S-+\\)" nil t)
(replace-match "\\1\\3" t)))
- (when (and gnus-display-mime-function (interactive-p))
- (funcall gnus-display-mime-function))))
+ (when (interactive-p)
+ (gnus-treat-article nil))))
(defun article-wash-html (&optional read-charset)
If READ-CHARSET, ask for a coding system."
(interactive "P")
(save-excursion
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
charset)
(when (gnus-buffer-live-p gnus-original-article-buffer)
(with-current-buffer gnus-original-article-buffer
(when entry
(setq func (cdr entry)))
(cond
- ((gnus-functionp func)
+ ((functionp func)
(funcall func))
(t
(apply (car func) (cdr func))))))))))
(mm-setup-w3m)
(save-restriction
(narrow-to-region (point) (point-max))
- (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images
- nil
- "\\`cid:"))
- (w3m-display-inline-images mm-inline-text-html-with-images)
+ (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp)
w3m-force-redisplay)
(w3m-region (point-min) (point-max)))
- (when mm-inline-text-html-with-w3m-keymap
+ (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)
- (nconc (mm-w3m-local-map-property)
- '(mm-inline-text-html-with-w3m t))))))
+ (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.
(regexp (if (consp gnus-list-identifiers)
(mapconcat 'identity gnus-list-identifiers " *\\|")
gnus-list-identifiers))
- buffer-read-only)
+ (inhibit-read-only t))
(when regexp
(save-excursion
(save-restriction
(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
(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-parameter-banner gnus-newsgroup-name))
(gnus-signature-limit nil)
- buffer-read-only beg end)
- (when (and gnus-article-address-banner-alist
- (not banner))
- (setq banner
- (let ((from (save-restriction
- (widen)
- (article-narrow-to-head)
- (mail-fetch-field "from"))))
- (when (and from
- (setq from
- (caar (mail-header-parse-addresses from))))
- (catch 'found
- (dolist (pair gnus-article-address-banner-alist)
- (when (string-match (car pair) from)
- (throw 'found (cdr pair)))))))))
- (when banner
- (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))))))))))
+ (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))
(orig (buffer-substring start end))
(trans (babel-as-string orig)))
(unless (gnus-article-check-hidden-text 'signature arg)
(save-excursion
(save-restriction
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(when (gnus-article-narrow-to-signature)
(gnus-article-hide-text-type
(point-min) (point-max) 'signature))))))
(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)
(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-show-hidden-text (type &optional dummy)
"Show all hidden text of type TYPE.
Originally it is hide instead of DUMMY."
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(inhibit-point-motion-hooks t))
(gnus-remove-text-properties-when
'article-type type
(save-restriction
(article-narrow-to-head)
(when (re-search-forward tdate-regexp nil t)
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- date (or (get-text-property (gnus-point-at-bol)
+ (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- (gnus-point-at-eol)) 'face))
+ eface (get-text-property (1- (point-at-eol)) 'face))
(forward-line 1))
(when (and date (not (string= date "")))
(goto-char (point-min))
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
;; Delete any old Date headers.
(while (re-search-forward date-regexp nil t)
(if pos
- (delete-region (progn (beginning-of-line) (point))
- (progn (gnus-article-forward-header)
- (point)))
- (delete-region (progn (beginning-of-line) (point))
+ (delete-region (point-at-bol)
(progn (gnus-article-forward-header)
- (forward-char -1)
(point)))
+ (delete-region (point-at-bol)
+ (progn (gnus-article-forward-header)
+ (forward-char -1)
+ (point)))
(setq pos (point))))
(when (and (not pos)
(re-search-forward tdate-regexp nil t))
(forward-line 1))
- (when pos
- (goto-char pos))
+ (gnus-goto-char pos)
(insert (article-make-date-line date (or type 'ut)))
(unless pos
(insert "\n")
;; Do highlighting.
(beginning-of-line)
(when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'original-date date)
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
+ (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))))))))
(cond
;; Convert to the local timezone.
((eq type 'local)
- (let ((tz (car (current-time-zone time))))
- (format "Date: %s %s%02d%02d" (current-time-string time)
- (if (> tz 0) "+" "-") (/ (abs tz) 3600)
- (/ (% (abs tz) 3600) 60))))
+ (concat "Date: " (message-make-date time)))
;; Convert to Universal Time.
((eq type 'ut)
(concat "Date: "
- (current-time-string
- (let* ((e (parse-time-string date))
- (tm (apply 'encode-time e))
- (ms (car tm))
- (ls (- (cadr tm) (car (current-time-zone time)))))
- (cond ((< ls 0) (list (1- ms) (+ ls 65536)))
- ((> ls 65535) (list (1+ ms) (- ls 65536)))
- (t (list ms ls)))))
- " UT"))
+ (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)
gnus-article-time-format)
(error nil))
gnus-article-time-format)))
- (if (gnus-functionp format)
+ (if (functionp format)
(funcall format time)
(concat "Date: " (format-time-string format time)))))
;; ISO 8601.
(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."
;; "Show all hidden text in the article buffer."
;; (interactive)
;; (save-excursion
-;; (let ((buffer-read-only nil))
+;; (let ((inhibit-read-only t))
;; (gnus-article-unhide-text (point-min) (point-max)))))
(defun article-remove-leading-whitespace ()
(interactive)
(save-excursion
(save-restriction
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(article-narrow-to-head)
(goto-char (point-min))
(while (re-search-forward "^[^ :]+: \\([ \t]+\\)" nil t)
gnus-article-emphasis-alist)
(error))
gnus-emphasis-alist))
- (buffer-read-only nil)
+ (inhibit-read-only t)
(props (append '(article-type emphasis)
gnus-hidden-properties))
regexp elem beg invisible visible face)
mml2015-use
(mml2015-clear-verify-function))
(with-temp-buffer
- (insert-buffer gnus-original-article-buffer)
+ (insert-buffer-substring gnus-original-article-buffer)
(setq items (split-string sig))
(message-narrow-to-head)
(let ((inhibit-point-motion-hooks t)
;; Don't verify multiple headers.
(setq headers (mapconcat (lambda (header)
(concat header ": "
- (mail-fetch-field header) "\n"))
+ (mail-fetch-field header)
+ "\n"))
(split-string (nth 1 items) ",") "")))
(delete-region (point-min) (point-max))
(insert "-----BEGIN PGP SIGNED MESSAGE-----\n\n")
(mm-handle-multipart-ctl-parameter
mm-security-handle 'gnus-info)))))
(when info
- (let (buffer-read-only bface eface)
+ (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 (gnus-point-at-bol) 'face)
- eface (get-text-property (1- (gnus-point-at-eol)) 'face))
+ (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)
article-verify-cancel-lock
article-hide-boring-headers
article-treat-overstrike
+ article-treat-ansi-sequences
article-fill-long-lines
article-capitalize-sentences
article-remove-cr
["Hide signature" gnus-article-hide-signature t]
["Hide citation" gnus-article-hide-citation t]
["Treat overstrike" gnus-article-treat-overstrike 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]
["Remove quoted-unreadable" gnus-article-de-quoted-unreadable t]
(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-image-alist)
(make-local-variable 'gnus-article-charset)
(make-local-variable 'gnus-article-ignored-charsets)
+ ;; Prevent recent Emacsen from displaying non-break space as "\ ".
+ (set (make-local-variable 'show-nonbreak-escape) nil)
(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)
(mm-enable-multibyte)
(gnus-run-hooks 'gnus-article-mode-hook))
(mm-enable-multibyte)
(setq major-mode 'gnus-original-article-mode)
(make-local-variable 'gnus-original-article))
- (if (get-buffer name)
+ (if (and (get-buffer name)
+ (with-current-buffer name
+ (if gnus-article-edit-mode
+ (if (y-or-n-p "Article mode edit in progress; discard? ")
+ (progn
+ (set-buffer-modified-p nil)
+ (gnus-kill-buffer name)
+ (message "")
+ nil)
+ (error "Action aborted"))
+ t)))
(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)
(when gnus-article-mime-handles
(mm-destroy-parts gnus-article-mime-handles)
(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 (memq article gnus-newsgroup-undownloaded)
+ (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-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))
;; Hooks for getting information from the article.
;; This hook must be called before being narrowed.
(let ((gnus-article-buffer (current-buffer))
- buffer-read-only)
+ buffer-read-only
+ (inhibit-read-only t))
(unless (eq major-mode 'gnus-article-mode)
(gnus-article-mode))
(setq buffer-read-only nil
(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")))
+ (gnus-mime-action-on-part "." "Take action on the part...")))
(defun gnus-article-mime-part-status ()
(if gnus-article-mime-handle-alist-1
(defvar gnus-mime-button-map
(let ((map (make-sparse-keymap)))
- (unless (>= (string-to-number emacs-version) 21)
- ;; XEmacs doesn't care.
- (set-keymap-parent map gnus-article-mode-map))
(define-key map gnus-mouse-2 'gnus-article-push-button)
(define-key map gnus-down-mouse-3 'gnus-mime-button-menu)
(dolist (c gnus-mime-button-commands)
(define-key map (cadr c) (car c)))
map))
-(defun gnus-mime-button-menu (event)
- "Construct a context-sensitive menu of MIME commands."
- (interactive "e")
- (save-window-excursion
- (let ((pos (event-start event)))
- (select-window (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
- (call-interactively response))))))
+(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
(mm-remove-parts handles)
(goto-char (point-min))
(or (search-forward "\n\n") (goto-char (point-max)))
- (let (buffer-read-only)
+ (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)
- (let* ((data (get-text-property (point) 'gnus-data))
- file param
- (handles gnus-article-mime-handles))
- (if (mm-multiple-handles gnus-article-mime-handles)
- (error "This function is not implemented"))
- (setq file (and data (mm-save-part data)))
- (when file
+ (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)
- (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)))))
+ (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-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))
- ;; LOCAL argument of add-hook differs between GNU Emacs
- ;; and XEmacs. make-local-hook makes sure they are local.
- (make-local-hook 'kill-buffer-hook)
- (add-hook 'kill-buffer-hook 'mml-destroy-buffers t t)))
- `(lambda (no-highlight)
- (let ((mail-parse-charset (or gnus-article-charset
- ',gnus-newsgroup-charset))
- (message-options message-options)
- (message-options-set-recipient)
- (mail-parse-ignored-charsets
- (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-part handles))))
(defun gnus-mime-save-part ()
"Save the MIME part under point."
(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)
+(defun gnus-mime-copy-part (&optional handle arg)
"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)
+ (interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- (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)
+ (unless handle
+ (setq handle (get-text-property (point) 'gnus-data)))
+ (when handle
+ (let ((filename (or (mail-content-type-get (mm-handle-disposition handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename)))
+ contents dont-decode charset coding-system)
+ (mm-with-unibyte-buffer
+ (mm-insert-part handle)
+ (setq contents (or (condition-case nil
+ (mm-decompress-buffer filename nil 'sig)
+ (error
+ (setq dont-decode t)
+ nil))
+ (buffer-string))))
+ (setq filename (cond (filename (file-name-nondirectory filename))
+ (dont-decode "*raw data*")
+ (t "*decoded*")))
+ (cond
+ (dont-decode)
+ ((not arg)
+ (unless (setq charset (mail-content-type-get
+ (mm-handle-type handle) 'charset))
+ (unless (setq coding-system (mm-with-unibyte-buffer
+ (insert contents)
+ (mm-find-buffer-file-coding-system)))
+ (setq charset gnus-newsgroup-charset))))
+ ((numberp arg)
+ (setq charset (or (cdr (assq arg
+ gnus-summary-show-article-charset-alist))
+ (mm-read-coding-system "Charset: ")))))
+ (switch-to-buffer (generate-new-buffer filename))
+ (if (or coding-system
+ (and charset
+ (setq coding-system (mm-charset-to-coding-system charset))
+ (not (eq charset 'ascii))))
+ (progn
+ (mm-enable-multibyte)
+ (insert (mm-decode-coding-string contents coding-system))
+ (setq buffer-file-coding-system
+ (if (boundp 'last-coding-system-used)
+ (symbol-value 'last-coding-system-used)
+ coding-system)))
+ (mm-disable-multibyte)
+ (insert contents)
+ (setq buffer-file-coding-system mm-binary-coding-system))
;; 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)
+ (setq buffer-file-name (expand-file-name filename))
(normal-mode))
(setq buffer-file-name nil))
(goto-char (point-min)))))
(ps-despool filename)))))
(defun gnus-mime-inline-part (&optional handle arg)
- "Insert the MIME part under point into the current buffer."
+ "Insert the MIME part under point into the current buffer.
+Compressed files like .gz and .bz2 are decompressed."
(interactive (list nil current-prefix-arg))
(gnus-article-check-buffer)
- (let* ((handle (or handle (get-text-property (point) 'gnus-data)))
- contents charset
- (b (point))
- buffer-read-only)
- (when handle
+ (unless handle
+ (setq handle (get-text-property (point) 'gnus-data)))
+ (when handle
+ (let ((b (point))
+ (inhibit-read-only t)
+ contents charset coding-system)
(if (and (not arg) (mm-handle-undisplayer handle))
(mm-remove-part handle)
- (setq contents (mm-get-part handle))
+ (mm-with-unibyte-buffer
+ (mm-insert-part handle)
+ (setq contents
+ (or (mm-decompress-buffer
+ (or (mail-content-type-get (mm-handle-disposition handle)
+ 'name)
+ (mail-content-type-get (mm-handle-disposition handle)
+ 'filename))
+ nil t)
+ (buffer-string))))
(cond
((not arg)
- (setq charset (or (mail-content-type-get
- (mm-handle-type handle) 'charset)
- gnus-newsgroup-charset)))
+ (unless (setq charset (mail-content-type-get
+ (mm-handle-type handle) 'charset))
+ (unless (setq coding-system
+ (mm-with-unibyte-buffer
+ (insert contents)
+ (mm-find-buffer-file-coding-system)))
+ (setq 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: ")))))
+ (mm-read-coding-system "Charset: "))))
+ (t
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle))))
(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))
+ (mm-insert-inline
+ handle
+ (if (or coding-system
+ (and charset
+ (setq coding-system
+ (mm-charset-to-coding-system charset))
+ (not (eq charset 'ascii))))
+ (mm-decode-coding-string contents coding-system)
+ (mm-string-to-multibyte contents)))
(goto-char b)))))
(defun gnus-mime-view-part-as-charset (&optional handle arg)
(let* ((handle (or handle (get-text-property (point) 'gnus-data)))
contents charset
(b (point))
- buffer-read-only)
+ (inhibit-read-only t))
(when handle
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))
(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)))
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
(when handle
(if (mm-handle-undisplayer handle)
(mm-remove-part handle)
(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)))
+ (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)
(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)))
+ (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)
(gnus-article-part-wrapper n 'gnus-mime-copy-part))
(defun gnus-article-view-part-as-charset (n)
- "Copy MIME part N, which is the numerical prefix."
+ "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-mime-match-handle-first (condition)
(if condition
- (let ((alist gnus-article-mime-handle-alist) ihandle n)
- (while (setq ihandle (pop alist))
+ (let (n)
+ (dolist (ihandle gnus-article-mime-handle-alist)
(if (and (cond
((functionp condition)
(funcall condition (cdr ihandle)))
(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)
+ (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))
"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
(if (gnus-buffer-live-p gnus-summary-buffer)
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
gnus-newsgroup-ignored-charsets)
nil)))
(save-excursion
(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
(setq b (point))
(gnus-eval-format
gnus-mime-button-line-format gnus-mime-button-line-format-alist
- `(,@(gnus-local-map-property gnus-mime-button-map)
- gnus-callback gnus-mm-display-part
- gnus-part ,gnus-tmp-id
- article-type annotation
- gnus-data ,handle))
- (setq e (point))
+ `(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
;; 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 nil gnus-article-loose-mime)
- (and gnus-article-emulate-mime
- (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.
(narrow-to-region (point-min) (point))
(gnus-treat-article 'head))))))))
-(defvar gnus-mime-display-multipart-as-mixed nil)
-(defvar gnus-mime-display-multipart-alternative-as-mixed nil)
-(defvar gnus-mime-display-multipart-related-as-mixed nil)
+(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)
+
+(defcustom gnus-mime-display-multipart-alternative-as-mixed nil
+ "Display \"multipart/alternative\" parts as \"multipart/mixed\"."
+ :version "22.1"
+ :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 "22.1"
+ :group 'gnus-article-mime
+ :type 'boolean)
(defun gnus-mime-display-part (handle)
(cond
(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)
;; Remember modify the number of forward lines.
(setq move t))
(setq beg (point))
(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
(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
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',not-pref ',begend ,id))
- ,@(gnus-local-map-property gnus-mime-button-map)
+ keymap ,gnus-mime-button-map
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
gnus-part ,id
',gnus-article-mime-handle-alist))
(gnus-mime-display-alternative
',ihandles ',handle ',begend ,id))
- ,@(gnus-local-map-property gnus-mime-button-map)
+ keymap ,gnus-mime-button-map
,gnus-mouse-face-prop ,gnus-article-mouse-face
face ,gnus-article-button-face
gnus-part ,id
(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)))
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets)))
(mm-display-part preferred)
;; Do highlighting.
(save-excursion
(defun gnus-article-wash-status ()
"Return a string which display status of article washing."
- (save-excursion
- (set-buffer gnus-article-buffer)
+ (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))
"Delete all images in CATEGORY."
(let ((entry (assq category gnus-article-image-alist)))
(dolist (image (cdr entry))
- (gnus-remove-image image))
+ (gnus-remove-image image category))
(setq gnus-article-image-alist (delq entry gnus-article-image-alist))
(gnus-delete-wash-type category)))
"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)))
(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) (save-restriction (widen) (point-max))))
+ (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 (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 ()
(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))
+ 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)
(functionp func))
(progn
(call-interactively func)
- (setq new-sum-point (point))
+ (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)
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)))) )
- (switch-to-buffer gnus-article-buffer)
+ (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)
(interactive "P")
(let ((article (cdr gnus-article-current))
contents)
- (if (not (gnus-mark-active-p))
+ (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)))
(interactive)
(let ((article (cdr gnus-article-current))
contents)
- (if (not (gnus-mark-active-p))
+ (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)))
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)
- (save-excursion
- (set-buffer gnus-original-article-buffer)
+ (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)
(gnus-cache-request-article article group))
'article)
;; Check the agent cache.
- ((and gnus-agent gnus-agent-cache gnus-plugged
- (numberp article)
- (gnus-agent-request-article article group))
+ ((gnus-agent-request-article article group)
'article)
;; Get the article and put into the article buffer.
((or (stringp article)
(backend (car (gnus-find-method-for-group
gnus-newsgroup-name)))
result
- (buffer-read-only nil))
+ (inhibit-read-only t))
(if (or (not (listp methods))
(and (symbolp (car methods))
(assq (car methods) nnoo-definition-alist)))
(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)))
(defvar gnus-article-edit-done-function nil)
(defvar gnus-article-edit-mode-map nil)
-(defvar gnus-article-edit-mode nil)
;; Should we be using derived.el for this?
(unless gnus-article-edit-mode-map
["Body" message-goto-body t]
["Signature" message-goto-signature t]))
-(define-derived-mode gnus-article-edit-mode text-mode "Article Edit"
+(define-derived-mode gnus-article-edit-mode message-mode "Article Edit"
"Major mode for editing articles.
This is an extended text-mode.
"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)
(set-buffer-modified-p nil)
(gnus-configure-windows 'edit-article)
(car gnus-article-current) (cdr gnus-article-current)))
;; We remove all text props from the article buffer.
(kill-all-local-variables)
- (gnus-set-text-properties (point-min) (point-max) nil)
+ (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."
(save-current-buffer
(set-buffer curbuf)
(set-window-start (get-buffer-window (current-buffer)) window-start)
- (goto-char p))))))
+ (goto-char p))))
+ (gnus-summary-show-article)))
(defun gnus-article-edit-full-stops ()
"Interactively repair spacing at end of sentences."
(defcustom gnus-button-url-regexp
(if (string-match "[[:digit:]]" "1") ;; support POSIX?
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|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\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~`%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~`%&*+\\/]\\|\\w\\)\\)")
+ "\\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
- (concat "[a-z0-9][-.a-z0-9]+\\." ;; [hostname.subdomain.]domain.
- ;; valid TLDs:
- "\\([a-z][a-z]" ;; two letter country TDLs
- "\\|biz\\|com\\|edu\\|gov\\|int\\|mil\\|net\\|org"
- "\\|aero\\|coop\\|info\\|name\\|museum"
- "\\|arpa\\|pro\\|uucp\\|bitnet\\|bofh" ;; old style?
- "\\)")
+ message-valid-fqdn-regexp
"Regular expression that matches a valid FQDN."
+ :version "22.1"
:group 'gnus-article-buttons
:type 'regexp)
"Function to use for displaying man pages.
The function must take at least one argument with a string naming the
man page."
+ :version "22.1"
:type '(choice (function-item :tag "Man" manual-entry)
(function-item :tag "Woman" woman)
(function :tag "Other"))
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 "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type '(choice (const "http://www.tex.ac.uk/tex-archive/")
(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 "22.1"
: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 "22.1"
: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 "22.1"
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
(defcustom gnus-button-mid-or-mail-regexp
- (concat "\\b\\(<?[a-z0-9][^<>\")!;:,{}\n\t ]*@"
+ (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 "22.1"
:group 'gnus-article-buttons
:type 'regexp)
-(defcustom gnus-button-prefer-mid-or-mail 'guess
- "What to do when the button on a string as \"foo123@bar.com\" is pushed.
-Strings like this can be either a message ID or a mail address. If the
-variable is set to the symbol `ask', query the user what do do. If it is the
-symbol `guess', Gnus will do a guess and query the user what do do if it is
-ambiguous. See the variable `gnus-button-guessed-mid-regexp' for details
-concerning the guessing. If it is one of the sybols `mid' or `mail', Gnus
-will always assume that the string is a message ID or a mail address,
-respectivly."
- ;; FIXME: doc-string could/should be improved.
+(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 "22.1"
:group 'gnus-article-buttons
- :type '(choice (const ask)
- (const guess)
+ :type '(choice (function-item :tag "Heuristic function"
+ gnus-button-mid-or-mail-heuristic)
+ (const ask)
(const mid)
(const mail)))
-(defcustom gnus-button-guessed-mid-regexp
- (concat
- "^<?\\(slrn\\|Pine\\.\\)"
- "\\|\\.fsf@\\|\\.fsf_-_@\\|\\.ln@"
- "\\|@4ax\\.com\\|@ID-[0-9]+\\.[a-zA-Z]+\\.dfncis\\.de"
- "\\|^<?.*[0-9].*[0-9].*[0-9].*[0-9].*[0-9].*[0-9].*@")
- "Regular expression that matches message IDs and not mail addresses."
- ;; TODO: Incorporate more matches from
- ;; <URL:http://piology.org/perl/id-or-mail.pl.html>. I.e. translate the
- ;; Perl-REs to Elisp-REs.
+(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 "22.1"
:group 'gnus-article-buttons
- :type 'regexp)
+ :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)
+ (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)
- ;; If it looks like a MID (well known readers or servers) use 'mid,
- ;; otherwise 'ask the user.
- (if (eq pref 'guess)
- (if (string-match gnus-button-guessed-mid-regexp mid-or-mail)
- (setq pref 'mid)
- (setq pref 'ask)))
+ (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 9 "calling `gnus-button-handle-news' %s" url-mid)
+ (gnus-message 8 "calling `gnus-button-handle-news' %s" url-mid)
(gnus-button-handle-news url-mid))
((eq pref 'mail)
- (gnus-message 9 "calling `gnus-url-mailto' %s" url-mailto)
- (gnus-url-mailto url-mailto)))))
+ (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."
(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-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
(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
"*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
-specifific groups. Setting it higher in TeX groups is probably a good idea.
+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 "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type 'integer)
"*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
-specifific groups. Setting it higher in Unix groups is probably a good idea.
+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 "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type 'integer)
"*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
-specifific groups. Setting it higher in Emacs or Gnus related groups is
+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 "22.1"
:group 'gnus-article-buttons
:link '(custom-manual "(gnus)Group Parameters")
:type 'integer)
-(defcustom gnus-button-mail-level 5
- "*Integer that says how many buttons for message IDs or mail addresses will appear.
+(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 "22.1"
+ :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 "22.1"
:group 'gnus-article-buttons
:type 'integer)
(defcustom gnus-button-alist
'(("<\\(url:[>\n\t ]*?\\)?\\(nntp\\|news\\):[>\n\t ]*\\([^>\n\t ]*@[^>\n\t ]*\\)>"
- 0 t gnus-button-handle-news 3)
+ 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 ]*\\)?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-z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
- ("\\bmailto:\\([^ \n\t]+\\)" 0 t gnus-url-mailto 1)
+ ("\\(\\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
- ("\\bCTAN:[ \t\n]*\\([^>)!;:,\n\t ]*\\)" 0 (>= gnus-button-tex-level 1)
- gnus-button-handle-ctan 1)
- ;; This is info
- ("\\binfo:\\(//\\)?\\([^'\">\n\t ]+\\)" 0
- (>= gnus-button-emacs-level 1) gnus-button-handle-info 2)
+ ((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)
+ ("\\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
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]+\\([^']+\\)\\)'" 1
+ ("`\\(\\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.
- (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
- ;; This is how URLs _should_ be embedded in text...
- ("<URL: *\\([^<>]*\\)>" 1 t gnus-button-embedded-url 1)
+ 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 browse-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))
+ ("\\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))
+ ("\\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)
- ("\\b\\([a-z][-_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W" 0
- (>= gnus-button-man-level 5) gnus-button-handle-man 1)
+ ;; 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-mail-level 5) gnus-button-handle-mid-or-mail 1))
+ 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 (case insensitive) matching text around the button (can
-also be lisp expression evaluating to a string),
+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 (choice regexp variable)
+ :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 browse-url 0)
- ("^Subject:" gnus-button-url-regexp 0 t browse-url 0)
- ("^[^:]+:" gnus-button-url-regexp 0 t browse-url 0)
- ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?]+\\)" 0 t gnus-url-mailto 1)
- ("^[^:]+:" "\\(<\\(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)
+ ("^OpenPGP:.*url=" gnus-button-url-regexp
+ 0 (>= gnus-button-browse-level 0) gnus-button-openpgp 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)
(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)
- (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))
(save-restriction
(when (and gnus-signature-face
(gnus-article-narrow-to-signature))
\"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)
(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 (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)))))))
+ (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:
;;; 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))
+ (gnus-with-article-buffer
+ (let ((inhibit-point-motion-hooks t))
(if (text-property-any end (point-max) 'article-type 'signature)
(progn
(gnus-delete-wash-type 'signature)
(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))))
(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)
+(defun gnus-button-handle-info-url (url)
"Fetch an info URL."
- (if (string-match
- "^\\([^:/]+\\)?/\\(.*\\)"
- 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 "(" (or (gnus-url-unhex-string (match-string 1 url))
- "Gnus")
+ (concat "("
+ (gnus-url-unhex-string
+ (match-string 1 url))
")"
- (gnus-url-unhex-string (match-string 2 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-openpgp (url)
+ "Retrieve and add an OpenPGP key given URL from an OpenPGP header."
+ (with-temp-buffer
+ (mm-url-insert-file-contents-external url)
+ (pgg-snarf-keys-region (point-min) (point-max))
+ (pgg-display-output-buffer nil nil nil)))
+
(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)
(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)
+ (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
(if (fboundp func)
(funcall func)
(message-position-on-field (caar args)))
- (insert (mapconcat 'identity (cdar args) ", "))
+ (insert (gnus-replace-in-string
+ (mapconcat 'identity (reverse (cdar args)) ", ")
+ "\r\n" "\n" t))
(setq args (cdr args)))
(if subject
(message-goto-body)
(defvar gnus-prev-page-line-format "%{%(Previous page...%)%}\n")
(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-prev-page)
- (define-key map "\r" 'gnus-button-prev-page)
+ (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 ((b (point))
- (buffer-read-only nil))
+ (inhibit-read-only t))
(gnus-eval-format
gnus-prev-page-line-format nil
- `(,@(gnus-local-map-property gnus-prev-page-map)
+ `(keymap ,gnus-prev-page-map
gnus-prev t
gnus-callback gnus-article-button-prev-page
article-type annotation))
(widget-convert-button
- 'link b (point)
+ 'link b (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point))
:action 'gnus-button-prev-page
:button-keymap gnus-prev-page-map)))
-(defvar gnus-prev-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-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-button-next-page (&optional args more-args)
"Go to the next page."
(interactive)
(defun gnus-insert-next-page-button ()
(let ((b (point))
- (buffer-read-only nil))
+ (inhibit-read-only t))
(gnus-eval-format gnus-next-page-line-format nil
- `(,@(gnus-local-map-property gnus-next-page-map)
+ `(keymap ,gnus-next-page-map
gnus-next t
gnus-callback gnus-article-button-next-page
article-type annotation))
(widget-convert-button
- 'link b (point)
+ 'link b (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point))
:action 'gnus-button-next-page
:button-keymap gnus-next-page-map)))
"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
+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:
(setq references
(or (mail-header-references gnus-current-headers) ""))
(set-buffer gnus-article-buffer)
- (let* ((buffer-read-only nil)
+ (let* ((inhibit-read-only t)
(headers
(mapcar (lambda (field)
(and (save-restriction
(search-forward field nil t))
(prog2
(message-narrow-to-field)
- (buffer-substring (point-min) (point-max))
+ (buffer-string)
(delete-region (point-min) (point-max))
(widen))))
'("Content-Type:" "Content-Transfer-Encoding:"
(defvar gnus-mime-security-button-map
(let ((map (make-sparse-keymap)))
- (unless (>= (string-to-number emacs-version) 21)
- (set-keymap-parent map gnus-article-mode-map))
(define-key map gnus-mouse-2 'gnus-article-push-button)
(define-key map "\r" 'gnus-article-press-button)
map))
(defun gnus-mime-security-verify-or-decrypt (handle)
(mm-remove-parts (cdr handle))
(let ((region (mm-handle-multipart-ctl-parameter handle 'gnus-region))
- point buffer-read-only)
+ point (inhibit-read-only t))
(if region
(goto-char (car region)))
(save-restriction
(not (get-text-property (point) 'gnus-mime-details)))
(gnus-mime-security-button-line-format
(get-text-property (point) 'gnus-line-format))
- buffer-read-only)
+ (inhibit-read-only t))
(forward-char -1)
(while (eq (get-text-property (point) 'gnus-line-format)
gnus-mime-security-button-line-format)
(gnus-eval-format
gnus-mime-security-button-line-format
gnus-mime-security-button-line-format-alist
- `(,@(gnus-local-map-property gnus-mime-security-button-map)
+ `(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 (point))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point)))
(widget-convert-button
'link b e
:mime-handle handle
(run-hooks 'gnus-art-load-hook)
+;;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33
;;; gnus-art.el ends here
projects / gnus / blobdiff