X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=0e8dede98f360e4cb1d6d8df99cccc57146ce81b;hp=2ec1fcfae462edd4b7676ba8147c95d321467dd5;hb=e2c9efb05a1ae9e65fd40bab80466da331f3981b;hpb=8bb7e608b8882835443703f5b8e5f4b40d3ae035 diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index 2ec1fcfae..0e8dede98 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1,17 +1,17 @@ ;;; gnus-art.el --- article mode commands for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; Keywords: news ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -19,18 +19,19 @@ ;; GNU General Public License for more details. ;; 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., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs < 22.2. +(eval-and-compile + (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile - (require 'cl) - (defvar tool-bar-map) - (defvar w3m-minor-mode-map)) + (require 'cl)) +(defvar tool-bar-map) +(defvar w3m-minor-mode-map) (require 'gnus) ;; Avoid the "Recursive load suspected" error in Emacs 21.1. @@ -175,12 +176,15 @@ If `gnus-visible-headers' is non-nil, this variable will be ignored." "*All headers that do not match this regexp will be hidden. This variable can also be a list of regexp of headers to remain visible. If this variable is non-nil, `gnus-ignored-headers' will be ignored." - :type '(repeat :value-to-internal (lambda (widget value) - (custom-split-regexp-maybe value)) - :match (lambda (widget value) - (or (stringp value) - (widget-editable-list-match widget value))) - regexp) + :type '(choice + (repeat :value-to-internal (lambda (widget value) + (custom-split-regexp-maybe value)) + :match (lambda (widget value) + (or (stringp value) + (widget-editable-list-match widget value))) + regexp) + (const :tag "Use gnus-ignored-headers" nil) + regexp) :group 'gnus-article-hiding) (defcustom gnus-sorted-header-list @@ -548,13 +552,15 @@ Gnus provides the following functions: * gnus-summary-save-in-vm (use VM's folder format) * gnus-summary-write-to-file (article format -- overwrite) * gnus-summary-write-body-to-file (article body -- overwrite) +* gnus-summary-save-in-pipe (article format) 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'. +`gnus-summary-write-to-file', `gnus-summary-write-body-to-file', and +`gnus-summary-save-in-pipe'. * :function The value specifies an alternative function which appends, not @@ -577,6 +583,7 @@ headers should be saved." (function-item gnus-summary-save-in-vm) (function-item gnus-summary-write-to-file) (function-item gnus-summary-write-body-to-file) + (function-item gnus-summary-save-in-pipe) (function))) (defcustom gnus-article-save-coding-system @@ -715,7 +722,7 @@ The following additional specs are available: (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 + :version "23.1" ;; No Gnus :type '(repeat regexp) :group 'gnus-article-various) @@ -882,7 +889,7 @@ See the manual for the valid properties for various image types. Currently, `pbm' is used for X-Face images and `png' is used for Face images in Emacs. Only the `:face' property is effective on the `xface' image type in XEmacs if it is built with the libcompface library." - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :group 'gnus-article-headers :type '(repeat (cons :format "%v" (symbol :tag "Image type") plist))) @@ -1054,7 +1061,7 @@ used." 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 + :version "23.1" ;; No Gnus :group 'gnus-article-mime :type '(choice (const nil :tag "Redisplay article.") (const 1 :tag "Next part.") @@ -1359,7 +1366,7 @@ 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 + :version "23.1" ;; No Gnus :group 'gnus-article-treat :type '(choice (const nil) (const :tag "all" t) @@ -1446,7 +1453,7 @@ See Info node `(gnus)Customizing Articles' and Info node "Display 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." +node `(gnus)Face' for details." :group 'gnus-article-treat :version "22.1" :link '(custom-manual "(gnus)Customizing Articles") @@ -1601,7 +1608,7 @@ It is a string, such as \"PGP\". If nil, ask user." (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) (mm-coding-system-p 'utf-8) - (executable-find (symbol-value 'idna-program))) + (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" @@ -1697,11 +1704,6 @@ Initialized from `text-mode-syntax-table.") (defvar gnus-save-article-buffer nil) -(defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s) - (?m (gnus-article-mime-part-status) ?s)) - gnus-summary-mode-line-format-alist)) - (defvar gnus-number-of-articles-to-be-saved nil) (defvar gnus-inhibit-hiding nil) @@ -1711,8 +1713,7 @@ Initialized from `text-mode-syntax-table.") ;;; Macros for dealing with the article buffer. (defmacro gnus-with-article-headers (&rest forms) - `(save-excursion - (set-buffer gnus-article-buffer) + `(with-current-buffer gnus-article-buffer (save-restriction (let ((inhibit-read-only t) (inhibit-point-motion-hooks t) @@ -1724,8 +1725,7 @@ Initialized from `text-mode-syntax-table.") (put 'gnus-with-article-headers 'edebug-form-spec '(body)) (defmacro gnus-with-article-buffer (&rest forms) - `(save-excursion - (set-buffer gnus-article-buffer) + `(with-current-buffer gnus-article-buffer (let ((inhibit-read-only t)) ,@forms))) @@ -2222,11 +2222,11 @@ unfolded." (mail-header-fold-field) (goto-char (point-max)))))) -(defcustom gnus-article-truncate-lines default-truncate-lines +(defcustom gnus-article-truncate-lines (default-value '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 + :version "23.1" ;; No Gnus :group 'gnus-article ;; :link '(custom-manual "(gnus)Customizing Articles") :type 'boolean) @@ -2235,7 +2235,7 @@ predicate. See Info node `(gnus)Customizing Articles'." "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." +long lines if and only if arg is positive." (interactive "P") (cond ((and (numberp arg) (> arg 0)) @@ -2332,8 +2332,7 @@ long lines iff arg is positive." (forward-line 1) (point)))))) -(eval-when-compile - (defvar gnus-face-properties-alist)) +(defvar gnus-face-properties-alist) (defun article-display-face (&optional force) "Display any Face headers in the header." @@ -2706,6 +2705,9 @@ charset defined in `gnus-summary-show-article-charset-alist' is used." (t (apply (car func) (cdr func)))))))))) +;; External. +(declare-function w3-region "ext:w3-display" (st nd)) + (defun gnus-article-wash-html-with-w3 () "Wash the current buffer with w3." (mm-setup-w3) @@ -2717,22 +2719,44 @@ charset defined in `gnus-summary-show-article-charset-alist' is used." (w3-region (point-min) (point-max)) (error)))) +;; External. +(declare-function w3m-region "ext:w3m" (start end &optional url charset)) + (defun gnus-article-wash-html-with-w3m () "Wash the current buffer with emacs-w3m." (mm-setup-w3m) (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) w3m-force-redisplay) (w3m-region (point-min) (point-max))) + ;; Put the mark meaning this part was rendered by emacs-w3m. + (put-text-property (point-min) (point-max) 'mm-inline-text-html-with-w3m t) (when (and mm-inline-text-html-with-w3m-keymap (boundp 'w3m-minor-mode-map) w3m-minor-mode-map) - (add-text-properties - (point-min) (point-max) - (list 'keymap w3m-minor-mode-map - ;; Put the mark meaning this part was rendered by emacs-w3m. - 'mm-inline-text-html-with-w3m t)))) - -(eval-when-compile (defvar charset)) ;; Bound by `article-wash-html'. + (if (and (boundp 'w3m-link-map) + w3m-link-map) + (let* ((start (point-min)) + (end (point-max)) + (on (get-text-property start 'w3m-href-anchor)) + (map (copy-keymap w3m-link-map)) + next) + (set-keymap-parent map w3m-minor-mode-map) + (while (< start end) + (if on + (progn + (setq next (or (text-property-any start end + 'w3m-href-anchor nil) + end)) + (put-text-property start next 'keymap map)) + (setq next (or (text-property-not-all start end + 'w3m-href-anchor nil) + end)) + (put-text-property start next 'keymap w3m-minor-mode-map)) + (setq start next + on (not on)))) + (put-text-property (point-min) (point-max) 'keymap w3m-minor-mode-map)))) + +(defvar charset) ;; Bound by `article-wash-html'. (defun gnus-article-wash-html-with-w3m-standalone () "Wash the current buffer with w3m." @@ -2760,7 +2784,7 @@ exit from the summary buffer. If it is the symbol `file', query on each file, if it is `ask' ask once when exiting from the summary buffer." :group 'gnus-article - :version "23.0" ;; No Gnus + :version "23.1" ;; No Gnus :type '(choice (const :tag "Don't delete" nil) (const :tag "Don't ask" t) (const :tag "Ask" ask) @@ -2774,9 +2798,9 @@ summary buffer." (or how (setq how gnus-article-browse-delete-temp))) (when (and (eq how 'ask) - (y-or-n-p (format - "Delete all %s temporary HTML file(s)? " - (length gnus-article-browse-html-temp-list))) + (gnus-y-or-n-p (format + "Delete all %s temporary HTML file(s)? " + (length gnus-article-browse-html-temp-list))) (setq how t))) (dolist (file gnus-article-browse-html-temp-list) (when (and (file-exists-p file) @@ -2790,65 +2814,223 @@ summary buffer." (setq gnus-article-browse-html-temp-list nil)) gnus-article-browse-html-temp-list) -(defun gnus-article-browse-html-parts (list) +(defun gnus-article-browse-html-parts (list &optional header) "View all \"text/html\" parts from LIST. -Recurse into multiparts." +Recurse into multiparts. The optional HEADER that should be a decoded +message header will be added to the bodies of the \"text/html\" parts." ;; Internal function used by `gnus-article-browse-html-article'. - (let ((showed)) + (let (type file charset tmp-file showed) ;; Find and show the html-parts. (dolist (handle list) ;; If HTML, show it: - (when (listp handle) - (cond ((and (bufferp (car handle)) - (string-match "text/html" (car (mm-handle-type handle)))) - (let ((tmp-file (mm-make-temp-file - ;; Do we need to care for 8.3 filenames? - "mm-" nil ".html"))) - (mm-save-part-to-file handle tmp-file) - (add-to-list 'gnus-article-browse-html-temp-list tmp-file) - (add-hook 'gnus-summary-prepare-exit-hook - 'gnus-article-browse-delete-temp-files) - (add-hook 'gnus-exit-gnus-hook - (lambda () - (gnus-article-browse-delete-temp-files t))) - ;; FIXME: Warn if there's an tag? - (browse-url-of-file tmp-file) - (setq showed t))) - ;; If multipart, recurse - ((and (stringp (car handle)) - (string-match "^multipart/" (car handle)) - (setq showed - (or showed - (gnus-article-browse-html-parts handle)))))))) + (cond ((not (listp handle))) + ((or (equal (car (setq type (mm-handle-type handle))) "text/html") + (and (equal (car type) "message/external-body") + (or header + (setq file (or (mail-content-type-get type 'name) + (mail-content-type-get + (mm-handle-disposition handle) + 'filename)))) + (or (mm-handle-cache handle) + (condition-case code + (progn (mm-extern-cache-contents handle) t) + (error + (gnus-message 3 "%s" (error-message-string code)) + (when (>= gnus-verbose 3) (sit-for 2)) + nil))) + (progn + (setq handle (mm-handle-cache handle) + type (mm-handle-type handle)) + (equal (car type) "text/html")))) + (when (or (setq charset (mail-content-type-get type 'charset)) + header + (not file)) + (setq tmp-file (mm-make-temp-file + ;; Do we need to care for 8.3 filenames? + "mm-" nil ".html"))) + ;; Add a meta html tag to specify charset and a header. + (cond + (header + (let (title eheader body hcharset coding) + (with-temp-buffer + (mm-enable-multibyte) + (setq case-fold-search t) + (insert header "\n") + (setq title (message-fetch-field "subject")) + (goto-char (point-min)) + (while (re-search-forward "\\(<\\)\\|\\(>\\)\\|&" nil t) + (replace-match (cond ((match-beginning 1) "<") + ((match-beginning 2) ">") + (t "&")))) + (goto-char (point-min)) + (insert "
\n")
+		   (goto-char (point-max))
+		   (insert "
\n
\n") + ;; We have to examine charset one by one since + ;; charset specified in parts might be different. + (if (eq charset 'gnus-decoded) + (setq charset 'utf-8 + eheader (mm-encode-coding-string (buffer-string) + charset) + title (when title + (mm-encode-coding-string title charset)) + body (mm-encode-coding-string (mm-get-part handle) + charset)) + (setq hcharset (mm-find-mime-charset-region (point-min) + (point-max))) + (cond ((= (length hcharset) 1) + (setq hcharset (car hcharset) + coding (mm-charset-to-coding-system + hcharset))) + ((> (length hcharset) 1) + (setq hcharset 'utf-8 + coding hcharset))) + (if coding + (if charset + (progn + (setq body + (mm-charset-to-coding-system charset)) + (if (eq coding body) + (setq eheader (mm-encode-coding-string + (buffer-string) coding) + title (when title + (mm-encode-coding-string + title coding)) + body (mm-get-part handle)) + (setq charset 'utf-8 + eheader (mm-encode-coding-string + (buffer-string) charset) + title (when title + (mm-encode-coding-string + title charset)) + body (mm-encode-coding-string + (mm-decode-coding-string + (mm-get-part handle) body) + charset)))) + (setq charset hcharset + eheader (mm-encode-coding-string + (buffer-string) coding) + title (when title + (mm-encode-coding-string + title coding)) + body (mm-get-part handle))) + (setq eheader (mm-string-as-unibyte (buffer-string)) + body (mm-get-part handle)))) + (erase-buffer) + (mm-disable-multibyte) + (insert body) + (when charset + (mm-add-meta-html-tag handle charset)) + (when title + (goto-char (point-min)) + (unless (search-forward "" nil t) + (re-search-forward "<head>\\s-*" nil t) + (insert "<title>" title "\n"))) + (goto-char (point-min)) + (or (re-search-forward + "]+\\|\\s-*\\)>\\s-*" nil t) + (re-search-forward + "]+\\|\\s-*\\)>\\s-*" nil t)) + (insert eheader) + (mm-write-region (point-min) (point-max) + tmp-file nil nil nil 'binary t)))) + (charset + (mm-with-unibyte-buffer + (insert (if (eq charset 'gnus-decoded) + (mm-encode-coding-string + (mm-get-part handle) + (setq charset 'utf-8)) + (mm-get-part handle))) + (if (or (mm-add-meta-html-tag handle charset) + (not file)) + (mm-write-region (point-min) (point-max) + tmp-file nil nil nil 'binary t) + (setq tmp-file nil)))) + (tmp-file + (mm-save-part-to-file handle tmp-file))) + (when tmp-file + (add-to-list 'gnus-article-browse-html-temp-list tmp-file)) + (add-hook 'gnus-summary-prepare-exit-hook + 'gnus-article-browse-delete-temp-files) + (add-hook 'gnus-exit-gnus-hook + (lambda () + (gnus-article-browse-delete-temp-files t))) + ;; FIXME: Warn if there's an tag? + (browse-url-of-file (or tmp-file (expand-file-name file))) + (setq showed t)) + ;; If multipart, recurse + ((equal (mm-handle-media-supertype handle) "multipart") + (when (gnus-article-browse-html-parts handle header) + (setq showed t))) + ((equal (mm-handle-media-type handle) "message/rfc822") + (mm-with-multibyte-buffer + (mm-insert-part handle) + (setq handle (mm-dissect-buffer t t)) + (when (and (bufferp (car handle)) + (stringp (car (mm-handle-type handle)))) + (setq handle (list handle))) + (when header + (article-decode-encoded-words) + (let ((gnus-visible-headers + (or (get 'gnus-visible-headers 'standard-value) + gnus-visible-headers))) + (article-hide-headers)) + (goto-char (point-min)) + (search-forward "\n\n" nil 'move) + (skip-chars-backward "\t\n ") + (setq header (buffer-substring (point-min) (point))))) + (when (prog1 + (gnus-article-browse-html-parts handle header) + (mm-destroy-parts handle)) + (setq showed t))))) showed)) -;; FIXME: Documentation in texi/gnus.texi missing. -(defun gnus-article-browse-html-article () +(defun gnus-article-browse-html-article (&optional arg) "View \"text/html\" parts of the current article with a WWW browser. +The message header is added to the beginning of every html part unless +the prefix argument ARG is given. 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. +`gnus-article-browse-html-article' passes the HTML content to the +browser without eliminating these \"web bugs\" you should only +use it for mails from trusted senders. -If you alwasy want to display HTML part in the browser, set +If you always want to display HTML parts in the browser, set `mm-text-html-renderer' to nil." ;; Cf. `mm-w3m-safe-url-regexp' - (interactive) - (save-window-excursion - ;; Open raw article and select the buffer - (gnus-summary-show-article t) - (gnus-summary-select-article-buffer) - (let ((parts (mm-dissect-buffer t t))) + (interactive "P") + (if arg + (gnus-summary-show-article) + (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value) + gnus-visible-headers)) + ;; As we insert a
, there's no need for the body boundary. + (gnus-treat-body-boundary nil)) + (gnus-summary-show-article))) + (with-current-buffer gnus-article-buffer + (let ((header (unless arg + (save-restriction + (widen) + (buffer-substring-no-properties + (goto-char (point-min)) + (if (search-forward "\n\n" nil t) + (match-beginning 0) + (goto-char (point-max)) + (skip-chars-backward "\t\n ") + (point)))))) + parts) + (set-buffer gnus-original-article-buffer) + (setq parts (mm-dissect-buffer t t)) ;; If singlepart, enforce a list. (when (and (bufferp (car parts)) (stringp (car (mm-handle-type parts)))) (setq parts (list parts))) ;; Process the list - (unless (gnus-article-browse-html-parts parts) + (unless (gnus-article-browse-html-parts parts header) (gnus-error 3 "Mail doesn't contain a \"text/html\" part!")) - (gnus-summary-show-article)))) + (mm-destroy-parts parts) + (unless arg + (gnus-summary-show-article))))) (defun article-hide-list-identifiers () "Remove list identifies from the Subject header. @@ -3222,9 +3404,15 @@ should replace the \"Date:\" one, or should be added below it." (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))) + (narrow-to-region + pos (if (setq pos (text-property-any pos (point-max) + 'original-date nil)) + (progn + (goto-char pos) + (if (or (bolp) (eobp)) + (point) + (1+ (point)))) + (point-max))) (goto-char (point-min)) (when (re-search-forward tdate-regexp nil t) (setq bface (get-text-property (point-at-bol) 'face) @@ -3538,9 +3726,8 @@ This format is defined by the `gnus-article-time-format' variable." gnus-newsgroup-name 'highlight-words t))) gnus-emphasis-alist))))) -(eval-when-compile - (defvar gnus-summary-article-menu) - (defvar gnus-summary-post-menu)) +(defvar gnus-summary-article-menu) +(defvar gnus-summary-post-menu) ;;; Saving functions. @@ -3553,9 +3740,9 @@ This format is defined by the `gnus-article-time-format' variable." (let ((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) + ;; Ignore group parameter. See `article-hide-headers'. + (gnus-summary-buffer nil)) + (with-current-buffer save-buffer (article-hide-headers 1 t)))) (save-window-excursion (if (not gnus-default-article-saver) @@ -3778,39 +3965,77 @@ The directory to save in defaults to `gnus-article-save-directory'." 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 - (cond ((and (eq command 'default) - gnus-last-shell-command) - gnus-last-shell-command) - ((stringp command) - command) - (t (read-string - (format - "Shell command on %s: " - (if (and gnus-number-of-articles-to-be-saved - (> gnus-number-of-articles-to-be-saved 1)) - (format "these %d articles" - gnus-number-of-articles-to-be-saved) - "this article")) - gnus-last-shell-command)))) - (when (string-equal command "") - (if gnus-last-shell-command - (setq command gnus-last-shell-command) - (error "A command is required"))) - (gnus-eval-in-buffer-window gnus-article-buffer - (save-restriction - (widen) - (shell-command-on-region (point-min) (point-max) command nil))) - (setq gnus-last-shell-command command)) +(put 'gnus-summary-save-in-pipe :decode t) +(put 'gnus-summary-save-in-pipe :headers 'gnus-saved-headers) +(defun gnus-summary-save-in-pipe (&optional command raw) + "Pipe this article to subprocess COMMAND. +Valid values for COMMAND include: + a string + The executable command name and possibly arguments. + nil + You will be prompted for the command in the minibuffer. + the symbol `default' + It will be replaced with the command which the variable + `gnus-summary-pipe-output-default-command' holds or the command + last used for saving. +Non-nil value for RAW overrides `:decode' and `:headers' properties +and the raw article including all headers will be piped." + (let ((article (gnus-summary-article-number)) + (decode (unless raw + (get 'gnus-summary-save-in-pipe :decode))) + save-buffer default) + (if article + (if (vectorp (gnus-summary-article-header article)) + (save-current-buffer + (gnus-summary-select-article decode decode nil article) + (insert-buffer-substring + (prog1 + (if decode + gnus-article-buffer + gnus-original-article-buffer) + (setq save-buffer + (nnheader-set-temp-buffer " *Gnus Save*")))) + ;; Remove unwanted headers. + (when (and (not raw) + (or (get 'gnus-summary-save-in-pipe :headers) + (not gnus-save-all-headers))) + (let ((gnus-visible-headers + (or (symbol-value (get 'gnus-summary-save-in-pipe + :headers)) + gnus-saved-headers gnus-visible-headers)) + (gnus-summary-buffer nil)) + (article-hide-headers 1 t)))) + (error "%d is not a real article" article)) + (error "No article to pipe")) + (setq default (or gnus-summary-pipe-output-default-command + gnus-last-shell-command)) + (unless (stringp command) + (setq command + (if (and (eq command 'default) default) + default + (gnus-read-shell-command "Shell command on this article: " + default)))) + (when (string-equal command "") + (if default + (setq command default) + (error "A command is required"))) + (gnus-eval-in-buffer-window save-buffer + (save-restriction + (widen) + (shell-command-on-region (point-min) (point-max) command nil))) + (gnus-kill-buffer save-buffer)) + (setq gnus-summary-pipe-output-default-command command)) (defun gnus-summary-pipe-to-muttprint (&optional command) "Pipe this article to muttprint." - (setq command (read-string - "Print using command: " gnus-summary-muttprint-program - nil gnus-summary-muttprint-program)) - (gnus-summary-save-in-pipe command)) + (unless (stringp command) + (setq command (read-string + "Print using command: " gnus-summary-muttprint-program + nil gnus-summary-muttprint-program))) + (let ((gnus-summary-pipe-output-default-command + gnus-summary-pipe-output-default-command)) + (gnus-summary-save-in-pipe command)) + (setq gnus-summary-muttprint-program command)) ;;; Article file names when saving. @@ -3880,6 +4105,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is (defun article-verify-x-pgp-sig () "Verify X-PGP-Sig." + ;; (interactive) (if (gnus-buffer-live-p gnus-original-article-buffer) (let ((sig (with-current-buffer gnus-original-article-buffer @@ -3972,8 +4198,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is `(lambda (&optional interactive &rest args) ,(documentation afunc t) (interactive (list t)) - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (if interactive (call-interactively ',afunc) (apply ',afunc args)))))))) @@ -4050,6 +4275,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "F" gnus-article-followup-with-original "\C-hk" gnus-article-describe-key "\C-hc" gnus-article-describe-key-briefly + "\C-hb" gnus-article-describe-bindings "\C-d" gnus-article-read-summary-keys "\M-*" gnus-article-read-summary-keys @@ -4060,6 +4286,13 @@ If variable `gnus-use-long-file-name' is non-nil, it is (substitute-key-definition 'undefined 'gnus-article-read-summary-keys gnus-article-mode-map) +(gnus-define-keys (gnus-article-send-map "S" gnus-article-mode-map) + "W" gnus-article-wide-reply-with-original) +(if (featurep 'xemacs) + (set-keymap-default-binding gnus-article-send-map + 'gnus-article-read-summary-send-keys) + (define-key gnus-article-send-map [t] 'gnus-article-read-summary-send-keys)) + (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) (gnus-summary-make-menu-bar)) @@ -4172,8 +4405,7 @@ Internal variable.") (gnus-set-global-variables))) (gnus-article-setup-highlight-words) ;; Init original article buffer. - (save-excursion - (set-buffer (gnus-get-buffer-create gnus-original-article-buffer)) + (with-current-buffer (gnus-get-buffer-create gnus-original-article-buffer) (mm-enable-multibyte) (setq major-mode 'gnus-original-article-mode) (make-local-variable 'gnus-original-article)) @@ -4188,8 +4420,7 @@ Internal variable.") nil) (error "Action aborted")) t))) - (save-excursion - (set-buffer name) + (with-current-buffer name (set (make-local-variable 'gnus-article-edit-mode) nil) (when gnus-article-mime-handles (mm-destroy-parts gnus-article-mime-handles) @@ -4203,8 +4434,7 @@ Internal variable.") (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) (current-buffer)) - (save-excursion - (set-buffer (gnus-get-buffer-create name)) + (with-current-buffer (gnus-get-buffer-create name) (gnus-article-mode) (make-local-variable 'gnus-summary-buffer) (setq gnus-summary-buffer @@ -4219,8 +4449,7 @@ Internal variable.") (when article-window (set-window-start article-window - (save-excursion - (set-buffer gnus-article-buffer) + (with-current-buffer gnus-article-buffer (goto-char (point-min)) (if (not line) (point-min) @@ -4274,8 +4503,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (if (or (eq result 'pseudo) (eq result 'nneething)) (progn - (save-excursion - (set-buffer summary-buffer) + (with-current-buffer summary-buffer (push article gnus-newsgroup-history) (setq gnus-last-article gnus-current-article gnus-current-article 0 @@ -4295,8 +4523,7 @@ If ALL-HEADERS is non-nil, no headers are hidden." (not (eq article gnus-current-article))) ;; Seems like a new article has been selected. ;; `gnus-current-article' must be an article number. - (save-excursion - (set-buffer summary-buffer) + (with-current-buffer summary-buffer (push article gnus-newsgroup-history) (setq gnus-last-article gnus-current-article gnus-current-article article @@ -4623,10 +4850,9 @@ and `gnus-mime-delete-part', and not provided at run-time normally." ;; 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)))) + (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) @@ -4688,8 +4914,9 @@ Deleting parts may malfunction or destroy the article; continue? ")) (handles gnus-article-mime-handles) (none "(none)") (description - (mail-decode-encoded-word-string (or (mm-handle-description data) - none))) + (let ((desc (mm-handle-description data))) + (when desc + (mail-decode-encoded-word-string desc)))) (filename (or (mail-content-type-get (mm-handle-disposition data) 'filename) none)) @@ -4707,7 +4934,8 @@ Deleting parts may malfunction or destroy the article; continue? ")) "| Type: " type "\n" "| Filename: " filename "\n" "| Size (encoded): " bsize " Byte\n" - "| Description: " description "\n" + (when description + (concat "| Description: " description "\n")) "`----\n")) (setcdr data (cdr (mm-make-handle @@ -4935,10 +5163,14 @@ Compressed files like .gz and .bz2 are decompressed." (mm-string-to-multibyte contents))) (goto-char b))))) -(defun gnus-mime-strip-charset-parameters (handle) - "Strip charset parameters from HANDLE." +(defun gnus-mime-set-charset-parameters (handle charset) + "Set CHARSET to parameters in HANDLE. +CHARSET may either be a string or a symbol." + (unless (stringp charset) + (setq charset (symbol-name charset))) (if (stringp (car handle)) - (mapc #'gnus-mime-strip-charset-parameters (cdr handle)) + (dolist (h (cdr handle)) + (gnus-mime-set-charset-parameters h charset)) (let* ((type (mm-handle-type (if (equal (mm-handle-media-type handle) "message/external-body") (progn @@ -4946,9 +5178,10 @@ Compressed files like .gz and .bz2 are decompressed." (mm-extern-cache-contents handle)) (mm-handle-cache handle)) handle))) - (charset (assq 'charset (cdr type)))) - (when charset - (delq charset type))))) + (param (assq 'charset (cdr type)))) + (if param + (setcdr param charset) + (setcdr type (cons (cons 'charset charset) (cdr type))))))) (defun gnus-mime-view-part-as-charset (&optional handle arg) "Insert the MIME part under point into the current buffer using the @@ -4958,18 +5191,18 @@ 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 form preferred parts) + charset form preferred parts) (when handle (when (prog1 (and fun - (setq gnus-newsgroup-charset + (setq charset (or (cdr (assq arg gnus-summary-show-article-charset-alist)) (mm-read-coding-system "Charset: ")))) (if (mm-handle-undisplayer handle) (mm-remove-part handle))) - (gnus-mime-strip-charset-parameters handle) + (gnus-mime-set-charset-parameters handle charset) (when (and (consp (setq form (cdr-safe fun))) (setq form (ignore-errors (assq 'gnus-mime-display-alternative form))) @@ -5280,9 +5513,7 @@ N is the numerical prefix." (mail-content-type-get (mm-handle-type handle) 'url) "")) (gnus-tmp-type (mm-handle-media-type handle)) - (gnus-tmp-description - (mail-decode-encoded-word-string (or (mm-handle-description handle) - ""))) + (gnus-tmp-description (or (mm-handle-description handle) "")) (gnus-tmp-dots (if (if displayed (car displayed) (mm-handle-displayed-p handle)) @@ -5829,41 +6060,52 @@ the coding cookie." If given a numerical ARG, move forward ARG pages." (interactive "P") (setq arg (if arg (prefix-numeric-value arg) 0)) - (save-excursion - (set-buffer gnus-article-buffer) - (goto-char (point-min)) + (with-current-buffer gnus-article-buffer (widen) ;; Remove any old next/prev buttons. (when (gnus-visual-p 'page-marker) (let ((inhibit-read-only t)) (gnus-remove-text-with-property 'gnus-prev) (gnus-remove-text-with-property 'gnus-next))) - (if - (cond ((< arg 0) - (re-search-backward page-delimiter nil 'move (1+ (abs arg)))) - ((> arg 0) - (re-search-forward page-delimiter nil 'move arg))) - (goto-char (match-end 0)) - (save-excursion - (goto-char (point-min)) - (setq gnus-page-broken - (and (re-search-forward page-delimiter nil t) t)))) - (when gnus-page-broken - (narrow-to-region - (point) - (if (re-search-forward page-delimiter nil 'move) - (match-beginning 0) - (point))) - (when (and (gnus-visual-p 'page-marker) - (> (point-min) (save-restriction (widen) (point-min)))) - (save-excursion - (goto-char (point-min)) - (gnus-insert-prev-page-button))) - (when (and (gnus-visual-p 'page-marker) - (< (point-max) (save-restriction (widen) (point-max)))) - (save-excursion - (goto-char (point-max)) - (gnus-insert-next-page-button)))))) + (let (st nd pt) + (when (save-excursion + (cond ((< arg 0) + (if (re-search-backward page-delimiter nil 'move (abs arg)) + (prog1 + (setq nd (match-beginning 0) + pt nd) + (when (re-search-backward page-delimiter nil t) + (setq st (match-end 0)))) + (when (re-search-forward page-delimiter nil t) + (setq nd (match-beginning 0) + pt (point-min))))) + ((> arg 0) + (if (re-search-forward page-delimiter nil 'move arg) + (prog1 + (setq st (match-end 0) + pt st) + (when (re-search-forward page-delimiter nil t) + (setq nd (match-beginning 0)))) + (when (re-search-backward page-delimiter nil t) + (setq st (match-end 0) + pt (point-max))))) + (t + (when (re-search-backward page-delimiter nil t) + (goto-char (setq st (match-end 0)))) + (when (re-search-forward page-delimiter nil t) + (setq nd (match-beginning 0))) + (or st nd)))) + (setq gnus-page-broken t) + (when pt (goto-char pt)) + (narrow-to-region (or st (point-min)) (or nd (point-max))) + (when (gnus-visual-p 'page-marker) + (save-excursion + (when nd + (goto-char nd) + (gnus-insert-next-page-button)) + (when st + (goto-char st) + (gnus-insert-prev-page-button)))))))) ;; Article mode commands @@ -5878,7 +6120,7 @@ If given a numerical ARG, move forward ARG pages." (defun gnus-article-goto-prev-page () "Show the previous page of the article." (interactive) - (if (bobp) + (if (save-restriction (widen) (bobp)) ;; Real beginning-of-buffer? (gnus-article-read-summary-keys nil (gnus-character-to-event ?p)) (gnus-article-prev-page nil))) @@ -5901,13 +6143,12 @@ If given a numerical ARG, move forward ARG pages." If end of article, return non-nil. Otherwise return nil. Argument LINES specifies lines to be scrolled up." (interactive "p") - (move-to-window-line -1) + (move-to-window-line (if (featurep 'xemacs) -1 (- -1 scroll-margin))) (if (and (not (and gnus-article-over-scroll (> (count-lines (window-start) (point-max)) - (+ (or lines (1- (window-height))) - (or (and (boundp 'scroll-margin) - (symbol-value 'scroll-margin)) - 0))))) + (if (featurep 'xemacs) + (or lines (1- (window-height))) + (+ (or lines (1- (window-height))) scroll-margin))))) (save-excursion (end-of-line) (and (pos-visible-in-window-p) ;Not continuation line. @@ -5939,19 +6180,19 @@ specifies." (min (max 0 scroll-margin) (max 1 (- (window-height) (if mode-line-format 1 0) - (if header-line-format 1 0))))))) + (if header-line-format 1 0) + 2)))))) (defun gnus-article-next-page-1 (lines) - (when (and (not (featurep 'xemacs)) - (numberp lines) - (> lines 0) - (numberp (symbol-value 'scroll-margin)) - (> (symbol-value 'scroll-margin) 0)) + (unless (featurep 'xemacs) ;; 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)))))) + (when (and (numberp lines) + (> lines 0) + (> scroll-margin 0)) + (setq lines (min lines + (max 0 (- (count-lines (window-start) (point-max)) + scroll-margin)))))) (condition-case () (let ((scroll-in-place nil)) (scroll-up lines)) @@ -5973,9 +6214,9 @@ Argument LINES specifies lines to be scrolled down." (goto-char (point-max)) (recenter (if gnus-article-over-scroll (if lines - (max (+ lines (or (and (boundp 'scroll-margin) - (symbol-value 'scroll-margin)) - 0)) + (max (if (featurep 'xemacs) + lines + (+ lines scroll-margin)) 3) (- (window-height) 2)) -1))) @@ -6067,26 +6308,26 @@ not have a face in `gnus-article-boring-faces'." "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article - '("A\r")) + '("A " "A<" "A>" "AM" "AP" "AR" "AT" "A\C-?" "A\M-\r" "A\r" "Ab" "Ae" + "An" "Ap" [?A (meta return)] [?A delete])) (nosave-in-article - '("\C-d")) + '("AS" "\C-d")) (up-to-top '("n" "Gn" "p" "Gp")) keys new-sum-point) - (save-excursion - (set-buffer gnus-article-current-summary) + (with-current-buffer gnus-article-current-summary (let (gnus-pick-mode) - (push (or key last-command-event) unread-command-events) - (setq keys (if (featurep 'xemacs) - (events-to-keys (read-key-sequence nil)) - (read-key-sequence nil))))) + (setq unread-command-events (nconc unread-command-events + (list (or key last-command-event))) + keys (if (featurep 'xemacs) + (events-to-keys (read-key-sequence nil t)) + (read-key-sequence nil t))))) (message "") (cond ((eq (aref keys (1- (length keys))) ?\C-h) - (with-current-buffer gnus-article-current-summary - (describe-bindings (substring keys 0 -1)))) + (gnus-article-describe-bindings (substring keys 0 -1))) ((or (member keys nosaves) (member keys nosave-but-article) (member keys nosave-in-article)) @@ -6162,6 +6403,7 @@ not have a face in `gnus-article-boring-faces'." (point)))) (when (and (not not-restore-window) new-sum-point + (window-live-p win) (with-current-buffer (window-buffer win) (eq major-mode 'gnus-summary-mode))) (set-window-point win new-sum-point) @@ -6172,53 +6414,110 @@ not have a face in `gnus-article-boring-faces'." (signal (car err) (cdr err)) (ding)))))))) +(defun gnus-article-read-summary-send-keys () + (interactive) + (let ((unread-command-events (list (gnus-character-to-event ?S)))) + (gnus-article-read-summary-keys))) + (defun gnus-article-describe-key (key) - "Display documentation of the function invoked by KEY. KEY is a string." - (interactive "kDescribe key: ") + "Display documentation of the function invoked by KEY. +KEY is a string or a vector." + (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs. + (read-key-sequence "Describe key: ")))) (gnus-article-check-buffer) - (if (eq (key-binding key) 'gnus-article-read-summary-keys) - (save-excursion - (set-buffer gnus-article-current-summary) - (let (gnus-pick-mode) - (if (featurep 'xemacs) - (progn - (push (elt key 0) unread-command-events) - (setq key (events-to-keys - (read-key-sequence "Describe key: ")))) - (setq unread-command-events - (mapcar - (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) - (string-to-list key))) - (setq key (read-key-sequence "Describe key: ")))) - (describe-key key)) + (if (memq (key-binding key t) '(gnus-article-read-summary-keys + gnus-article-read-summary-send-keys)) + (with-current-buffer gnus-article-current-summary + (setq unread-command-events + (if (featurep 'xemacs) + (append key nil) + (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) + (list 'meta (- x 128)) + x)) + key))) + (let ((cursor-in-echo-area t) + gnus-pick-mode) + (describe-key (read-key-sequence nil t)))) (describe-key key))) (defun gnus-article-describe-key-briefly (key &optional insert) - "Display documentation of the function invoked by KEY. KEY is a string." - (interactive "kDescribe key: \nP") + "Display documentation of the function invoked by KEY. +KEY is a string or a vector." + (interactive (list (let ((cursor-in-echo-area t)) ;; better for XEmacs. + (read-key-sequence "Describe key: ")) + current-prefix-arg)) (gnus-article-check-buffer) - (if (eq (key-binding key) 'gnus-article-read-summary-keys) - (save-excursion - (set-buffer gnus-article-current-summary) - (let (gnus-pick-mode) - (if (featurep 'xemacs) - (progn - (push (elt key 0) unread-command-events) - (setq key (events-to-keys - (read-key-sequence "Describe key: ")))) - (setq unread-command-events - (mapcar - (lambda (x) (if (>= x 128) (list 'meta (- x 128)) x)) - (string-to-list key))) - (setq key (read-key-sequence "Describe key: ")))) - (describe-key-briefly key insert)) + (if (memq (key-binding key t) '(gnus-article-read-summary-keys + gnus-article-read-summary-send-keys)) + (with-current-buffer gnus-article-current-summary + (setq unread-command-events + (if (featurep 'xemacs) + (append key nil) + (mapcar (lambda (x) (if (and (integerp x) (>= x 128)) + (list 'meta (- x 128)) + x)) + key))) + (let ((cursor-in-echo-area t) + gnus-pick-mode) + (describe-key-briefly (read-key-sequence nil t) insert))) (describe-key-briefly key insert))) +;;`gnus-agent-mode' in gnus-agent.el will define it. +(defvar gnus-agent-summary-mode) +(defvar gnus-draft-mode) + +(defun gnus-article-describe-bindings (&optional prefix) + "Show a list of all defined keys, and their definitions. +The optional argument PREFIX, if non-nil, should be a key sequence; +then we display only bindings that start with that prefix." + (interactive) + (gnus-article-check-buffer) + (let ((keymap (copy-keymap gnus-article-mode-map)) + (map (copy-keymap gnus-article-send-map)) + (sumkeys (where-is-internal 'gnus-article-read-summary-keys)) + agent draft) + (define-key keymap "S" map) + (define-key map [t] nil) + (with-current-buffer gnus-article-current-summary + (set-keymap-parent map (key-binding "S")) + (let (key def gnus-pick-mode) + (while sumkeys + (setq key (pop sumkeys)) + (cond ((and (vectorp key) (= (length key) 1) + (consp (setq def (aref key 0))) + (numberp (car def)) (numberp (cdr def))) + (when (< (max (car def) (cdr def)) 128) + (setq sumkeys + (append (mapcar + #'vector + (nreverse (gnus-uncompress-range def))) + sumkeys)))) + ((setq def (key-binding key)) + (unless (eq def 'undefined) + (define-key keymap key def)))))) + (when (boundp 'gnus-agent-summary-mode) + (setq agent gnus-agent-summary-mode)) + (when (boundp 'gnus-draft-mode) + (setq draft gnus-draft-mode))) + (with-temp-buffer + (use-local-map keymap) + (set (make-local-variable 'gnus-agent-summary-mode) agent) + (set (make-local-variable 'gnus-draft-mode) draft) + (describe-bindings prefix)) + (let ((item `((lambda (prefix) + (with-current-buffer ,(current-buffer) + (gnus-article-describe-bindings prefix))) + ,prefix))) + (with-current-buffer (if (fboundp 'help-buffer) + (let (help-xref-following) (help-buffer)) + "*Help*") ;; Emacs 21 + (setq help-xref-stack-item item))))) + (defun gnus-article-reply-with-original (&optional wide) "Start composing a reply mail to the current message. The text in the region will be yanked. If the region isn't active, the entire article will be yanked." - (interactive "P") + (interactive) (let ((article (cdr gnus-article-current)) contents) (if (not (gnus-region-active-p)) @@ -6233,6 +6532,13 @@ the entire article will be yanked." (gnus-summary-reply (list (list article contents)) wide))))) +(defun gnus-article-wide-reply-with-original () + "Start composing a wide reply mail to the current message. +The text in the region will be yanked. If the region isn't active, +the entire article will be yanked." + (interactive) + (gnus-article-reply-with-original t)) + (defun gnus-article-followup-with-original () "Compose a followup to the current article. The text in the region will be yanked. If the region isn't active, @@ -6303,8 +6609,7 @@ If given a prefix, show the hidden text instead." gnus-summary-buffer (get-buffer gnus-summary-buffer) (gnus-buffer-exists-p gnus-summary-buffer)) - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let ((header (gnus-summary-article-header article))) (when (< article 0) (cond @@ -6350,7 +6655,13 @@ If given a prefix, show the hidden text instead." (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) + ;; `insert-buffer-substring' would incorrectly use the + ;; equivalent of string-make-multibyte which amount to decoding + ;; with locale-coding-system, causing failure of + ;; subsequent decoding. + (insert (mm-string-to-multibyte + (with-current-buffer gnus-original-article-buffer + (buffer-substring (point-min) (point-max))))) 'article) ;; Check the backlog. ((and gnus-keep-backlog @@ -6596,9 +6907,8 @@ groups." (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) ;; Flush original article as well. - (save-excursion - (when (get-buffer gnus-original-article-buffer) - (set-buffer gnus-original-article-buffer) + (when (get-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (setq gnus-original-article nil))) (when gnus-use-cache (gnus-cache-update-article @@ -6663,7 +6973,8 @@ groups." (concat "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com + "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]*" "\\|" "[" chars punct "]+" "[" chars "]" "\\)")) @@ -7108,9 +7419,9 @@ positives are possible." 1 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url-kde 2) ("\\((Info-goto-node\\|(info\\)[ \t\n]*\\(\"[^\"]*\"\\))" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 2) - ("\\b\\(C-h\\|?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" - ;; Info links like `C-h i d m CC Mode RET' - 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) + ("\\b\\(C-h\\|?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET\\([ \t\n,]*\\)\\)?" + ;; Info links like `C-h i d m Gnus RET' or `C-h i d m Gnus RET i partial RET' + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 0) ;; This is custom ("M-x[ \t\n]\\(customize-[^ ]+\\)[ \t\n]RET[ \t\n]\\([^ ]+\\)[ \t\n]RET" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-custom 1 2) @@ -7590,8 +7901,7 @@ url is put as the `gnus-button-url' overlay property on the button." (gnus-parse-news-url url) (cond (message-id - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (if server (let ((gnus-refer-article-method (nconc (list (list 'nntp server)) @@ -7655,12 +7965,45 @@ url is put as the `gnus-button-url' overlay property on the button." "Fetch KDE style info URL." (gnus-info-find-node (gnus-url-unhex-string url))) +;; (info) will autoload info.el +(declare-function Info-menu "info" (menu-item &optional fork)) +(declare-function Info-index-next "info" (num)) + (defun gnus-button-handle-info-keystrokes (url) "Call `info' when pushing the corresponding URL button." - ;; For links like `C-h i d m gnus RET', `C-h i d m CC Mode RET'. - (info) - (Info-directory) - (Info-menu url)) + ;; For links like `C-h i d m gnus RET part RET , ,', `C-h i d m CC Mode RET'. + (let (node indx comma) + (if (string-match + (concat "\\b\\(C-h\\|?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+" + "\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" + "\\([ \t\n]+i[ \t\n]+[^ ]+ ?[^ ]+[ \t\n]+RET" + "\\(?:[ \t\n,]*\\)\\)?") + url) + (setq node (match-string 2 url) + indx (match-string 3 url)) + (error "Can't parse %s" url)) + (info) + (Info-directory) + (Info-menu node) + (when (> (length indx) 0) + (string-match (concat "[ \t\n]+i[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" + "\\([ \t\n,]*\\)") + indx) + (setq comma (match-string 2 indx)) + (setq indx (match-string 1 indx)) + (Info-index indx) + (when comma + (dotimes (i (with-temp-buffer + (insert comma) + ;; Note: the XEmacs version of `how-many' takes + ;; no optional argument. + (goto-char (point-min)) + (how-many ","))) + (Info-index-next 1))) + nil))) + +;; Called after pgg-snarf-keys-region, which autoloads pgg.el. +(declare-function pgg-display-output-buffer "pgg" (start end status)) (defun gnus-button-openpgp (url) "Retrieve and add an OpenPGP key given URL from an OpenPGP header." @@ -7912,12 +8255,11 @@ For example: (funcall (cadr elem))))))) ;; Dynamic variables. -(eval-when-compile - (defvar part-number) - (defvar total-parts) - (defvar type) - (defvar condition) - (defvar length)) +(defvar part-number) +(defvar total-parts) +(defvar type) +(defvar condition) +(defvar length) (defun gnus-treat-predicate (val) (cond @@ -7965,6 +8307,11 @@ For example: gnus-article-encrypt-protocol-alist nil t)) current-prefix-arg)) + ;; User might hit `K E' instead of `K e', so prompt once. + (when (and gnus-article-encrypt-protocol + gnus-novice-user) + (unless (gnus-y-or-n-p "Really encrypt article(s)? ") + (error "Encrypt aborted."))) (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) (unless func (error "Can't find the encrypt protocol %s" protocol)) @@ -7974,8 +8321,7 @@ For example: (error "Can't encrypt the article in group %s" gnus-newsgroup-name)) (gnus-summary-iterate n - (save-excursion - (set-buffer gnus-summary-buffer) + (with-current-buffer gnus-summary-buffer (let ((mail-parse-charset gnus-newsgroup-charset) (mail-parse-ignored-charsets gnus-newsgroup-ignored-charsets) (summary-buffer gnus-summary-buffer) @@ -8021,9 +8367,8 @@ For example: (when gnus-keep-backlog (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) - (save-excursion - (when (get-buffer gnus-original-article-buffer) - (set-buffer gnus-original-article-buffer) + (when (get-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer (setq gnus-original-article nil))) (when gnus-use-cache (gnus-cache-update-article @@ -8274,5 +8619,5 @@ For example: (run-hooks 'gnus-art-load-hook) -;;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33 +;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33 ;;; gnus-art.el ends here