;;; gnus-art.el --- article mode commands for Gnus
;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; Keywords: news
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
:type '(choice (const nil)
(integer :value 200)
(number :value 4.0)
- (function :value fun)
+ function
(regexp :value ".*"))
:group 'gnus-article-signature)
display -"))
"*String or function to be executed to display an X-Face header.
If it is a string, the command will be executed in a sub-shell
-asynchronously. The compressed face will be piped to this command."
+asynchronously. The compressed face will be piped to this command."
:type `(choice string
(function-item gnus-display-x-face-in-from)
function)
:group 'gnus-article-washing)
(defcustom gnus-save-all-headers t
- "*If non-nil, don't remove any headers before saving."
+ "*If non-nil, don't remove any headers before saving.
+This will be overridden by the `:headers' property that the symbol of
+the saver function, which is specified by `gnus-default-article-saver',
+might have."
:group 'gnus-article-saving
:type 'boolean)
"Headers to keep if `gnus-save-all-headers' is nil.
If `gnus-save-all-headers' is non-nil, this variable will be ignored.
If that variable is nil, however, all headers that match this regexp
-will be kept while the rest will be deleted before saving."
+will be kept while the rest will be deleted before saving. This and
+`gnus-save-all-headers' will be overridden by the `:headers' property
+that the symbol of the saver function, which is specified by
+`gnus-default-article-saver', might have."
:group 'gnus-article-saving
:type 'regexp)
(defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail
"A function to save articles in your favourite format.
-The function must be interactively callable (in other words, it must
-be an Emacs command).
+The function will be called by way of the `gnus-summary-save-article'
+command, and friends such as `gnus-summary-save-article-rmail'.
Gnus provides the following functions:
* gnus-summary-save-in-file (article format)
* gnus-summary-save-body-in-file (article body)
* gnus-summary-save-in-vm (use VM's folder format)
-* gnus-summary-write-to-file (article format -- overwrite)."
+* gnus-summary-write-to-file (article format -- overwrite)
+* gnus-summary-write-body-to-file (article body -- overwrite)
+
+The symbol of each function may have the following properties:
+
+* :decode
+The value non-nil means save decoded articles. This is meaningful
+only with `gnus-summary-save-in-file', `gnus-summary-save-body-in-file',
+`gnus-summary-write-to-file', and `gnus-summary-write-body-to-file'.
+
+* :function
+The value specifies an alternative function which appends, not
+overwrites, articles to a file. This implies that when saving many
+articles at a time, `gnus-prompt-before-saving' is bound to t and all
+articles are saved in a single file. This is meaningful only with
+`gnus-summary-write-to-file' and `gnus-summary-write-body-to-file'.
+
+* :headers
+The value specifies the symbol of a variable of which the value
+specifies headers to be saved. If it is omitted,
+`gnus-save-all-headers' and `gnus-saved-headers' control what
+headers should be saved."
:group 'gnus-article-saving
:type '(radio (function-item gnus-summary-save-in-rmail)
(function-item gnus-summary-save-in-mail)
(function-item gnus-summary-save-body-in-file)
(function-item gnus-summary-save-in-vm)
(function-item gnus-summary-write-to-file)
+ (function-item gnus-summary-write-body-to-file)
(function)))
+(defcustom gnus-article-save-coding-system
+ (or (and (mm-coding-system-p 'utf-8) 'utf-8)
+ (and (mm-coding-system-p 'iso-2022-7bit) 'iso-2022-7bit)
+ (and (mm-coding-system-p 'emacs-mule) 'emacs-mule)
+ (and (mm-coding-system-p 'escape-quoted) 'escape-quoted))
+ "Coding system used to save decoded articles to a file.
+
+The recommended coding systems are `utf-8', `iso-2022-7bit' and so on,
+which can safely encode any characters in text. This is used by the
+commands including:
+
+* gnus-summary-save-article-file
+* gnus-summary-save-article-body-file
+* gnus-summary-write-article-file
+* gnus-summary-write-article-body-file
+
+and the functions to which you may set `gnus-default-article-saver':
+
+* gnus-summary-save-in-file
+* gnus-summary-save-body-in-file
+* gnus-summary-write-to-file
+* gnus-summary-write-body-to-file
+
+Those commands and functions save just text displayed in the article
+buffer to a file if the value of this variable is non-nil. Note that
+buttonized MIME parts will be lost in a saved file in that case.
+Otherwise, raw articles will be saved."
+ :group 'gnus-article-saving
+ :type `(choice
+ :format "%{%t%}:\n %[Value Menu%] %v"
+ (const :tag "Save raw articles" nil)
+ ,@(delq nil
+ (mapcar
+ (lambda (arg) (if (mm-coding-system-p (nth 3 arg)) arg))
+ '((const :tag "UTF-8" utf-8)
+ (const :tag "iso-2022-7bit" iso-2022-7bit)
+ (const :tag "Emacs internal" emacs-mule)
+ (const :tag "escape-quoted" escape-quoted))))
+ (symbol :tag "Coding system")))
+
(defcustom gnus-rmail-save-name 'gnus-plain-save-name
"A function generating a file name to save articles in Rmail format.
The function is called with NEWSGROUP, HEADERS, and optional LAST-FILE."
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))
(defface gnus-header-from
'((((class color)
(background dark))
- (:foreground "spring green"))
+ (:foreground "PaleGreen1"))
(((class color)
(background light))
(:foreground "red3"))
(defface gnus-header-subject
'((((class color)
(background dark))
- (:foreground "SeaGreen3"))
+ (:foreground "SeaGreen1"))
(((class color)
(background light))
(:foreground "red4"))
(defface gnus-header-name
'((((class color)
(background dark))
- (:foreground "SeaGreen"))
+ (:foreground "SpringGreen2"))
(((class color)
(background light))
(:foreground "maroon"))
(defface gnus-header-content
'((((class color)
(background dark))
- (:foreground "forest green" :italic t))
+ (:foreground "SpringGreen1" :italic t))
(((class color)
(background light))
(:foreground "indianred4" :italic t))
(defvar gnus-decode-header-function 'mail-decode-encoded-word-region
"Function used to decode headers.")
+(defvar gnus-decode-address-function 'mail-decode-encoded-address-region
+ "Function used to decode addresses.")
+
(defvar gnus-article-dumbquotes-map
'(("\200" "EUR")
("\202" ",")
:group 'gnus-article-mime
:type '(repeat regexp))
-(defcustom gnus-buttonized-mime-types (unless (eq mm-verify-option 'never)
- '("multipart/signed"))
+(defcustom gnus-buttonized-mime-types nil
"List of MIME types that should be given buttons when rendered inline.
If set, this variable overrides `gnus-unbuttonized-mime-types'.
To see e.g. security buttons you could set this to
:link '(custom-manual "(gnus)Customizing Articles")
:type gnus-article-treat-custom)
+(defcustom gnus-article-unfold-long-headers nil
+ "If non-nil, allow unfolding headers even if the header is long.
+If it is a regexp, only long headers matching this regexp are unfolded.
+If it is t, all long headers are unfolded.
+
+This variable has no effect if `gnus-treat-unfold-headers' is nil."
+ :version "23.0" ;; No Gnus
+ :group 'gnus-article-treat
+ :type '(choice (const nil)
+ (const :tag "all" t)
+ (regexp)))
+
(defcustom gnus-treat-fold-headers nil
"Fold headers.
Valid values are nil, t, `head', `first', `last', an integer or a
(defcustom gnus-treat-display-x-face
(and (not noninteractive)
- (or (and (fboundp 'image-type-available-p)
- (image-type-available-p 'xbm)
- (string-match "^0x" (shell-command-to-string "uncompface"))
- (executable-find "icontopbm"))
- (and (featurep 'xemacs)
- (featurep 'xface)))
+ (gnus-image-type-available-p 'xbm)
+ (if (featurep 'xemacs)
+ (featurep 'xface)
+ (and (string-match "^0x" (shell-command-to-string "uncompface"))
+ (executable-find "icontopbm")))
'head)
"Display X-Face headers.
-Valid values are nil, t, `head', `first', `last', an integer or a
-predicate. See Info node `(gnus)Customizing Articles' and Info
-node `(gnus)X-Face' for details."
+Valid values are nil and `head'.
+See Info node `(gnus)Customizing Articles' and Info node
+`(gnus)X-Face' for details."
:group 'gnus-article-treat
:version "21.1"
:link '(custom-manual "(gnus)Customizing Articles")
(defcustom gnus-treat-display-face
(and (not noninteractive)
- (or (and (fboundp 'image-type-available-p)
- (image-type-available-p 'png))
- (and (featurep 'xemacs)
- (featurep 'png)))
+ (gnus-image-type-available-p 'png)
'head)
"Display Face headers.
Valid values are nil, t, `head', `first', `last', an integer or a
:type gnus-article-treat-head-custom)
(put 'gnus-treat-display-face 'highlight t)
-(defcustom gnus-treat-display-smileys
- (if (or (and (featurep 'xemacs)
- (featurep 'xpm))
- (and (fboundp 'image-type-available-p)
- (image-type-available-p 'pbm)))
- t nil)
+(defcustom gnus-treat-display-smileys (gnus-image-type-available-p 'xpm)
"Display smileys.
Valid values are nil, t, `head', `first', `last', an integer or a
predicate. See Info node `(gnus)Customizing Articles' and Info
'("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)
(interactive)
;; This function might be inhibited.
(unless gnus-inhibit-hiding
- (let ((inhibit-read-only nil)
+ (let ((inhibit-read-only t)
(case-fold-search t)
(max (1+ (length gnus-sorted-header-list)))
(inhibit-point-motion-hooks t)
'string<))))
(gnus-article-hide-header "reply-to")))))
((eq elem 'date)
- (let ((date (message-fetch-field "date")))
+ (let ((date (with-current-buffer gnus-original-article-buffer
+ ;; If date in `gnus-article-buffer' is localized
+ ;; (`gnus-treat-date-user-defined'),
+ ;; `days-between' might fail.
+ (message-fetch-field "date"))))
(when (and date
(< (days-between (current-time-string) date)
4))
(while (not (eobp))
(save-restriction
(mail-header-narrow-to-field)
- (let ((header (buffer-string)))
+ (let* ((header (buffer-string))
+ (unfoldable
+ (or (equal gnus-article-unfold-long-headers t)
+ (and (stringp gnus-article-unfold-long-headers)
+ (string-match gnus-article-unfold-long-headers header)))))
(with-temp-buffer
(insert header)
(goto-char (point-min))
(while (re-search-forward "\n[\t ]" nil t)
(replace-match " " t t)))
- (setq length (- (point-max) (point-min) 1)))
- (when (< length (window-width))
- (while (re-search-forward "\n[\t ]" nil t)
- (replace-match " " t t)))
+ (setq length (- (point-max) (point-min) 1))
+ (when (or unfoldable
+ (< length (window-width)))
+ (while (re-search-forward "\n[\t ]" nil t)
+ (replace-match " " t t))))
(goto-char (point-max)))))))
(defun gnus-article-treat-fold-headers ()
(mail-header-fold-field)
(goto-char (point-max))))))
+(defcustom gnus-article-truncate-lines default-truncate-lines
+ "Value of `truncate-lines' in Gnus Article buffer.
+Valid values are nil, t, `head', `first', `last', an integer or a
+predicate. See Info node `(gnus)Customizing Articles'."
+ :version "23.0" ;; No Gnus
+ :group 'gnus-article
+ ;; :link '(custom-manual "(gnus)Customizing Articles")
+ :type 'boolean)
+
+(defun gnus-article-toggle-truncate-lines (&optional arg)
+ "Toggle whether to fold or truncate long lines in article the buffer.
+If ARG is non-nil and not a number, toggle
+`gnus-article-truncate-lines' too. If ARG is a number, truncate
+long lines iff arg is positive."
+ (interactive "P")
+ (cond
+ ((and (numberp arg) (> arg 0))
+ (setq gnus-article-truncate-lines t))
+ ((numberp arg)
+ (setq gnus-article-truncate-lines nil))
+ (arg
+ (setq gnus-article-truncate-lines
+ (not gnus-article-truncate-lines))))
+ (gnus-with-article-buffer
+ (cond
+ ((and (numberp arg) (> arg 0))
+ (setq truncate-lines nil))
+ ((numberp arg)
+ (setq truncate-lines t)))
+ ;; In versions of Emacs 22 (CVS) before 2006-05-26,
+ ;; `toggle-truncate-lines' needs an argument.
+ (toggle-truncate-lines)))
+
(defun gnus-article-treat-body-boundary ()
"Place a boundary line at the end of the headers."
(interactive)
(set-buffer gnus-summary-buffer)
(error))
gnus-newsgroup-ignored-charsets))
- (inhibit-read-only t))
- (save-restriction
- (article-narrow-to-head)
- (funcall gnus-decode-header-function (point-min) (point-max)))))
+ (inhibit-read-only t)
+ end start)
+ (goto-char (point-min))
+ (when (search-forward "\n\n" nil 'move)
+ (forward-line -1))
+ (setq end (point))
+ (while (not (bobp))
+ (while (progn
+ (forward-line -1)
+ (and (not (bobp))
+ (memq (char-after) '(?\t ? )))))
+ (setq start (point))
+ (if (looking-at "\
+\\(?:Resent-\\)?\\(?:From\\|Cc\\|To\\|Bcc\\|\\(?:In-\\)?Reply-To\\|Sender\
+\\|Mail-Followup-To\\|Mail-Copies-To\\|Approved\\):")
+ (funcall gnus-decode-address-function start end)
+ (funcall gnus-decode-header-function start end))
+ (goto-char (setq end start)))))
(defun article-decode-group-name ()
- "Decode group names in `Newsgroups:'."
+ "Decode group names in Newsgroups, Followup-To and Xref headers."
(let ((inhibit-point-motion-hooks t)
(inhibit-read-only t)
- (method (gnus-find-method-for-group gnus-newsgroup-name)))
+ (method (gnus-find-method-for-group gnus-newsgroup-name))
+ regexp)
(when (and (or gnus-group-name-charset-method-alist
gnus-group-name-charset-group-alist)
(gnus-buffer-live-p gnus-original-article-buffer))
(save-restriction
(article-narrow-to-head)
- (with-current-buffer gnus-original-article-buffer
- (goto-char (point-min)))
- (while (re-search-forward
- "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
- (replace-match (save-match-data
- (gnus-decode-newsgroups
- ;; XXX how to use data in article buffer?
- (with-current-buffer gnus-original-article-buffer
- (re-search-forward
- "^Newsgroups:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
- nil t)
- (match-string 1))
- gnus-newsgroup-name method))
- t t nil 1))
- (goto-char (point-min))
- (with-current-buffer gnus-original-article-buffer
- (goto-char (point-min)))
- (while (re-search-forward
- "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]" nil t)
- (replace-match (save-match-data
- (gnus-decode-newsgroups
- ;; XXX how to use data in article buffer?
- (with-current-buffer gnus-original-article-buffer
- (re-search-forward
- "^Followup-To:\\(\\(.\\|\n[\t ]\\)*\\)\n[^\t ]"
- nil t)
- (match-string 1))
- gnus-newsgroup-name method))
- t t nil 1))))))
+ (dolist (header '("Newsgroups" "Followup-To" "Xref"))
+ (with-current-buffer gnus-original-article-buffer
+ (goto-char (point-min)))
+ (setq regexp (concat "^" header
+ ":\\([^\n]*\\(?:\n[\t ]+[^\n]+\\)*\\)\n"))
+ (while (re-search-forward regexp nil t)
+ (replace-match (save-match-data
+ (gnus-decode-newsgroups
+ ;; XXX how to use data in article buffer?
+ (with-current-buffer gnus-original-article-buffer
+ (re-search-forward regexp nil t)
+ (match-string 1))
+ gnus-newsgroup-name method))
+ t t nil 1))
+ (goto-char (point-min)))))))
(autoload 'idna-to-unicode "idna")
(add-hook 'gnus-exit-gnus-hook
(lambda ()
(gnus-article-browse-delete-temp-files t)))
- (browse-url tmp-file)
+ ;; FIXME: Warn if there's an <img> tag?
+ (browse-url-of-file tmp-file)
(setq showed t)))
;; If multipart, recurse
((and (stringp (car handle))
(gnus-article-browse-html-parts handle))))))))
showed))
-;; TODO: Key binding
+;; FIXME: Documentation in texi/gnus.texi missing.
(defun gnus-article-browse-html-article ()
- "View \"text/html\" parts of the current article with a WWW browser."
+ "View \"text/html\" parts of the current article with a WWW browser.
+
+Warning: Spammers use links to images in HTML articles to verify
+whether you have read the message. As
+`gnus-article-browse-html-article' passes the unmodified HTML
+content to the browser without eliminating these \"web bugs\" you
+should only use it for mails from trusted senders."
+ ;; Cf. `mm-w3m-safe-url-regexp'
(interactive)
(save-window-excursion
;; Open raw article and select the buffer
(defun gnus-article-save (save-buffer file &optional num)
"Save the currently selected article."
- (unless gnus-save-all-headers
- ;; Remove headers according to `gnus-saved-headers'.
+ (when (or (get gnus-default-article-saver :headers)
+ (not gnus-save-all-headers))
+ ;; Remove headers according to `gnus-saved-headers' or the value
+ ;; of the `:headers' property that the saver function might have.
(let ((gnus-visible-headers
- (or gnus-saved-headers gnus-visible-headers))
+ (or (symbol-value (get gnus-default-article-saver :headers))
+ gnus-saved-headers gnus-visible-headers))
(gnus-article-buffer save-buffer))
(save-excursion
(set-buffer save-buffer)
(funcall gnus-default-article-saver filename)))))
(defun gnus-read-save-file-name (prompt &optional filename
- function group headers variable)
+ function group headers variable
+ dir-var)
(let ((default-name
(funcall function group headers (symbol-value variable)))
result)
default-name)
(filename filename)
(t
+ (when (symbol-value dir-var)
+ (setq default-name (expand-file-name
+ (file-name-nondirectory default-name)
+ (symbol-value dir-var))))
(let* ((split-name (gnus-get-split-value gnus-split-methods))
(prompt
(format prompt
;; Possibly translate some characters.
(nnheader-translate-file-chars file))))))
(gnus-make-directory (file-name-directory result))
- (set variable result)))
+ (when variable
+ (set variable result))
+ (when dir-var
+ (set dir-var (file-name-directory result)))
+ result))
(defun gnus-article-archive-name (group)
"Return the first instance of an \"Archive-name\" in the current buffer."
(gnus-output-to-mail filename)))))
filename)
+(put 'gnus-summary-save-in-file :decode t)
+(put 'gnus-summary-save-in-file :headers 'gnus-saved-headers)
(defun gnus-summary-save-in-file (&optional filename overwrite)
"Append this article to file.
Optional argument FILENAME specifies file name.
(gnus-output-to-file filename))))
filename)
+(put 'gnus-summary-write-to-file :decode t)
+(put 'gnus-summary-write-to-file :function 'gnus-summary-save-in-file)
+(put 'gnus-summary-write-to-file :headers 'gnus-saved-headers)
(defun gnus-summary-write-to-file (&optional filename)
"Write this article to a file, overwriting it if the file exists.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
- (gnus-summary-save-in-file nil t))
+ (setq filename (gnus-read-save-file-name
+ "Save %s in file" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers nil 'gnus-newsgroup-last-directory))
+ (gnus-summary-save-in-file filename t))
-(defun gnus-summary-save-body-in-file (&optional filename)
+(put 'gnus-summary-save-body-in-file :decode t)
+(defun gnus-summary-save-body-in-file (&optional filename overwrite)
"Append this article body to a file.
Optional argument FILENAME specifies file name.
The directory to save in defaults to `gnus-article-save-directory'."
(widen)
(when (article-goto-body)
(narrow-to-region (point) (point-max)))
+ (when (and overwrite
+ (file-exists-p filename))
+ (delete-file filename))
(gnus-output-to-file filename))))
filename)
+(put 'gnus-summary-write-body-to-file :decode t)
+(put 'gnus-summary-write-body-to-file
+ :function 'gnus-summary-save-body-in-file)
+(defun gnus-summary-write-body-to-file (&optional filename)
+ "Write this article body to a file, overwriting it if the file exists.
+Optional argument FILENAME specifies file name.
+The directory to save in defaults to `gnus-article-save-directory'."
+ (setq filename (gnus-read-save-file-name
+ "Save %s body in file" filename
+ gnus-file-save-name gnus-newsgroup-name
+ gnus-current-headers nil 'gnus-newsgroup-last-directory))
+ (gnus-summary-save-body-in-file filename t))
+
(defun gnus-summary-save-in-pipe (&optional command)
"Pipe this article to subprocess."
(setq command
(defun gnus-numeric-save-name (newsgroup headers &optional last-file)
"Generate file name from NEWSGROUP, HEADERS, and optional LAST-FILE.
If variable `gnus-use-long-file-name' is non-nil, it is
-~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
+~/News/news.group/num. Otherwise, it is like ~/News/news/group/num."
(let ((default
(expand-file-name
(concat (if (gnus-use-long-file-name 'not-save)
(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 "\ ".
+ ;; Prevent Emacs 22 from displaying non-break space with `nobreak-space'
+ ;; face.
(set (make-local-variable 'nobreak-char-display) nil)
(setq cursor-in-non-selected-windows nil)
+ (setq truncate-lines gnus-article-truncate-lines)
(gnus-set-default-directory)
(buffer-disable-undo)
(setq buffer-read-only t
(mm-enable-multibyte)
(gnus-run-mode-hooks 'gnus-article-mode-hook))
+(defvar gnus-button-marker-list nil
+ "Regexp matching any of the regexps from `gnus-button-alist'.
+Internal variable.")
+
(defun gnus-article-setup-buffer ()
"Initialize the article buffer."
(let* ((name (if gnus-single-article-buffer "*Article*"
(setq gnus-article-buffer name)
(setq gnus-original-article-buffer original)
(setq gnus-article-mime-handle-alist nil)
- ;; This might be a variable local to the summary buffer.
- (unless gnus-single-article-buffer
- (save-excursion
- (set-buffer gnus-summary-buffer)
+ (with-current-buffer gnus-summary-buffer
+ ;; This might be a variable local to the summary buffer.
+ (unless gnus-single-article-buffer
(setq gnus-article-buffer name)
(setq gnus-original-article-buffer original)
(gnus-set-global-variables)))
(set-buffer (gnus-get-buffer-create name))
(gnus-article-mode)
(make-local-variable 'gnus-summary-buffer)
+ (setq gnus-summary-buffer
+ (gnus-summary-buffer-name gnus-newsgroup-name))
(gnus-summary-set-local-parameters gnus-newsgroup-name)
(current-buffer)))))
;; Set article window start at LINE, where LINE is the number of lines
;; from the head of the article.
(defun gnus-article-set-window-start (&optional line)
- (set-window-start
- (gnus-get-buffer-window gnus-article-buffer t)
- (save-excursion
- (set-buffer gnus-article-buffer)
- (goto-char (point-min))
- (if (not line)
- (point-min)
- (gnus-message 6 "Moved to bookmark")
- (search-forward "\n\n" nil t)
- (forward-line line)
- (point)))))
+ (let ((article-window (gnus-get-buffer-window gnus-article-buffer t)))
+ (when article-window
+ (set-window-start
+ article-window
+ (save-excursion
+ (set-buffer gnus-article-buffer)
+ (goto-char (point-min))
+ (if (not line)
+ (point-min)
+ (gnus-message 6 "Moved to bookmark")
+ (search-forward "\n\n" nil t)
+ (forward-line line)
+ (point)))))))
(defun gnus-article-prepare (article &optional all-headers header)
"Prepare ARTICLE in article mode buffer.
(funcall gnus-display-mime-function))
(gnus-run-hooks 'gnus-article-prepare-hook)))
+;;;
+;;; Gnus Sticky Article Mode
+;;;
+
+(define-derived-mode gnus-sticky-article-mode gnus-article-mode "StickyArticle"
+ "Mode for sticky articles."
+ ;; Release bindings that won't work.
+ (substitute-key-definition 'gnus-article-read-summary-keys 'undefined
+ gnus-sticky-article-mode-map)
+ (substitute-key-definition 'gnus-article-refer-article 'undefined
+ gnus-sticky-article-mode-map)
+ (dolist (k '("e" "h" "s" "F" "R"))
+ (define-key gnus-sticky-article-mode-map k nil))
+ (define-key gnus-sticky-article-mode-map "k" 'gnus-kill-sticky-article-buffer)
+ (define-key gnus-sticky-article-mode-map "q" 'bury-buffer)
+ (define-key gnus-sticky-article-mode-map "\C-hc" 'describe-key-briefly)
+ (define-key gnus-sticky-article-mode-map "\C-hk" 'describe-key))
+
+(defun gnus-sticky-article (arg)
+ "Make the current article sticky.
+If a prefix ARG is given, ask for a name for this sticky article buffer."
+ (interactive "P")
+ (gnus-summary-show-thread)
+ (gnus-summary-select-article nil nil 'pseudo)
+ (let (new-art-buf-name)
+ (gnus-eval-in-buffer-window gnus-article-buffer
+ (setq new-art-buf-name
+ (concat
+ "*Sticky Article: "
+ (if arg
+ (read-from-minibuffer "Sticky article buffer name: ")
+ (gnus-with-article-headers
+ (gnus-article-goto-header "subject")
+ (setq new-art-buf-name
+ (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position)))
+ (goto-char (point-min))
+ (gnus-article-goto-header "from")
+ (setq new-art-buf-name
+ (concat
+ new-art-buf-name ", "
+ (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position))))
+ (goto-char (point-min))
+ (gnus-article-goto-header "date")
+ (setq new-art-buf-name
+ (concat
+ new-art-buf-name ", "
+ (buffer-substring-no-properties
+ (line-beginning-position) (line-end-position))))))
+ "*"))
+ (if (and (gnus-buffer-live-p new-art-buf-name)
+ (with-current-buffer new-art-buf-name
+ (eq major-mode 'gnus-sticky-article-mode)))
+ (switch-to-buffer new-art-buf-name)
+ (setq new-art-buf-name (rename-buffer new-art-buf-name t)))
+ (gnus-sticky-article-mode))
+ (setq gnus-article-buffer new-art-buf-name))
+ (gnus-summary-recenter)
+ (gnus-summary-position-point))
+
+(defun gnus-kill-sticky-article-buffer (&optional buffer)
+ "Kill the given sticky article BUFFER.
+If none is given, assume the current buffer and kill it if it has
+`gnus-sticky-article-mode'."
+ (interactive)
+ (unless buffer
+ (setq buffer (current-buffer)))
+ (with-current-buffer buffer
+ (when (eq major-mode 'gnus-sticky-article-mode)
+ (gnus-kill-buffer buffer))))
+
+(defun gnus-kill-sticky-article-buffers (arg)
+ "Kill all sticky article buffers.
+If a prefix ARG is given, ask for confirmation."
+ (interactive "P")
+ (dolist (buf (gnus-buffers))
+ (with-current-buffer buf
+ (when (eq major-mode 'gnus-sticky-article-mode)
+ (if (not arg)
+ (gnus-kill-buffer buf)
+ (when (yes-or-no-p (concat "Kill buffer " (buffer-name buf) "? "))
+ (gnus-kill-buffer buf)))))))
+
;;;
;;; Gnus MIME viewing functions
;;;
gnus-mime-button-menu gnus-mime-button-map "MIME button menu."
`("MIME Part"
,@(mapcar (lambda (c)
- (vector (caddr c) (car c) :enable t))
+ (vector (caddr c) (car c) :active t))
gnus-mime-button-commands)))
(defun gnus-mime-button-menu (event prefix)
(handles gnus-article-mime-handles)
(none "(none)")
(description
- (or
- (mail-decode-encoded-word-string (or (mm-handle-description data)
- none))))
+ (mail-decode-encoded-word-string (or (mm-handle-description data)
+ none)))
(filename
(or (mail-content-type-get (mm-handle-disposition data) 'filename)
none))
(def-type (and name (mm-default-file-encoding name))))
(and def-type (cons def-type 0))))
-(defun gnus-mime-view-part-as-type (&optional mime-type)
- "Choose a MIME media type, and view the part as such."
+(defun gnus-mime-view-part-as-type (&optional mime-type pred)
+ "Choose a MIME media type, and view the part as such.
+If non-nil, PRED is a predicate to use during completion to limit the
+available media-types."
(interactive)
(unless mime-type
(setq mime-type
(format "View as MIME type (default %s): "
(car default))
(mapcar #'list (mailcap-mime-types))
- nil nil nil nil
+ pred nil nil nil
(car default)))))
(gnus-article-check-buffer)
(let ((handle (get-text-property (point) 'gnus-data)))
(mm-string-to-multibyte contents)))
(goto-char b)))))
+(defun gnus-mime-strip-charset-parameters (handle)
+ "Strip charset parameters from HANDLE."
+ (if (stringp (car handle))
+ (mapc #'gnus-mime-strip-charset-parameters (cdr handle))
+ (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle)
+ "message/external-body")
+ (progn
+ (unless (mm-handle-cache handle)
+ (mm-extern-cache-contents handle))
+ (mm-handle-cache handle))
+ handle)))
+ (charset (assq 'charset (cdr type))))
+ (when charset
+ (delq charset type)))))
+
(defun gnus-mime-view-part-as-charset (&optional handle arg)
"Insert the MIME part under point into the current buffer using the
specified charset."
(let ((handle (or handle (get-text-property (point) 'gnus-data)))
(fun (get-text-property (point) 'gnus-callback))
(gnus-newsgroup-ignored-charsets 'gnus-all)
- gnus-newsgroup-charset type charset)
+ gnus-newsgroup-charset form preferred parts)
(when handle
(if (mm-handle-undisplayer handle)
(mm-remove-part handle))
(setq gnus-newsgroup-charset
(or (cdr (assq arg gnus-summary-show-article-charset-alist))
(mm-read-coding-system "Charset: ")))
- ;; Strip the charset parameter from `handle'.
- (setq type (mm-handle-type
- (if (equal (mm-handle-media-type handle)
- "message/external-body")
- (progn
- (unless (mm-handle-cache handle)
- (mm-extern-cache-contents handle))
- (mm-handle-cache handle))
- handle))
- charset (assq 'charset (cdr type)))
- (delq charset type)
+ (gnus-mime-strip-charset-parameters handle)
+ (when (and (consp (setq form (cdr-safe fun)))
+ (setq form (ignore-errors
+ (assq 'gnus-mime-display-alternative form)))
+ (setq preferred (caddr form))
+ (progn
+ (when (eq (car preferred) 'quote)
+ (setq preferred (cadr preferred)))
+ (not (equal preferred
+ (get-text-property (point) 'gnus-data))))
+ (setq parts (get-text-property (point) 'gnus-part))
+ (setq parts (cdr (assq parts
+ gnus-article-mime-handle-alist)))
+ (equal (mm-handle-media-type parts) "multipart/alternative")
+ (setq parts (reverse (cdr parts))))
+ (setcar (cddr form)
+ (list 'quote (or (cadr (member preferred parts))
+ (car parts)))))
(funcall fun handle)))))
(defun gnus-mime-view-part-externally (&optional handle)
(mm-inlined-types nil)
(mail-parse-charset gnus-newsgroup-charset)
(mail-parse-ignored-charsets
- (with-current-buffer gnus-summary-buffer
- gnus-newsgroup-ignored-charsets)))
- (when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle)))))
+ (with-current-buffer gnus-summary-buffer
+ gnus-newsgroup-ignored-charsets))
+ (type (mm-handle-media-type handle))
+ (method (mailcap-mime-info type))
+ (mm-enable-external t))
+ (if (not (stringp method))
+ (gnus-mime-view-part-as-type
+ nil (lambda (types) (stringp (mailcap-mime-info (car types)))))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))))
(defun gnus-mime-view-part-internally (&optional handle)
"View the MIME part under point with an internal viewer.
(with-current-buffer gnus-summary-buffer
gnus-newsgroup-ignored-charsets))
(inhibit-read-only t))
- (when handle
- (if (mm-handle-undisplayer handle)
- (mm-remove-part handle)
- (mm-display-part handle)))))
+ (if (not (mm-inlinable-p handle))
+ (gnus-mime-view-part-as-type
+ nil (lambda (types) (mm-inlinable-p handle (car types))))
+ (when handle
+ (if (mm-handle-undisplayer handle)
+ (mm-remove-part handle)
+ (mm-display-part handle))))))
(defun gnus-mime-action-on-part (&optional action)
"Do something with the MIME attachment at \(point\)."
(unless (with-current-buffer gnus-summary-buffer
(eq gnus-current-article (gnus-summary-article-number)))
(error "You should select the right article first"))
+ (if n
+ (setq n (prefix-numeric-value n))
+ (let ((pt (point)))
+ (setq n (or (get-text-property pt 'gnus-part)
+ (and (not (bobp))
+ (get-text-property (1- pt) 'gnus-part))
+ (get-text-property (prog2
+ (forward-line 1)
+ (point)
+ (goto-char pt))
+ 'gnus-part)
+ (get-text-property
+ (or (and (setq pt (previous-single-property-change
+ pt 'gnus-part))
+ (1- pt))
+ (next-single-property-change (point) 'gnus-part)
+ (point))
+ 'gnus-part)
+ 1))))
;; Check whether the specified part exists.
(when (> n (length gnus-article-mime-handle-alist))
(error "No such part")))
(defun gnus-article-pipe-part (n)
"Pipe MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'mm-pipe-part))
(defun gnus-article-save-part (n)
"Save MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'mm-save-part))
(defun gnus-article-interactively-view-part (n)
"View MIME part N interactively, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'mm-interactively-view-part))
(defun gnus-article-copy-part (n)
"Copy MIME part N, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-copy-part))
(defun gnus-article-view-part-as-charset (n)
"View MIME part N using a specified charset.
N is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-view-part-as-charset))
(defun gnus-article-view-part-externally (n)
"View MIME part N externally, which is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-view-part-externally))
(defun gnus-article-inline-part (n)
"Inline MIME part N, which is the numerical prefix."
- (interactive "p")
+ (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")
+ (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")
+ (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")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-delete-part t))
(defun gnus-article-view-part-as-type (n)
"Choose a MIME media type, and view part N as such.
N is the numerical prefix."
- (interactive "p")
+ (interactive "P")
(gnus-article-part-wrapper n 'gnus-mime-view-part-as-type t))
(defun gnus-article-mime-match-handle-first (condition)
;; Exclude a newline.
(1- (point))
(point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
+ 'face gnus-article-button-face))
(widget-convert-button
'link b e
:mime-handle handle
(article-goto-body)
(narrow-to-region (point-min) (point))
(gnus-article-save-original-date
- (gnus-treat-article 'head)))))))))
+ (gnus-treat-article 'head)))))))
+ ;; Cope with broken MIME messages.
+ (goto-char (point-max))
+ (unless (bolp)
+ (insert "\n"))))
(defcustom gnus-mime-display-multipart-as-mixed nil
"Display \"multipart\" parts as \"multipart/mixed\".
(save-excursion
(save-restriction
(narrow-to-region beg (point))
- (gnus-treat-article
- nil id
- (gnus-article-mime-total-parts)
- (mm-handle-media-type handle)))))))))
+ (if (eq handle gnus-article-mime-handles)
+ ;; The format=flowed case.
+ (gnus-treat-article nil 1 1 (mm-handle-media-type handle))
+ ;; Don't count signature parts that are never displayed.
+ ;; The part number should be re-calculated supposing this
+ ;; might be a message/rfc822 part.
+ (let (handles)
+ (dolist (part gnus-article-mime-handles)
+ (unless (or (stringp part)
+ (equal (car (mm-handle-type part))
+ "application/pgp-signature"))
+ (push part handles)))
+ (gnus-treat-article
+ nil (length (memq handle handles)) (length handles)
+ (mm-handle-media-type handle)))))))))))
(defun gnus-unbuttonized-mime-type-p (type)
"Say whether TYPE is to be unbuttonized."
;;; Article savers.
(defun gnus-output-to-file (file-name)
- "Append the current article to a file named FILE-NAME."
- (let ((artbuf (current-buffer)))
+ "Append the current article to a file named FILE-NAME.
+If `gnus-article-save-coding-system' is non-nil, it is used to encode
+text and used as the value of the coding cookie which is added to the
+top of a file. Otherwise, this function saves a raw article without
+the coding cookie."
+ (let* ((artbuf (current-buffer))
+ (file-name-coding-system nnmail-pathname-coding-system)
+ (coding gnus-article-save-coding-system)
+ (coding-system-for-read (if coding
+ nil ;; Rely on the coding cookie.
+ mm-text-coding-system))
+ (coding-system-for-write (or coding
+ mm-text-coding-system-for-write
+ mm-text-coding-system))
+ (exists (file-exists-p file-name)))
(with-temp-buffer
+ (when exists
+ (insert-file-contents file-name)
+ (goto-char (point-min))
+ ;; Remove the existing coding cookie.
+ (when (looking-at "X-Gnus-Coding-System: .+\n\n")
+ (delete-region (match-beginning 0) (match-end 0))))
+ (goto-char (point-max))
(insert-buffer-substring artbuf)
;; Append newline at end of the buffer as separator, and then
;; save it to file.
(goto-char (point-max))
(insert "\n")
- (let ((file-name-coding-system nnmail-pathname-coding-system))
- (mm-append-to-file (point-min) (point-max) file-name))
- t)))
+ (when coding
+ ;; If the coding system is not suitable to encode the text,
+ ;; ask a user for a proper one.
+ (when (fboundp 'select-safe-coding-system)
+ (setq coding (coding-system-base
+ (save-window-excursion
+ (select-safe-coding-system (point-min) (point-max)
+ coding))))
+ (setq coding-system-for-write
+ (or (cdr (assq coding '((mule-utf-8 . utf-8))))
+ coding)))
+ (goto-char (point-min))
+ ;; Add the coding cookie.
+ (insert (format "X-Gnus-Coding-System: -*- coding: %s; -*-\n\n"
+ coding-system-for-write)))
+ (if exists
+ (progn
+ (write-region (point-min) (point-max) file-name nil 'no-message)
+ (message "Appended to %s" file-name))
+ (write-region (point-min) (point-max) file-name))))
+ t)
(defun gnus-narrow-to-page (&optional arg)
"Narrow the article buffer to a page.
"Execute the last keystroke in the summary buffer."
(interactive)
(let (func)
- (pop-to-buffer gnus-article-current-summary 'norecord)
+ (pop-to-buffer gnus-article-current-summary nil (not (featurep 'xemacs)))
(setq func (lookup-key (current-local-map) (this-command-keys)))
(call-interactively func)))
(message "")
- (if (or (member keys nosaves)
- (member keys nosave-but-article)
- (member keys nosave-in-article))
- (let (func)
- (save-window-excursion
- (pop-to-buffer gnus-article-current-summary 'norecord)
- ;; We disable the pick minor mode commands.
- (let (gnus-pick-mode)
- (setq func (lookup-key (current-local-map) keys))))
- (if (or (not func)
- (numberp func))
- (ding)
- (unless (member keys nosave-in-article)
- (set-buffer gnus-article-current-summary))
- (call-interactively func)
- (setq new-sum-point (point)))
- (when (member keys nosave-but-article)
- (pop-to-buffer gnus-article-buffer 'norecord)))
+ (cond
+ ((eq (aref keys (1- (length keys))) ?\C-h)
+ (with-current-buffer gnus-article-current-summary
+ (describe-bindings (substring keys 0 -1))))
+ ((or (member keys nosaves)
+ (member keys nosave-but-article)
+ (member keys nosave-in-article))
+ (let (func)
+ (save-window-excursion
+ (pop-to-buffer gnus-article-current-summary
+ nil (not (featurep 'xemacs)))
+ ;; We disable the pick minor mode commands.
+ (let (gnus-pick-mode)
+ (setq func (lookup-key (current-local-map) keys))))
+ (if (or (not func)
+ (numberp func))
+ (ding)
+ (unless (member keys nosave-in-article)
+ (set-buffer gnus-article-current-summary))
+ (call-interactively func)
+ (setq new-sum-point (point)))
+ (when (member keys nosave-but-article)
+ (pop-to-buffer gnus-article-buffer nil (not (featurep 'xemacs))))))
+ (t
;; These commands should restore window configuration.
(let ((obuf (current-buffer))
(owin (current-window-configuration))
- (opoint (point))
- win func in-buffer selected new-sum-start new-sum-hscroll)
+ win func in-buffer selected new-sum-start new-sum-hscroll err)
(cond (not-restore-window
- (pop-to-buffer gnus-article-current-summary 'norecord))
+ (pop-to-buffer gnus-article-current-summary
+ nil (not (featurep 'xemacs)))
+ (setq win (selected-window)))
((setq win (get-buffer-window gnus-article-current-summary))
(select-window win))
(t
- (switch-to-buffer gnus-article-current-summary 'norecord)))
+ (let ((summary-buffer gnus-article-current-summary))
+ (gnus-configure-windows 'article)
+ (unless (setq win (get-buffer-window summary-buffer 'visible))
+ (let ((gnus-buffer-configuration
+ '(article ((vertical 1.0
+ (summary 0.25 point)
+ (article 1.0))))))
+ (gnus-configure-windows 'article))
+ (setq win (get-buffer-window summary-buffer 'visible)))
+ (gnus-select-frame-set-input-focus (window-frame win))
+ (select-window win))))
(setq in-buffer (current-buffer))
;; We disable the pick minor mode commands.
(if (and (setq func (let (gnus-pick-mode)
(lookup-key (current-local-map) keys)))
- (functionp func))
+ (functionp func)
+ (condition-case code
+ (progn
+ (call-interactively func)
+ t)
+ (error
+ (setq err code)
+ nil)))
(progn
- (call-interactively func)
(when (eq win (selected-window))
(setq new-sum-point (point)
new-sum-start (window-start win)
new-sum-hscroll (window-hscroll win)))
- (when (eq in-buffer (current-buffer))
+ (when (or (eq in-buffer (current-buffer))
+ (when (eq obuf (current-buffer))
+ (set-buffer in-buffer)
+ t))
(setq selected (gnus-summary-select-article))
(set-buffer obuf)
(unless not-restore-window
(set-window-configuration owin))
- (when (eq selected 'old)
- (article-goto-body)
+ (when (and (eq selected 'old)
+ new-sum-point)
(set-window-start (get-buffer-window (current-buffer))
1)
(set-window-point (get-buffer-window (current-buffer))
- (point)))
+ (if (article-goto-body)
+ (1- (point))
+ (point))))
(when (and (not not-restore-window)
- new-sum-point)
+ new-sum-point
+ (with-current-buffer (window-buffer win)
+ (eq major-mode 'gnus-summary-mode)))
(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))))))
+ (if err
+ (signal (car err) (cdr err))
+ (ding))))))))
(defun gnus-article-describe-key (key)
"Display documentation of the function invoked by KEY. KEY is a string."
;;; Internal Variables:
(defcustom gnus-button-url-regexp
- (if (string-match "[[:digit:]]" "1") ;; support POSIX?
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?[-a-z0-9_=!?#$@~%&*+\\/:;.,[:word:]]+[-a-z0-9_=#$@~%&*+\\/[:word:]]\\)"
- "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)\\(//[-a-z0-9_.]+:[0-9]*\\)?\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)\\)")
+ (concat
+ "\\b\\(\\(www\\.\\|\\(s?https?\\|ftp\\|file\\|gopher\\|"
+ "nntp\\|news\\|telnet\\|wais\\|mailto\\|info\\):\\)"
+ "\\(//[-a-z0-9_.]+:[0-9]*\\)?"
+ (if (string-match "[[:digit:]]" "1") ;; Support POSIX?
+ (let ((chars "-a-z0-9_=#$@~%&*+\\/[:word:]")
+ (punct "!?:;.,"))
+ (concat
+ "\\(?:"
+ ;; Match paired parentheses, e.g. in Wikipedia URLs:
+ "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]"
+ "\\|"
+ "[" chars punct "]+" "[" chars "]"
+ "\\)"))
+ (concat ;; XEmacs 21.4 doesn't support POSIX.
+ "\\([-a-z0-9_=!?#$@~%&*+\\/:;.,]\\|\\w\\)+"
+ "\\([-a-z0-9_=#$@~%&*+\\/]\\|\\w\\)"))
+ "\\)")
"Regular expression that matches URLs."
:group 'gnus-article-buttons
:type 'regexp)
of the symbols `mid' or `mail', Gnus will always assume that the string is a
message ID or a mail address, respectively. If this variable is set to the
symbol `ask', always query the user what do do. If it is a function, this
-function will be called with the string as it's only argument. The function
+function will be called with the string as its only argument. The function
must return `mid', `mail', `invalid' or `ask'."
:version "22.1"
:group 'gnus-article-buttons
"Call function FUN on argument ARG.
Both FUN and ARG are supposed to be strings. ARG will be passed
as a symbol to FUN."
- (funcall (intern fun) (intern arg)))
+ (funcall (intern fun)
+ (if (string-match "^customize-apropos" fun)
+ arg
+ (intern arg))))
(defvar gnus-button-handle-describe-prefix "^\\(C-h\\|<?[Ff]1>?\\)")
0 (>= gnus-button-message-level 0) gnus-button-message-id 2)
("\\bin\\( +article\\| +message\\)? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
+ ("\\b\\(mid\\|message-id\\):? +\\(<\\([^\n @<>]+@[^\n @<>]+\\)>\\)"
+ 2 (>= gnus-button-message-level 0) gnus-button-message-id 3)
("\\(<URL: *\\)mailto: *\\([^> \n\t]+\\)>"
0 (>= gnus-button-message-level 0) gnus-url-mailto 2)
;; RFC 2368 (The mailto URL scheme)
1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
("`\\([a-z][-a-z0-9]+\\.el\\)'"
1 (>= gnus-button-emacs-level 8) gnus-button-handle-library 1)
- ("`\\([a-z][a-z0-9]+-[a-z]+-[-a-z]+\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
+ ("`\\([a-z][a-z0-9]+-[a-z0-9]+-[-a-z0-9]*[a-z]\\|\\(gnus\\|message\\)-[-a-z]+\\)'"
0 (>= gnus-button-emacs-level 8) gnus-button-handle-symbol 1)
("`\\([a-z][a-z0-9]+-[a-z]+\\)'"
0 (>= gnus-button-emacs-level 9) gnus-button-handle-symbol 1)
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-function 2)
("\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+v[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET"
0 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-variable 2)
- ("`\\(\\b\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
+ ("`\\(\\(C-h\\|<?[Ff]1>?\\)[ \t\n]+k[ \t\n]+\\([^']+\\)\\)'"
;; Unlike the other regexps we really have to require quoting
;; here to determine where it ends.
1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3)
(with-current-buffer gnus-summary-buffer
(gnus-summary-refer-article message-id)))
-(defun gnus-button-fetch-group (address)
+(defun gnus-button-fetch-group (address &rest ignore)
"Fetch GROUP specified by ADDRESS."
+ (when (string-match "\\`\\(nntp\\|news\\):\\(//\\)?\\(.*\\)\\'"
+ address)
+ ;; Allow to use `gnus-button-fetch-group' in `browse-url-browser-function'
+ ;; for nntp:// and news://
+ (setq address (match-string 3 address)))
(if (not (string-match "[:/]" address))
;; This is just a simple group url.
(gnus-group-read-ephemeral-group address gnus-select-method)
map))
(defun gnus-insert-prev-page-button ()
- (let ((b (point))
+ (let ((b (point)) e
(inhibit-read-only t))
(gnus-eval-format
gnus-prev-page-line-format nil
`(keymap ,gnus-prev-page-map
- gnus-prev t
- gnus-callback gnus-article-button-prev-page
- article-type annotation))
+ gnus-prev t
+ gnus-callback gnus-article-button-prev-page
+ article-type annotation))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e)
+ 'face gnus-article-button-face))
(widget-convert-button
- 'link b (if (bolp)
- ;; Exclude a newline.
- (1- (point))
- (point))
+ 'link b e
:action 'gnus-button-prev-page
:button-keymap gnus-prev-page-map)))
(select-window win)))
(defun gnus-insert-next-page-button ()
- (let ((b (point))
+ (let ((b (point)) e
(inhibit-read-only t))
(gnus-eval-format gnus-next-page-line-format nil
`(keymap ,gnus-next-page-map
- gnus-next t
- gnus-callback gnus-article-button-next-page
- article-type annotation))
+ gnus-next t
+ gnus-callback gnus-article-button-next-page
+ article-type annotation))
+ (setq e (if (bolp)
+ ;; Exclude a newline.
+ (1- (point))
+ (point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e)
+ 'face gnus-article-button-face))
(widget-convert-button
- 'link b (if (bolp)
- ;; Exclude a newline.
- (1- (point))
- (point))
+ 'link b e
:action 'gnus-button-next-page
:button-keymap gnus-next-page-map)))
,@(delq nil
(mapcar (lambda (c)
(unless (eq (car c) 'undefined)
- (vector (caddr c) (car c) :enable t)))
+ (vector (caddr c) (car c) :active t)))
gnus-mime-security-button-commands))))
(defun gnus-mime-security-button-menu (event prefix)
point (inhibit-read-only t))
(if region
(goto-char (car region)))
- (save-restriction
- (narrow-to-region (point) (point))
- (with-current-buffer (mm-handle-multipart-original-buffer handle)
- (let* ((mm-verify-option 'known)
- (mm-decrypt-option 'known)
- (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
- (unless (eq nparts (cdr handle))
- (mm-destroy-parts (cdr handle))
- (setcdr handle nparts))))
- (setq point (point))
- (gnus-mime-display-security handle)
- (goto-char (point-max)))
+ (setq point (point))
+ (with-current-buffer (mm-handle-multipart-original-buffer handle)
+ (let* ((mm-verify-option 'known)
+ (mm-decrypt-option 'known)
+ (nparts (mm-possibly-verify-or-decrypt (cdr handle) handle)))
+ (unless (eq nparts (cdr handle))
+ (mm-destroy-parts (cdr handle))
+ (setcdr handle nparts))))
+ (gnus-mime-display-security handle)
(when region
(delete-region (point) (cdr region))
(set-marker (car region) nil)
;; Exclude a newline.
(1- (point))
(point)))
+ (when gnus-article-button-face
+ (gnus-overlay-put (gnus-make-overlay b e nil t)
+ 'face gnus-article-button-face))
(widget-convert-button
'link b e
:mime-handle handle
(mm-set-handle-multipart-parameter
handle 'gnus-region
(cons (set-marker (make-marker) (point-min))
- (set-marker (make-marker) (point-max))))))
+ (set-marker (make-marker) (point-max))))
+ (goto-char (point-max))))
(defun gnus-mime-security-run-function (function)
"Run FUNCTION with the security part under point."