;;; gnus-art.el --- article mode commands for Semi-gnus
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
-;; Free Software Foundation, Inc.
+
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
+;; 2005 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; MORIOKA Tomohiko <morioka@jaist.ac.jp>
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
;;; Commentary:
(eval-when-compile
(require 'cl)
(require 'static)
- (defvar tool-bar-map))
+ (defvar tool-bar-map)
+ (defvar w3m-minor-mode-map))
(require 'path-util)
(require 'gnus)
-(require 'gnus-sum)
+;; Avoid the "Recursive load suspected" error in Emacs 21.1.
+(eval-and-compile
+ (let ((recursive-load-depth-limit 100))
+ (require 'gnus-sum)))
(require 'gnus-spec)
(require 'gnus-int)
(require 'gnus-win)
(autoload 'gnus-msg-mail "gnus-msg" nil t)
(autoload 'gnus-button-mailto "gnus-msg")
(autoload 'gnus-button-reply "gnus-msg" nil t)
+(autoload 'parse-time-string "parse-time" nil nil)
+(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
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)
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."
- :type '(choice (integer :value 200)
+regexp. If it matches, the text in question is not a signature.
+
+This can also be a list of the above values."
+ :type '(choice (const nil)
+ (integer :value 200)
(number :value 4.0)
(function :value fun)
(regexp :value ".*"))
(gnus-image-type-available-p 'pbm))
'gnus-display-x-face-in-from
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | ee -"))
- ((and (fboundp 'image-type-available-p)
- (module-installed-p 'x-face-e21))
- 'x-face-decode-message-header)
((gnus-image-type-available-p 'pbm)
'gnus-display-x-face-in-from)
- ((and window-system
- (module-installed-p 'x-face-mule))
- 'x-face-mule-gnus-article-display-x-face)
(t
"{ echo '/* Width=48, Height=48 */'; uncompface; } | icontopbm | \
display -"))
If it is a string, the command will be executed in a sub-shell
asynchronously. The compressed face will be piped to this command."
:type `(choice
- ,@(let (x-face-e21 x-face-mule)
- (if (featurep 'xemacs)
- nil
- (setq x-face-e21 (module-installed-p 'x-face-e21)
- x-face-mule (module-installed-p 'x-face-mule)))
- (delq nil
- (list
- 'string
- (if (or (gnus-image-type-available-p 'xface)
- (gnus-image-type-available-p 'pbm))
- '(function-item gnus-display-x-face-in-from))
- (if (and x-face-e21
- (fboundp 'image-type-available-p))
- '(function-item
- :tag "x-face-decode-message-header (x-face-e21)"
- x-face-decode-message-header))
- (if x-face-mule
- '(function-item
- x-face-mule-gnus-article-display-x-face))
- 'function))))
- ;;:version "21.1"
+ :format "%{%t%}:\n%[Value Menu%] %v"
+ ,@(delq nil
+ (list
+ 'string
+ (if (or (gnus-image-type-available-p 'xface)
+ (gnus-image-type-available-p 'pbm))
+ '(function-item gnus-display-x-face-in-from))
+ 'function)))
+ :version "21.1"
:group 'gnus-picon
:group 'gnus-article-washing)
(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) (car (cdr 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))
+ '(;; I've never seen anyone use this strikethru convention whereas I've
+ ;; several times seen it triggered by normal text. --Stef
+ ;; Miles suggests that this form is sometimes used but for italics,
+ ;; so maybe we should map it to `italic'.
+ ;; ("\\(\\s-\\|^\\)\\(-\\(\\(\\w\\|-[^-]\\)+\\)-\\)\\(\\s-\\|[?!.,;]\\)"
+ ;; 2 3 gnus-emphasis-strikethru)
+ ("\\(\\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"
"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)
-(eval-and-compile
- (autoload 'mail-extract-address-components "mail-extr"))
-
(defcustom gnus-save-all-headers t
"*If non-nil, don't remove any headers before saving."
:group 'gnus-article-saving
'((\"^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)
+(defcustom gnus-copy-article-ignored-headers nil
+ "List of headers to be removed when copying an article.
+Each element is a regular expression."
+ :version "23.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.")
:type 'face
:group 'gnus-article-buttons)
-(defcustom gnus-signature-face 'gnus-signature-face
+(defcustom gnus-signature-face 'gnus-signature
"Face used for highlighting a signature in the article buffer.
-Obsolete; use the face `gnus-signature-face' for customizations instead."
+Obsolete; use the face `gnus-signature' for customizations instead."
:type 'face
:group 'gnus-article-highlight
:group 'gnus-article-signature)
-(defface gnus-signature-face
+(defface gnus-signature
'((t
(:italic t)))
"Face used for highlighting a signature in the article buffer."
:group 'gnus-article-highlight
:group 'gnus-article-signature)
+;; backward-compatibility alias
+(put 'gnus-signature-face 'face-alias 'gnus-signature)
-(defface gnus-header-from-face
+(defface gnus-header-from
'((((class color)
(background dark))
(:foreground "spring green"))
"Face used for displaying from headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-from-face 'face-alias 'gnus-header-from)
-(defface gnus-header-subject-face
+(defface gnus-header-subject
'((((class color)
(background dark))
(:foreground "SeaGreen3"))
"Face used for displaying subject headers."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-subject-face 'face-alias 'gnus-header-subject)
-(defface gnus-header-newsgroups-face
+(defface gnus-header-newsgroups
'((((class color)
(background dark))
(:foreground "yellow" :italic t))
articles."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups)
-(defface gnus-header-name-face
+(defface gnus-header-name
'((((class color)
(background dark))
(:foreground "SeaGreen"))
"Face used for displaying header names."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-name-face 'face-alias 'gnus-header-name)
-(defface gnus-header-content-face
+(defface gnus-header-content
'((((class color)
(background dark))
(:foreground "forest green" :italic t))
"Face used for displaying header content."
:group 'gnus-article-headers
:group 'gnus-article-highlight)
+;; backward-compatibility alias
+(put 'gnus-header-content-face 'face-alias 'gnus-header-content)
(defcustom gnus-header-face-alist
- '(("From" nil gnus-header-from-face)
- ("Subject" nil gnus-header-subject-face)
- ("Newsgroups:.*," nil gnus-header-newsgroups-face)
- ("" gnus-header-name-face gnus-header-content-face))
+ '(("From" nil gnus-header-from)
+ ("Subject" nil gnus-header-subject)
+ ("Newsgroups:.*," nil gnus-header-newsgroups)
+ ("" gnus-header-name gnus-header-content))
"*Controls highlighting of article headers.
An alist of the form (HEADER NAME CONTENT).
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")
This is meant for people who want to do something automatic based
on parts -- for instance, adding Vcard info to a database."
:group 'gnus-article-mime
- :type 'function)
+ :type '(choice (const nil)
+ function))
(defcustom gnus-mime-multipart-functions nil
"An alist of MIME types to functions to display them."
:version "21.1"
:group 'gnus-article-mime
- :type 'alist)
+ :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.
(defcustom gnus-mime-action-alist
'(("save to file" . gnus-mime-save-part)
("save and strip" . gnus-mime-save-part-and-strip)
+ ("replace with file" . gnus-mime-replace-part)
("delete part" . gnus-mime-delete-part)
("display as text" . gnus-mime-inline-part)
("view the part" . gnus-mime-view-part)
:type '(repeat (cons (string :tag "name")
(function))))
+(defcustom gnus-auto-select-part 1
+ "Advance to next MIME part when deleting or stripping parts.
+
+When 0, point will be placed on the same part as before. When
+positive (negative), move point forward (backwards) this many
+parts. When nil, redisplay article."
+ :version "23.0" ;; No Gnus
+ :group 'gnus-article-mime
+ :type '(choice (const nil :tag "Redisplay article.")
+ (const 1 :tag "Next part.")
+ (const 0 :tag "Current part.")
+ integer))
+
;;;
;;; The treatment variables
;;;
(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)
"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-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 (memq gnus-article-x-face-command
- '(x-face-decode-message-header
- x-face-mule-gnus-article-display-x-face))
- (and (fboundp 'image-type-available-p)
+ (or (and (fboundp 'image-type-available-p)
(image-type-available-p 'xbm)
(string-match "^0x" (shell-command-to-string "uncompface"))
(executable-find "icontopbm"))
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)X-Face' for details."
:group 'gnus-article-treat
- ;;:version "21.1"
+ :version "21.1"
:link '(custom-manual "(gnus)Customizing Articles")
:link '(custom-manual "(gnus)X-Face")
:type gnus-article-treat-head-custom
(not (or (featurep 'xemacs)
(gnus-image-type-available-p 'xpm)
(gnus-image-type-available-p 'pbm)))
- "If non-nil, gnus uses `smiley-mule' for displaying smileys rather than
-`smiley'. It defaults to t when Emacs 20 or earlier is running.
+ "Non-nil means use `smiley-mule' to show smileys rather than `smiley'.
`smiley-mule' is boundled in BITMAP-MULE package. You can set it to t
-even if you are using Emacs 21+. It has no effect on XEmacs."
+even if your Emacs supports images. It has no effect on XEmacs."
:group 'gnus-article-various
:type 'boolean
:get (lambda (symbol)
(defcustom gnus-treat-display-face
(and (not noninteractive)
- ;; x-face-e21 handles both X-Face and Face headers.
- (not (and (eq gnus-article-x-face-command 'x-face-decode-message-header)
- (module-installed-p 'x-face-e21)))
(or (and (fboundp 'image-type-available-p)
(image-type-available-p 'png))
(and (featurep 'xemacs)
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)
See Info node `(gnus)Customizing Articles' and Info node
`(gnus)Smileys' for details."
:group 'gnus-article-treat
- ;;:version "21.1"
+ :version "21.1"
:link '(custom-manual "(gnus)Customizing Articles")
:link '(custom-manual "(gnus)Smileys")
:type gnus-article-treat-custom)
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 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-head-custom)
"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
:type gnus-article-treat-custom)
(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)
(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)
'("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-ut gnus-article-date-ut)
(gnus-treat-date-local gnus-article-date-local)
(gnus-treat-date-english gnus-article-date-english)
- (gnus-treat-date-lapsed gnus-article-date-lapsed)
(gnus-treat-date-original gnus-article-date-original)
(gnus-treat-date-user-defined gnus-article-date-user)
(gnus-treat-date-iso8601 gnus-article-date-iso8601)
+ (gnus-treat-date-lapsed gnus-article-date-lapsed)
(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)
;; Displaying X-Face should be done after unfolding headers
(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)
(when (eq 1 (point-min))
(set-window-start (get-buffer-window (current-buffer)) 1)))
(unless gnus-inhibit-hiding
- (save-excursion
- (save-restriction
- (let ((inhibit-read-only t)
- (case-fold-search t)
- (max (1+ (length gnus-sorted-header-list)))
- (ignored (when (not gnus-visible-headers)
- (cond ((stringp gnus-ignored-headers)
- gnus-ignored-headers)
- ((listp gnus-ignored-headers)
- (mapconcat 'identity gnus-ignored-headers
- "\\|")))))
- (visible
- (cond ((stringp gnus-visible-headers)
- gnus-visible-headers)
- ((and gnus-visible-headers
- (listp gnus-visible-headers))
- (mapconcat 'identity gnus-visible-headers "\\|"))))
- (inhibit-point-motion-hooks t)
- beg)
+ (let ((inhibit-read-only t)
+ (case-fold-search t)
+ (max (1+ (length gnus-sorted-header-list)))
+ (inhibit-point-motion-hooks t)
+ (cur (current-buffer))
+ ignored visible beg)
+ (save-excursion
+ ;; `gnus-ignored-headers' and `gnus-visible-headers' may be
+ ;; group parameters, so we should go to the summary buffer.
+ (when (prog1
+ (condition-case nil
+ (progn (set-buffer gnus-summary-buffer) t)
+ (error nil))
+ (setq ignored (when (not gnus-visible-headers)
+ (cond ((stringp gnus-ignored-headers)
+ gnus-ignored-headers)
+ ((listp gnus-ignored-headers)
+ (mapconcat 'identity
+ gnus-ignored-headers
+ "\\|"))))
+ visible (cond ((stringp gnus-visible-headers)
+ gnus-visible-headers)
+ ((and gnus-visible-headers
+ (listp gnus-visible-headers))
+ (mapconcat 'identity
+ gnus-visible-headers
+ "\\|")))))
+ (set-buffer cur))
+ (save-restriction
;; First we narrow to just the headers.
(article-narrow-to-head)
;; Hide any "From " lines at the beginning of (mail) articles.
(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
- (gnus-point-at-bol)
+ (point-at-bol)
(progn
(end-of-line)
(if (re-search-forward "^[^ \t]" nil t)
(goto-char (point-min))
(when (re-search-forward (concat "^" header ":") nil t)
(gnus-article-hide-text-type
- (gnus-point-at-bol)
+ (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.
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))
start end previous)
(put-text-property
(point) end 'face 'underline)))))))))
+(defun article-treat-ansi-sequences ()
+ "Translate ANSI SGR control sequences into overlays or extents."
+ (interactive)
+ (save-excursion
+ (when (article-goto-body)
+ (let ((inhibit-read-only t))
+ (ansi-color-apply-on-region (point) (point-max))))))
+
(defun gnus-article-treat-unfold-headers ()
"Unfold folded message headers.
Only the headers that fit into the current window width will be
"Toggle display of textual emoticons (\"smileys\") as small graphical icons."
(interactive)
(unless (featurep 'xemacs)
- (when (and (>= emacs-major-version 21)
- (not gnus-article-should-use-smiley-mule)
+ (when (and (not gnus-article-should-use-smiley-mule)
gnus-article-smiley-mule-loaded-p)
(load "smiley" nil t)
(setq gnus-article-smiley-mule-loaded-p nil))
"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)
(end-of-line)
(when (>= (current-column) (min fill-column width))
(narrow-to-region (min (1+ (point)) (point-max))
- (gnus-point-at-bol))
+ (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)
;; read-only.
(if (and wash-face-p (memq 'face gnus-article-wash-types))
(gnus-delete-images 'face)
- (let (face faces)
- (save-excursion
+ (let (face faces from)
+ (save-current-buffer
(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))
+ (gnus-buffer-live-p gnus-original-article-buffer)
+ (not (re-search-forward "^Face:[\t ]*" nil t)))
(set-buffer gnus-original-article-buffer))
(save-restriction
(mail-narrow-to-head)
(while (gnus-article-goto-header "Face")
(push (mail-header-field-value) faces))))
- (while (setq face (pop faces))
- (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 nil 'face))))))
- )))
+ (when faces
+ (goto-char (point-min))
+ (let ((from (gnus-article-goto-header "from"))
+ png image)
+ (unless from
+ (insert "From:")
+ (setq from (point))
+ (insert "[no `from' set]\n"))
+ (while faces
+ (when (setq png (gnus-convert-face-to-png (pop faces)))
+ (setq image
+ (apply 'gnus-create-image png 'png t
+ (cdr (assq 'png gnus-face-properties-alist))))
+ (goto-char from)
+ (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."
(gnus-delete-images 'xface)
;; Display X-Faces.
(let (x-faces from face)
- (save-excursion
+ (save-current-buffer
(when (and wash-face-p
- (progn
- (goto-char (point-min))
- (not (re-search-forward
- "^X-Face\\(-[0-9]+\\)?:[\t ]*" nil t)))
- (gnus-buffer-live-p gnus-original-article-buffer))
+ (gnus-buffer-live-p gnus-original-article-buffer)
+ (not (re-search-forward "^X-Face:[\t ]*" nil t)))
;; If type `W f', use gnus-original-article-buffer,
;; otherwise use the current buffer because displaying
;; RFC822 parts calls this function too.
;; single external face.
(when (stringp gnus-article-x-face-command)
(setq x-faces (list (car x-faces))))
- (while (and (setq face (pop x-faces))
- gnus-article-x-face-command
- (or force
- ;; Check whether this face is censored.
- (not gnus-article-x-face-too-ugly)
- (and gnus-article-x-face-too-ugly from
- (not (string-match gnus-article-x-face-too-ugly
- from)))))
- ;; We display the face.
- (cond ((stringp gnus-article-x-face-command)
- ;; The command is a string, so we interpret the command
- ;; as a, well, command, and fork it off.
- (let ((process-connection-type nil))
- (process-kill-without-query
- (start-process
- "article-x-face" nil shell-file-name
- shell-command-switch gnus-article-x-face-command))
- (with-temp-buffer
- (insert face)
- (process-send-region "article-x-face"
- (point-min) (point-max)))
- (process-send-eof "article-x-face")))
- ((functionp gnus-article-x-face-command)
- ;; The command is a lisp function, so we call it.
- (funcall gnus-article-x-face-command face))
- (t
- (error "%s is not a function"
- gnus-article-x-face-command)))))))))
+ (when (and x-faces
+ gnus-article-x-face-command
+ (or force
+ ;; Check whether this face is censored.
+ (not gnus-article-x-face-too-ugly)
+ (and from
+ (not (string-match gnus-article-x-face-too-ugly
+ from)))))
+ (while (setq face (pop x-faces))
+ ;; We display the face.
+ (cond ((stringp gnus-article-x-face-command)
+ ;; The command is a string, so we interpret the command
+ ;; as a, well, command, and fork it off.
+ (let ((process-connection-type nil))
+ (gnus-set-process-query-on-exit-flag
+ (start-process
+ "article-x-face" nil shell-file-name
+ shell-command-switch gnus-article-x-face-command)
+ nil)
+ (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
(defun article-decode-encoded-words ()
"Remove encoded-word encoding from headers."
- (let (buffer-read-only)
- (let ((charset (save-excursion
- (set-buffer gnus-summary-buffer)
- default-mime-charset)))
- (mime-decode-header-in-buffer charset))))
+ (let ((charset (save-excursion
+ (set-buffer gnus-summary-buffer)
+ default-mime-charset))
+ (inhibit-read-only t))
+ (mime-decode-header-in-buffer charset)))
(defun article-decode-group-name ()
"Decode group names in `Newsgroups:'."
(let ((inhibit-point-motion-hooks t)
- 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)
(autoload 'idna-to-unicode "idna")
(defun article-decode-idna-rhs ()
- "Decode IDNA strings in RHS in From:, To: and Cc: headers in current buffer."
+ "Decode IDNA strings in RHS in various headers in current buffer.
+The following headers are decoded: From:, To:, Cc:, Reply-To:,
+Mail-Reply-To: and Mail-Followup-To:."
(when gnus-use-idna
(save-restriction
(let ((inhibit-point-motion-hooks t)
- buffer-read-only)
+ (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)
+ (while (re-search-forward "@[^ \t\n\r,>]*\\(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")))
- (save-excursion (backward-char)
- (message-idna-inside-rhs-p))
+ (looking-at "From\\|To\\|Cc\\|Reply-To\\|Mail-Reply-To\\|Mail-Followup-To")))
(setq unicode (idna-to-unicode ace))))
(unless (string= ace unicode)
(replace-match unicode nil nil nil 1)))))))))
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 (interactive-p)
(gnus-treat-article nil))))
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
(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:"))
+ (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
(article-really-strip-banner
(gnus-parameter-banner gnus-newsgroup-name)))
(when gnus-article-address-banner-alist
- (article-really-strip-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)))))))))))))
+ ;; 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-restriction
(let ((inhibit-point-motion-hooks t)
(gnus-signature-limit nil)
- buffer-read-only)
+ (inhibit-read-only t))
(article-goto-body)
(cond
((eq banner 'signature)
"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)))
(article-goto-body))
(goto-char (point-min)))
(unless (gnus-article-check-hidden-text 'signature arg)
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(button (point)))
(while (setq button (text-property-any button (point-max)
'gnus-callback
(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)))))
(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
(forward-line 1)
(setq ended t)))))
-(defun article-date-ut (&optional type highlight header)
+(defun article-date-ut (&optional type highlight)
"Convert DATE date to universal time in the current article.
If TYPE is `local', convert to local time; if it is `lapsed', output
how much time has lapsed since DATE. For `lapsed', the value of
`gnus-article-date-lapsed-new-header' says whether the \"X-Sent:\" header
should replace the \"Date:\" one, or should be added below it."
(interactive (list 'ut t))
- (let* ((header (or header
- (and (eq 1 (point-min))
- (mail-header-date (save-excursion
- (set-buffer gnus-summary-buffer)
- gnus-current-headers)))
- (message-fetch-field "date")
- ""))
- (date (if (vectorp header) (mail-header-date header)
- header))
+ (let* ((tdate-regexp "^Date:[ \t]\\|^X-Sent:[ \t]")
+ (date-regexp (cond ((not gnus-article-date-lapsed-new-header)
+ tdate-regexp)
+ ((eq type 'lapsed)
+ "^X-Sent:[ \t]")
+ (article-lapsed-timer
+ "^Date:[ \t]")
+ (t
+ tdate-regexp)))
+ (case-fold-search t)
+ (inhibit-read-only t)
(inhibit-point-motion-hooks t)
- bface eface date-pos)
- (when (and date (not (string= date "")))
- (save-excursion
- (save-restriction
- (article-narrow-to-head)
- (when (or (and (eq type 'lapsed)
- gnus-article-date-lapsed-new-header
- ;; Attempt to get the face of X-Sent first.
- (re-search-forward "^X-Sent:[ \t]" nil t))
- (re-search-forward "^Date:[ \t]" nil t)
- ;; If Date is missing, try again for X-Sent.
- (re-search-forward "^X-Sent:[ \t]" nil t))
- (setq bface (get-text-property (gnus-point-at-bol) 'face)
- date (or (get-text-property (gnus-point-at-bol)
- 'original-date)
- date)
- eface (get-text-property (1- (gnus-point-at-eol))
- 'face)))
- (let ((buffer-read-only nil))
- ;; Delete any old X-Sent headers.
- (when (setq date-pos
- (text-property-any (point-min) (point-max)
- 'article-date-lapsed t))
- (goto-char (setq date-pos (set-marker (make-marker) date-pos)))
- (delete-region (match-beginning 0)
- (progn (forward-line 1) (point))))
- (goto-char (point-min))
- ;; Delete any old Date headers.
- (while (re-search-forward "^Date:[ \t]" nil t)
- (unless date-pos
- (setq date-pos (match-beginning 0)))
- (unless (and (eq type 'lapsed)
- gnus-article-date-lapsed-new-header)
- (delete-region (match-beginning 0)
- (progn (message-next-header) (point)))))
- (if date-pos
- (progn
- (goto-char date-pos)
- (unless (bolp)
- ;; Possibly, Date has been deleted.
- (insert "\n"))
- (when (and (eq type 'lapsed)
- gnus-article-date-lapsed-new-header
- (looking-at "Date:"))
- (forward-line 1)))
- (goto-char (point-min)))
- (insert (article-make-date-line date type))
- (when (eq type 'lapsed)
- (put-text-property (gnus-point-at-bol) (point)
- 'article-date-lapsed t))
+ pos date bface eface)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (goto-char (point-min))
+ (while (or (setq date (get-text-property (setq pos (point))
+ 'original-date))
+ (when (setq pos (next-single-property-change
+ (point) 'original-date))
+ (setq date (get-text-property pos 'original-date))
+ t))
+ (narrow-to-region pos (or (text-property-any pos (point-max)
+ 'original-date nil)
+ (point-max)))
+ (goto-char (point-min))
+ (when (re-search-forward tdate-regexp nil t)
+ (setq bface (get-text-property (point-at-bol) 'face)
+ eface (get-text-property (1- (point-at-eol)) 'face)))
+ (goto-char (point-min))
+ (setq pos nil)
+ ;; Delete any old Date headers.
+ (while (re-search-forward date-regexp nil t)
+ (if pos
+ (delete-region (point-at-bol) (progn
+ (gnus-article-forward-header)
+ (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))
+ (gnus-goto-char pos)
+ (insert (article-make-date-line date (or type 'ut)))
+ (unless pos
(insert "\n")
- (forward-line -1)
- ;; Do highlighting.
- (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'original-date date)
- (put-text-property (match-beginning 1) (1+ (match-end 1))
- 'face bface)
- (put-text-property (match-beginning 2) (match-end 2)
- 'face eface))))))))
+ (forward-line -1))
+ ;; Do highlighting.
+ (beginning-of-line)
+ (when (looking-at "\\([^:]+\\): *\\(.*\\)$")
+ (put-text-property (match-beginning 1) (1+ (match-end 1))
+ 'face bface)
+ (put-text-property (match-beginning 2) (match-end 2)
+ 'face eface))
+ (put-text-property (point-min) (1- (point-max)) 'original-date date)
+ (goto-char (point-max))
+ (widen))))))
(defun article-make-date-line (date type)
"Return a DATE line of TYPE."
(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)
(defun article-update-date-lapsed ()
"Function to be run from a timer to update the lapsed time line."
- (let (deactivate-mark)
- (save-excursion
- (ignore-errors
- (walk-windows
- (lambda (w)
- (set-buffer (window-buffer w))
- (when (eq major-mode 'gnus-article-mode)
- (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)))))
+ (save-match-data
+ (let (deactivate-mark)
+ (save-excursion
+ (ignore-errors
+ (walk-windows
+ (lambda (w)
+ (set-buffer (window-buffer w))
+ (when (or (and (eq major-mode 'mime-view-mode)
+ (eq (mime-preview-original-major-mode)
+ 'gnus-original-article-mode))
+ (eq major-mode 'gnus-article-mode))
+ (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)
"Start a timer to update the X-Sent header in the article buffers.
(setq n 1))
(gnus-stop-date-timer)
(setq article-lapsed-timer
- (nnheader-run-at-time 1 n 'article-update-date-lapsed)))
+ (run-at-time 1 n 'article-update-date-lapsed)))
(defun gnus-stop-date-timer ()
"Stop the X-Sent timer."
(interactive (list t))
(article-date-ut 'iso8601 highlight))
+(defmacro gnus-article-save-original-date (&rest forms)
+ "Save the original date as a text property and evaluate FORMS."
+ `(let* ((case-fold-search t)
+ (start (progn
+ (goto-char (point-min))
+ (when (and (re-search-forward "^date:[\t\n ]+" nil t)
+ (not (bolp)))
+ (match-end 0))))
+ (date (when (and start
+ (re-search-forward "[\t ]*\n\\(?:[^\t ]\\|\\'\\)"
+ nil t))
+ (buffer-substring-no-properties start
+ (match-beginning 0)))))
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (put-text-property (point-min) (point) 'original-date date)
+ ,@forms
+ (goto-char (point-max))
+ (skip-chars-backward "\n")
+ (put-text-property (point-min) (point) 'original-date date)))
+
;; (defun article-show-all ()
;; "Show all hidden text in the article buffer."
;; (interactive)
;; (save-excursion
;; (widen)
-;; (let ((buffer-read-only nil))
+;; (let ((inhibit-read-only t))
;; (gnus-article-unhide-text (point-min) (point-max))
;; (gnus-remove-text-with-property 'gnus-prev)
;; (gnus-remove-text-with-property 'gnus-next))))
(save-restriction
(widen)
(article-narrow-to-head)
- (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)
((null split-name)
(read-file-name
(concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
+ (file-name-nondirectory default-name) "): ")
(file-name-directory default-name)
default-name))
;; A single group name is returned.
(symbol-value variable)))
(read-file-name
(concat prompt " (default "
- (file-name-nondirectory default-name) ") ")
+ (file-name-nondirectory default-name) "): ")
(file-name-directory default-name)
default-name))
;; A single split name was found
((file-exists-p name) name)
(t gnus-article-save-directory))))
(read-file-name
- (concat prompt " (default " name ") ")
+ (concat prompt " (default " name "): ")
dir name)))
;; A list of splits was found.
(t
(setq result
(expand-file-name
(read-file-name
- (concat prompt " (`M-p' for defaults) ")
+ (concat prompt " (`M-p' for defaults): ")
gnus-article-save-directory
(car split-name))
gnus-article-save-directory)))
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s in rmail file:" filename
+ "Save %s in rmail file" filename
gnus-rmail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-rmail))
(gnus-eval-in-buffer-window gnus-save-article-buffer
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s in Unix mail file:" filename
+ "Save %s in Unix mail file" filename
gnus-mail-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-mail))
(gnus-eval-in-buffer-window gnus-save-article-buffer
Optional argument FILENAME specifies file name.
Directory to save to is default to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s in file:" filename
+ "Save %s in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
(gnus-eval-in-buffer-window gnus-save-article-buffer
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(setq filename (gnus-read-save-file-name
- "Save %s body in file:" filename
+ "Save %s body in file" filename
gnus-file-save-name gnus-newsgroup-name
gnus-current-headers 'gnus-newsgroup-last-file))
(gnus-eval-in-buffer-window gnus-save-article-buffer
(shell-command-on-region (point-min) (point-max) command nil)))
(setq gnus-last-shell-command command))
-(defmacro gnus-read-string (prompt &optional initial-contents history
- default-value)
- "Like `read-string' but allow for older XEmacsen that don't have the 5th arg."
- (if (and (featurep 'xemacs)
- (< emacs-minor-version 2))
- `(read-string ,prompt ,initial-contents ,history)
- `(read-string ,prompt ,initial-contents ,history ,default-value)))
-
(defun gnus-summary-pipe-to-muttprint (&optional command)
"Pipe this article to muttprint."
- (setq command (gnus-read-string
+ (setq command (read-string
"Print using command: " gnus-summary-muttprint-program
nil gnus-summary-muttprint-program))
(gnus-summary-save-in-pipe command))
(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)
(require 'navi2ch-mona)
(set-face-font (make-face 'gnus-mona-face) navi2ch-mona-font))
(save-excursion
- (let ((buffer-read-only nil))
+ (let ((inhibit-read-only t))
(article-goto-body)
(gnus-overlay-put
(gnus-make-overlay (point) (point-max))
article-monafy
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]
["Treat html" gnus-article-wash-html t]
\\[gnus-article-describe-briefly]\t Describe the current mode briefly
\\[gnus-info-find-node]\t Go to the Gnus info node"
(interactive)
+ (kill-all-local-variables)
(gnus-simplify-mode-line)
(setq mode-name "Article")
(setq major-mode 'gnus-article-mode)
(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 'nobreak-char-display) 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)
- (gnus-run-hooks 'gnus-article-mode-hook))
+ (gnus-run-mode-hooks 'gnus-article-mode-hook))
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(set-buffer-multibyte t)
(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)
(buffer-disable-undo)
(setq buffer-read-only t)
(defun gnus-article-display-traditional-message ()
"Article display method for traditional message."
(set-buffer gnus-article-buffer)
- (let (buffer-read-only)
+ (let ((inhibit-read-only t))
(erase-buffer)
(insert-buffer-substring gnus-original-article-buffer)))
(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.
(if (search-forward "\n\n" nil t)
(point)
(point-max)))
- (gnus-treat-article 'head)
+ (gnus-article-save-original-date (gnus-treat-article 'head))
(put-text-property (point-min) (point-max) 'article-treated-header t)
(goto-char (point-max)))
(while (and (not (eobp)) entity)
(defun gnus-article-prepare-display ()
"Make the current buffer look like a nice article."
(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
(if (search-forward "\n\n" nil t)
(point)
(point-max)))
- (gnus-treat-article 'head)
+ (gnus-article-save-original-date (gnus-treat-article 'head))
(put-text-property (point-min) (point-max) 'article-treated-header t)
(goto-char (point-max))
(widen)
(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-replace-part "r" "Replace part")
(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-internally "E" "View Internally") ;; Why `E'?
(gnus-mime-view-part-externally "e" "View Externally")
(gnus-mime-print-part "p" "Print")
(gnus-mime-pipe-part "|" "Pipe To Command...")
(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)
(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))))))
-(defun gnus-mime-save-part-and-strip ()
- "Save the MIME part under point then replace it with an external body."
+(defun gnus-article-jump-to-part (n)
+ "Jump to MIME part N."
+ (interactive "P")
+ (pop-to-buffer gnus-article-buffer)
+ ;; FIXME: why is it necessary?
+ (sit-for 0)
+ (let ((parts (length gnus-article-mime-handle-alist)))
+ (or n (setq n
+ (string-to-number
+ (read-string ;; Emacs 21 doesn't have `read-number'.
+ (format "Jump to part (2..%s): " parts)))))
+ (unless (and (integerp n) (<= n parts) (>= n 1))
+ (setq n
+ (progn
+ (gnus-message 7 "Invalid part `%s', using %s instead."
+ n parts)
+ parts)))
+ (gnus-message 9 "Jumping to part %s." n)
+ (cond ((>= gnus-auto-select-part 1)
+ (while (and (<= n parts)
+ (not (gnus-article-goto-part n)))
+ (setq n (1+ n))))
+ ((< gnus-auto-select-part 0)
+ (while (and (>= n 1)
+ (not (gnus-article-goto-part n)))
+ (setq n (1- n))))
+ (t
+ (gnus-article-goto-part n)))))
+
+(eval-when-compile
+ (defsubst gnus-article-edit-part (handles &optional current-id)
+ "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 ()
+ (buffer-disable-undo)
+ (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-substring 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))
+ t)
+ (gnus-article-edit-done)
+ (gnus-summary-expand-window)
+ (gnus-summary-show-article)
+ (when (and current-id (integerp gnus-auto-select-part))
+ (gnus-article-jump-to-part
+ (+ current-id gnus-auto-select-part)))))
+
+(defun gnus-mime-replace-part (file)
+ "Replace MIME part under point with an external body."
+ ;; Useful if file has already been saved to disk
+ (interactive
+ (list
+ (mm-with-multibyte
+ (read-file-name "Replace MIME part with file: "
+ (or mm-default-directory default-directory)
+ nil nil))))
+ (gnus-mime-save-part-and-strip file))
+
+(defun gnus-mime-save-part-and-strip (&optional file)
+ "Save the MIME part under point then replace it with an external body.
+If FILE is given, use it for the external 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..."))
(let* ((data (get-text-property (point) 'gnus-data))
- file param
+ (id (get-text-property (point) 'gnus-part))
+ 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)))
+ (unless file
+ (setq file
+ (and data (mm-save-part data "Delete MIME part and save to: "))))
(when file
(with-current-buffer (mm-handle-buffer data)
(erase-buffer)
`("message/external-body"
(access-type . "LOCAL-FILE")
(name . ,file)))))
- (set-buffer gnus-summary-buffer)
- (gnus-article-edit-article
- `(lambda ()
- (erase-buffer)
- (let ((mail-parse-charset (or gnus-article-charset
- ',gnus-newsgroup-charset))
- (mail-parse-ignored-charsets
- (or gnus-article-ignored-charsets
- ',gnus-newsgroup-ignored-charsets))
- (mbl mml-buffer-list))
- (setq mml-buffer-list nil)
- (insert-buffer gnus-original-article-buffer)
- (mime-to-mml ',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))))))
+ ;; (set-buffer gnus-summary-buffer)
+ (gnus-article-edit-part handles id))))
+
+;; A function like `gnus-summary-save-parts' (`X m', `<MIME> <Extract all
+;; parts...>') but with stripping would be nice.
(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)
- (unless (and gnus-novice-user
- (not (gnus-yes-or-no-p
- "Really delete attachment forever? ")))
+ (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 (or gnus-expert-user
+ (gnus-yes-or-no-p "\
+Deleting parts may malfunction or destroy the article; continue? "))
(let* ((data (get-text-property (point) 'gnus-data))
+ (id (get-text-property (point) 'gnus-part))
(handles gnus-article-mime-handles)
(none "(none)")
(description
(or (mail-content-type-get (mm-handle-disposition data) 'filename)
none))
(type (mm-handle-media-type data)))
- (if (mm-multiple-handles gnus-article-mime-handles)
- (error "This function is not implemented"))
+ (unless data
+ (error "No MIME part under point"))
(with-current-buffer (mm-handle-buffer data)
(let ((bsize (format "%s" (buffer-size))))
(erase-buffer)
nil `("text/plain") nil nil
(list "attachment")
(format "Deleted attachment (%s bytes)" bsize))))))
- (set-buffer gnus-summary-buffer)
- ;; FIXME: maybe some of the following code (borrowed from
- ;; `gnus-mime-save-part-and-strip') isn't necessary?
- (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)))))
- ;; Not in `gnus-mime-save-part-and-strip':
- (gnus-article-edit-done)
- (gnus-summary-expand-window)
- (gnus-summary-show-article))
+ ;; (set-buffer gnus-summary-buffer)
+ (gnus-article-edit-part handles id))))
(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 coding-system '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))
- buffer-read-only)
+ (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)
(if action-pair
(funcall (cdr action-pair)))))
-(defun gnus-article-part-wrapper (n function)
- (save-current-buffer
- (set-buffer gnus-article-buffer)
- (when (> n (length gnus-article-mime-handle-alist))
- (error "No such part"))
- (gnus-article-goto-part n)
- (let ((handle (cdr (assq n gnus-article-mime-handle-alist))))
- (funcall function handle))))
+(defun gnus-article-part-wrapper (n function &optional no-handle interactive)
+ "Call FUNCTION on MIME part N.
+Unless NO-HANDLE, call FUNCTION with N-th MIME handle as it's only argument.
+If INTERACTIVE, call FUNCTION interactivly."
+ (let (window frame)
+ ;; Check whether the article is displayed.
+ (unless (and (gnus-buffer-live-p gnus-article-buffer)
+ (setq window (get-buffer-window gnus-article-buffer t))
+ (frame-visible-p (setq frame (window-frame window))))
+ (error "No article is displayed"))
+ (with-current-buffer gnus-article-buffer
+ ;; Check whether the article displays the right contents.
+ (unless (with-current-buffer gnus-summary-buffer
+ (eq gnus-current-article (gnus-summary-article-number)))
+ (error "You should select the right article first"))
+ ;; Check whether the specified part exists.
+ (when (> n (length gnus-article-mime-handle-alist))
+ (error "No such part")))
+ (unless
+ (progn
+ ;; To select the window is needed so that the cursor
+ ;; might be visible on the MIME button.
+ (select-window (prog1
+ window
+ (setq window (selected-window))
+ ;; Article may be displayed in the other frame.
+ (gnus-select-frame-set-input-focus
+ (prog1
+ frame
+ (setq frame (selected-frame))))))
+ (when (gnus-article-goto-part n)
+ ;; We point the cursor and the arrow at the MIME button
+ ;; when the `function' prompt the user for something.
+ (let ((cursor-in-non-selected-windows t)
+ (overlay-arrow-string "=>")
+ (overlay-arrow-position (point-marker)))
+ (unwind-protect
+ (cond
+ ((and no-handle interactive)
+ (call-interactively function))
+ (no-handle
+ (funcall function))
+ (interactive
+ (call-interactively
+ function
+ (cdr (assq n gnus-article-mime-handle-alist))))
+ (t
+ (funcall function
+ (cdr (assq n gnus-article-mime-handle-alist)))))
+ (set-marker overlay-arrow-position nil)
+ (unless gnus-auto-select-part
+ (gnus-select-frame-set-input-focus frame)
+ (select-window window))))
+ t))
+ (if gnus-inhibit-mime-unbuttonizing
+ ;; This is the default though the program shouldn't reach here.
+ (error "No such part")
+ ;; The part which doesn't have the MIME button is selected.
+ ;; So, we display all the buttons and redo it.
+ (let ((gnus-inhibit-mime-unbuttonizing t))
+ (gnus-summary-show-article)
+ (gnus-article-part-wrapper n function no-handle))))))
(defun gnus-article-pipe-part (n)
"Pipe MIME part N, which is the numerical prefix."
(interactive "p")
(gnus-article-part-wrapper n 'gnus-mime-inline-part))
+(defun gnus-article-save-part-and-strip (n)
+ "Save MIME part N and replace it with an external body.
+N is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-save-part-and-strip t))
+
+(defun gnus-article-replace-part (n)
+ "Replace MIME part N with an external body.
+N is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-replace-part t t))
+
+(defun gnus-article-delete-part (n)
+ "Delete MIME part N and add some information about the removed part.
+N is the numerical prefix."
+ (interactive "p")
+ (gnus-article-part-wrapper n 'gnus-mime-delete-part t))
+
(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
(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))
+ `(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))
;; 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)
+ (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.
(save-restriction
(article-goto-body)
(narrow-to-region (point-min) (point))
- (gnus-treat-article 'head))))))))
+ (gnus-article-save-original-date
+ (gnus-treat-article 'head)))))))))
(defcustom gnus-mime-display-multipart-as-mixed nil
"Display \"multipart\" parts as \"multipart/mixed\".
(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)
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
+ ;; Maybe a broken MIME message.
+ ((null handle))
;; Single part.
((not (stringp (car handle)))
(gnus-mime-display-single handle))
(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-insert-inline
+ handle
+ (let ((charset (mail-content-type-get (mm-handle-type handle)
+ 'charset)))
+ (cond ((not charset)
+ (mm-string-as-multibyte (mm-get-part handle)))
+ ((eq charset 'gnus-decoded)
+ (with-current-buffer (mm-handle-buffer handle)
+ (buffer-string)))
+ (t
+ (mm-decode-string (mm-get-part handle) charset)))))
(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))
"Hide unwanted headers if `gnus-have-all-headers' is nil.
Provided for backwards compatibility."
(when (and (or (not (gnus-buffer-live-p gnus-summary-buffer))
- (not (save-excursion (set-buffer gnus-summary-buffer)
- gnus-have-all-headers)))
+ (not (with-current-buffer gnus-summary-buffer
+ gnus-have-all-headers)))
(not gnus-inhibit-hiding))
(gnus-article-hide-headers)))
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (let ((file-name-coding-system nnmail-pathname-coding-system)
- (pathname-coding-system nnmail-pathname-coding-system))
+ (let ((file-name-coding-system nnmail-pathname-coding-system))
(write-region-as-binary (point-min) (point-max) file-name 'append))
t)))
(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)))
(if
(match-beginning 0)
(point)))
(when (and (gnus-visual-p 'page-marker)
- (not (= (point-min) 1)))
+ (> (point-min) (save-restriction (widen) (point-min))))
(save-excursion
(goto-char (point-min))
(gnus-insert-prev-page-button)))
(when (and (gnus-visual-p 'page-marker)
- (< (+ (point-max) 2) (buffer-size)))
+ (< (point-max) (save-restriction (widen) (point-max))))
(save-excursion
(goto-char (point-max))
(gnus-insert-next-page-button))))))
(save-excursion
(save-restriction
(widen)
+ (forward-line)
(eobp)))) ;Real end-of-buffer?
(progn
(when gnus-article-over-scroll
(gnus-article-next-page-1 lines)
nil))
+(defmacro gnus-article-beginning-of-window ()
+ "Move point to the beginning of the window.
+In Emacs, the point is placed at the line number which `scroll-margin'
+specifies."
+ (if (featurep 'xemacs)
+ '(move-to-window-line 0)
+ '(move-to-window-line
+ (min (max 0 scroll-margin)
+ (max 1 (- (window-height)
+ (if mode-line-format 1 0)
+ (if header-line-format 1 0)))))))
+
(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))
+ (when (and (not (featurep 'xemacs))
+ (numberp lines)
+ (> lines 0)
+ (numberp (symbol-value 'scroll-margin))
+ (> (symbol-value 'scroll-margin) 0))
+ ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for
+ ;; too many number of lines if `scroll-margin' is set as two or greater.
+ (setq lines (min lines
+ (max 0 (- (count-lines (window-start) (point-max))
+ (symbol-value 'scroll-margin))))))
+ (condition-case ()
+ (let ((scroll-in-place nil))
+ (scroll-up lines))
+ (end-of-buffer
+ ;; Long lines may cause an end-of-buffer error.
+ (goto-char (point-max))))
+ (gnus-article-beginning-of-window))
(defun gnus-article-prev-page (&optional lines)
"Show previous page of current article.
(gnus-narrow-to-page -1) ;Go to previous page.
(goto-char (point-max))
(recenter -1))
- (let ((scroll-in-place nil))
- (prog1
- (condition-case ()
- (scroll-down lines)
- (beginning-of-buffer
- (goto-char (point-min))))
- (move-to-window-line 0)))))
+ (prog1
+ (condition-case ()
+ (let ((scroll-in-place nil))
+ (scroll-down lines))
+ (beginning-of-buffer
+ (goto-char (point-min))))
+ (gnus-article-beginning-of-window))))
(defun gnus-article-only-boring-p ()
"Decide whether there is only boring text remaining in the article.
"Read article specified by message-id around point."
(interactive)
(save-excursion
- (re-search-backward "[ \t]\\|^" (gnus-point-at-bol) t)
- (re-search-forward "<?news:<?\\|<" (gnus-point-at-eol) t)
- (if (re-search-forward "[^@ ]+@[^ \t>]+" (gnus-point-at-eol) t)
+ (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 msg-id))
(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)
(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.
,(or (mail-header-references gnus-current-headers) "")
,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight))))
-(defun gnus-article-edit-article (start-func exit-func)
+(defun gnus-article-edit-article (start-func exit-func &optional quiet)
"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)
(setq gnus-prev-winconf winconf)
(when gnus-article-edit-article-setup-function
(funcall gnus-article-edit-article-setup-function))
- (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit")))
+ (unless quiet
+ (gnus-message 6 "C-c C-c to end edits; C-c C-k to exit"))))
(defun gnus-article-edit-done (&optional arg)
"Update the article edits and exit."
(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)
(defcustom gnus-button-valid-fqdn-regexp
message-valid-fqdn-regexp
"Regular expression that matches a valid FQDN."
+ :version "22.1"
+ :group 'gnus-article-buttons
+ :type 'regexp)
+
+;; Regexp suggested by Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
+(defcustom gnus-button-valid-localpart-regexp
+ "[a-z0-9$%(*-=?[_][^<>\")!;:,{}\n\t ]*"
+ "Regular expression that matches a localpart of mail addresses or MIDs."
+ :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
- "\\("; Cannot use `\(?: ... \)' (compatibility with Emacs 20).
- "biblio\\|digests\\|dviware\\|fonts\\|graphics\\|help\\|"
- "indexing\\|info\\|language\\|macros\\|support\\|systems\\|"
- "tds\\|tools\\|usergrps\\|web\\|nonfree\\|obsolete"
- "\\)")
+ (regexp-opt
+ (list "archive-tools" "biblio" "bibliography" "digests" "documentation"
+ "dviware" "fonts" "graphics" "help" "indexing" "info" "language"
+ "languages" "macros" "nonfree" "obsolete" "support" "systems"
+ "tds" "tools" "usergrps" "web") t)
"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 ]*@"
- ;; Felix Wiemann in <87oeuomcz9.fsf@news2.ososo.de>
+ (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@"
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)
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 (function-item :tag "Heuristic function"
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 '(repeat (cons (number :tag "Rate")
(regexp :tag "Regexp"))))
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)
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)
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)
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)
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 (>= gnus-button-message-level 0) gnus-button-handle-news 3)
- ("\\b\\(nntp\\|news\\):\\([^>\n\t ]*@[^>)!;:,\n\t ]*\\)" 0 t
- gnus-button-handle-news 2)
+ ((concat "\\b\\(nntp\\|news\\):\\("
+ gnus-button-valid-localpart-regexp "@[a-z0-9.-]+[a-z]\\)")
+ 0 t gnus-button-handle-news 2)
("\\(\\b<\\(url:[>\n\t ]*\\)?\\(nntp\\|news\\):[>\n\t ]*\\(//\\)?\\([^>\n\t ]*\\)>\\)"
1 (>= gnus-button-message-level 0) gnus-button-fetch-group 5)
("\\b\\(nntp\\|news\\):\\(//\\)?\\([^'\">\n\t ]+\\)"
("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
;; RFC 2368 (The mailto URL scheme)
- ("mailto:\\([-a-z.@_+0-9%=?&]+\\)"
+ ("\\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)
("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\\)\\>"
+ ;; 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)
(gnus-button-url-regexp
0 (>= gnus-button-browse-level 0) browse-url 0)
;; man pages
- ("\\b\\([a-z][a-z]+\\)([1-9])\\W"
+ ("\\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"
+ ("\\b\\([a-z][-_.a-z0-9]+([1-9])\\)\\W"
0 (and (>= gnus-button-man-level 3) (< gnus-button-man-level 5))
gnus-button-handle-man 1)
;; even more: Apache::PerlRun(3pm), PDL::IO::FastRaw(3pm),
;; SoWWWAnchor(3iv), XSelectInput(3X11), X(1), X(7)
- ("\\b\\([a-z][-+_.:a-z0-9]+\\)([1-9][X1a-z]*)\\W\\|\\b\\(X\\)([1-9])\\W"
+ ("\\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
("^\\(From\\|Reply-To\\):" ": *\\(.+\\)$"
1 (>= gnus-button-message-level 0) gnus-button-reply 1)
("^\\(Cc\\|To\\):" "[^ \t\n<>,()\"]+@[^ \t\n<>,()\"]+"
- 0 (>= gnus-button-message-level 0) gnus-button-mailto 0)
+ 0 (>= gnus-button-message-level 0) gnus-msg-mail 0)
("^X-[Uu][Rr][Ll]:" gnus-button-url-regexp
0 (>= gnus-button-browse-level 0) browse-url 0)
("^Subject:" gnus-button-url-regexp
0 (>= gnus-button-browse-level 0) browse-url 0)
("^[^:]+:" gnus-button-url-regexp
0 (>= gnus-button-browse-level 0) browse-url 0)
- ("^[^:]+:" "\\bmailto:\\([-a-z.@_+0-9%=?&]+\\)"
+ ("^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))
: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'."
+`gnus-signature-separator' using the face `gnus-signature'."
(interactive)
(when gnus-signature-face
- (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 (gnus-article-narrow-to-signature)
(gnus-overlay-put (gnus-make-overlay (point-min) (point-max))
(interactive)
(save-excursion
(set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
+ (let ((inhibit-read-only t)
(inhibit-point-motion-hooks t))
(when (gnus-article-search-signature)
(gnus-article-add-button (match-beginning 0) (match-end 0)
\"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:
(list 'gnus-callback fun)
(and data (list 'gnus-data data))))
(widget-convert-button 'link from to :action 'gnus-widget-press-button
- ;; Quote `:button-keymap' for Mule 2.3
- ;; but it won't work.
- ':button-keymap gnus-widget-button-keymap))
+ :button-keymap gnus-widget-button-keymap))
;;; Internal functions:
(defun gnus-article-set-globals ()
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
(gnus-set-global-variables)))
(defun gnus-signature-toggle (end)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (let ((buffer-read-only nil)
- (inhibit-point-motion-hooks t)
+ (gnus-with-article-buffer
+ (let ((inhibit-point-motion-hooks t)
(limit (next-single-property-change end 'mime-view-entity
nil (point-max))))
(if (text-property-any end limit 'article-type 'signature)
(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))))
(cons fun args)))))))
(defun gnus-parse-news-url (url)
- (let (scheme server group message-id articles)
+ (let (scheme server port group message-id articles)
(with-temp-buffer
(insert url)
(goto-char (point-min))
(when (looking-at "\\([A-Za-z]+\\):")
(setq scheme (match-string 1))
(goto-char (match-end 0)))
- (when (looking-at "//\\([^/]+\\)/")
+ (when (looking-at "//\\([^:/]+\\)\\(:?\\)\\([0-9]+\\)?/")
(setq server (match-string 1))
+ (setq port (if (stringp (match-string 3))
+ (string-to-number (match-string 3))
+ (match-string 3)))
(goto-char (match-end 0)))
(cond
(setq group (match-string 1)))
(t
(error "Unknown news URL syntax"))))
- (list scheme server group message-id articles)))
+ (list scheme server port group message-id articles)))
(defun gnus-button-handle-news (url)
"Fetch a news URL."
- (destructuring-bind (scheme server group message-id articles)
+ (destructuring-bind (scheme server port group message-id articles)
(gnus-parse-news-url url)
(cond
(message-id
(save-excursion
(set-buffer gnus-summary-buffer)
(if server
- (let ((gnus-refer-article-method (list (list 'nntp server))))
+ (let ((gnus-refer-article-method
+ (nconc (list (list 'nntp server))
+ gnus-refer-article-method))
+ (nntp-port-number (or port "nntp")))
+ (gnus-message 7 "Fetching %s with %s"
+ message-id gnus-refer-article-method)
(gnus-summary-refer-article message-id))
(gnus-summary-refer-article message-id))))
(group
(defun gnus-button-handle-man (url)
"Fetch a man page."
+ (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
+ (when (eq gnus-button-man-handler 'woman)
+ (setq url (gnus-replace-in-string url "([1-9][X1a-z]*).*\\'" "")))
+ (gnus-message 9 "`%s' `%s'" gnus-button-man-handler url)
(funcall gnus-button-man-handler url))
(defun gnus-button-handle-info-url (url)
(if (string-match "\\([^#]+\\)#?\\(.*\\)" url)
(gnus-info-find-node
(concat "("
- (gnus-url-unhex-string
+ (gnus-url-unhex-string
(match-string 1 url))
")"
- (or (gnus-url-unhex-string
+ (or (gnus-url-unhex-string
(match-string 2 url))
"Top")))
(error "Can't parse %s" url)))
(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)
(match-string 3 address)
"nntp")))
nil nil nil
- (and (match-end 6) (list (string-to-int (match-string 6 address))))))))
+ (and (match-end 6) (list (string-to-number (match-string 6 address))))))))
(defun gnus-url-parse-query-string (query &optional downcase)
(let (retval pairs cur key val)
(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)
(situation (get-text-property (point-min) 'mime-view-situation)))
(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
:action 'gnus-button-prev-page
:button-keymap gnus-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)
(situation (get-text-property (point-min) 'mime-view-situation)))
(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
"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
+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.
current-prefix-arg))
(let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist))))
(unless func
- (error (format "Can't find the encrypt protocol %s" protocol)))
+ (error "Can't find the encrypt protocol %s" protocol))
(if (member gnus-newsgroup-name '("nndraft:delayed"
"nndraft:drafts"
"nndraft:queue"))
(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
(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
(narrow-to-region (point) (point))
(unless (gnus-unbuttonized-mime-type-p (car handle))
(gnus-insert-mime-security-button handle))
- (gnus-mime-display-mixed (cdr handle))
+ (gnus-mime-display-part (cadr handle))
(unless (bolp)
(insert "\n"))
(unless (gnus-unbuttonized-mime-type-p (car handle))