X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fgnus-art.el;h=530e72ff5ea79a8bcab5037e8fa54180ed8de4d1;hp=b55a0d4a6a4486087bf92086077619ce343b1faf;hb=b7df893161350265e845a70d711a97a32536a221;hpb=2be417e643b24869731422d0c996f8310e96714e diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index b55a0d4a6..530e72ff5 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, 2008 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010 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,15 +19,13 @@ ;; 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. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (eval-when-compile @@ -36,10 +34,7 @@ (defvar w3m-minor-mode-map) (require 'gnus) -;; Avoid the "Recursive load suspected" error in Emacs 21.1. -(eval-and-compile - (let ((recursive-load-depth-limit 100)) - (require 'gnus-sum))) +(require 'gnus-sum) (require 'gnus-spec) (require 'gnus-int) (require 'gnus-win) @@ -178,12 +173,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 @@ -536,6 +534,7 @@ that the symbol of the saver function, which is specified by :group 'gnus-article-saving :type 'regexp) +;; Note that "Rmail format" is mbox since Emacs 23, but Babyl before. (defcustom gnus-default-article-saver 'gnus-summary-save-in-rmail "A function to save articles in your favourite format. The function will be called by way of the `gnus-summary-save-article' @@ -551,13 +550,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 @@ -580,6 +581,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 @@ -722,8 +724,8 @@ Each element is a regular expression." :type '(repeat regexp) :group 'gnus-article-various) -(make-obsolete-variable 'gnus-article-hide-pgp-hook - "This variable is obsolete in Gnus 5.10.") +(make-obsolete-variable 'gnus-article-hide-pgp-hook nil + "Gnus 5.10 (Emacs 22.1)") (defface gnus-button '((t (:weight bold))) @@ -761,6 +763,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." :group 'gnus-article-signature) ;; backward-compatibility alias (put 'gnus-signature-face 'face-alias 'gnus-signature) +(put 'gnus-signature-face 'obsolete-face "22.1") (defface gnus-header-from '((((class color) @@ -776,6 +779,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." :group 'gnus-article-highlight) ;; backward-compatibility alias (put 'gnus-header-from-face 'face-alias 'gnus-header-from) +(put 'gnus-header-from-face 'obsolete-face "22.1") (defface gnus-header-subject '((((class color) @@ -791,6 +795,7 @@ Obsolete; use the face `gnus-signature' for customizations instead." :group 'gnus-article-highlight) ;; backward-compatibility alias (put 'gnus-header-subject-face 'face-alias 'gnus-header-subject) +(put 'gnus-header-subject-face 'obsolete-face "22.1") (defface gnus-header-newsgroups '((((class color) @@ -808,6 +813,7 @@ articles." :group 'gnus-article-highlight) ;; backward-compatibility alias (put 'gnus-header-newsgroups-face 'face-alias 'gnus-header-newsgroups) +(put 'gnus-header-newsgroups-face 'obsolete-face "22.1") (defface gnus-header-name '((((class color) @@ -823,6 +829,7 @@ articles." :group 'gnus-article-highlight) ;; backward-compatibility alias (put 'gnus-header-name-face 'face-alias 'gnus-header-name) +(put 'gnus-header-name-face 'obsolete-face "22.1") (defface gnus-header-content '((((class color) @@ -837,6 +844,7 @@ articles." :group 'gnus-article-highlight) ;; backward-compatibility alias (put 'gnus-header-content-face 'face-alias 'gnus-header-content) +(put 'gnus-header-content-face 'obsolete-face "22.1") (defcustom gnus-header-face-alist '(("From" nil gnus-header-from) @@ -908,25 +916,25 @@ image type in XEmacs if it is built with the libcompface library." "Function used to decode addresses.") (defvar gnus-article-dumbquotes-map - '(("\200" "EUR") - ("\202" ",") - ("\203" "f") - ("\204" ",,") - ("\205" "...") - ("\213" "<") - ("\214" "OE") - ("\221" "`") - ("\222" "'") - ("\223" "``") - ("\224" "\"") - ("\225" "*") - ("\226" "-") - ("\227" "--") - ("\230" "~") - ("\231" "(TM)") - ("\233" ">") - ("\234" "oe") - ("\264" "'")) + '((?\200 "EUR") + (?\202 ",") + (?\203 "f") + (?\204 ",,") + (?\205 "...") + (?\213 "<") + (?\214 "OE") + (?\221 "`") + (?\222 "'") + (?\223 "``") + (?\224 "\"") + (?\225 "*") + (?\226 "-") + (?\227 "--") + (?\230 "~") + (?\231 "(TM)") + (?\233 ">") + (?\234 "oe") + (?\264 "'")) "Table for MS-to-Latin1 translation.") (defcustom gnus-ignored-mime-types nil @@ -1212,8 +1220,8 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) -(make-obsolete-variable 'gnus-treat-strip-pgp - "This option is obsolete in Gnus 5.10.") +(make-obsolete-variable 'gnus-treat-strip-pgp nil + "Gnus 5.10 (Emacs 22.1)") (defcustom gnus-treat-strip-pem nil "Strip PEM signatures. @@ -1404,15 +1412,19 @@ predicate. See Info node `(gnus)Customizing Articles'." :type gnus-article-treat-custom) (make-obsolete-variable 'gnus-treat-display-xface - 'gnus-treat-display-x-face) + 'gnus-treat-display-x-face "Emacs 22.1") (defcustom gnus-treat-display-x-face (and (not noninteractive) (gnus-image-type-available-p 'xbm) (if (featurep 'xemacs) (featurep 'xface) - (and (string-match "^0x" (shell-command-to-string "uncompface")) - (executable-find "icontopbm"))) + (condition-case nil + (and (string-match "^0x" (shell-command-to-string "uncompface")) + (executable-find "icontopbm")) + ;; shell-command-to-string may signal an error, e.g. if + ;; shell-file-name is not found. + (error nil))) 'head) "Display X-Face headers. Valid values are nil and `head'. @@ -1449,7 +1461,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") @@ -1517,10 +1529,38 @@ node `(gnus)Picons' for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-newsgroups-picon 'highlight t) +(defcustom gnus-treat-from-gravatar nil + "Display gravatars in the From header. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Gravatars' for details." + :version "24.1" + :group 'gnus-article-treat + :group 'gnus-gravatar + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Gravatars") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-from-gravatar 'highlight t) + +(defcustom gnus-treat-mail-gravatar nil + "Display gravatars in To and Cc headers. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Gravatars' for details." + :version "24.1" + :group 'gnus-article-treat + :group 'gnus-gravatar + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Gravatars") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-mail-gravatar 'highlight t) + (defcustom gnus-treat-body-boundary (if (or gnus-treat-newsgroups-picon gnus-treat-mail-picon - gnus-treat-from-picon) + gnus-treat-from-picon + gnus-treat-from-gravatar + gnus-treat-mail-gravatar) ;; If there's much decoration, the user might prefer a boundery. 'head nil) @@ -1558,24 +1598,6 @@ predicate. See Info node `(gnus)Customizing Articles'." :link '(custom-manual "(gnus)Customizing Articles") :type gnus-article-treat-custom) -(defcustom gnus-treat-play-sounds nil - "Play sounds. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :version "21.1" - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) - -(defcustom gnus-treat-translate nil - "Translate articles from one language to another. -Valid values are nil, t, `head', `first', `last', an integer or a -predicate. See Info node `(gnus)Customizing Articles'." - :version "21.1" - :group 'gnus-article-treat - :link '(custom-manual "(gnus)Customizing Articles") - :type gnus-article-treat-custom) - (defcustom gnus-treat-x-pgp-sig nil "Verify X-PGP-Sig. To automatically treat X-PGP-Sig, set it to head. @@ -1599,9 +1621,6 @@ It is a string, such as \"PGP\". If nil, ask user." :type 'string :group 'mime-security) -(defvar gnus-article-wash-function nil - "Function used for converting HTML into text.") - (defcustom gnus-use-idna (and (condition-case nil (require 'idna) (file-error)) (mm-coding-system-p 'utf-8) (executable-find idna-program)) @@ -1617,6 +1636,15 @@ This requires GNU Libidn, and by default only enabled if it is found." :group 'gnus-article :type 'boolean) +(defcustom gnus-blocked-images 'gnus-block-private-groups + "Images that have URLs matching this regexp will be blocked. +This can also be a function to be evaluated. If so, it will be +called with the group name as the parameter, and should return a +regexp." + :version "24.1" + :group 'gnus-art + :type 'regexp) + ;;; Internal variables (defvar gnus-english-month-names @@ -1653,10 +1681,12 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-hide-signature gnus-article-hide-signature) (gnus-treat-strip-list-identifiers gnus-article-hide-list-identifiers) (gnus-treat-leading-whitespace gnus-article-remove-leading-whitespace) - (gnus-treat-strip-pem gnus-article-hide-pem) (gnus-treat-from-picon gnus-treat-from-picon) (gnus-treat-mail-picon gnus-treat-mail-picon) (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) + (gnus-treat-strip-pem gnus-article-hide-pem) + (gnus-treat-from-gravatar gnus-treat-from-gravatar) + (gnus-treat-mail-gravatar gnus-treat-mail-gravatar) (gnus-treat-highlight-headers gnus-article-highlight-headers) (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-strip-trailing-blank-lines @@ -1678,8 +1708,7 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-hide-citation gnus-article-hide-citation) (gnus-treat-hide-citation-maybe gnus-article-hide-citation-maybe) (gnus-treat-highlight-citation gnus-article-highlight-citation) - (gnus-treat-body-boundary gnus-article-treat-body-boundary) - (gnus-treat-play-sounds gnus-earcon-display))) + (gnus-treat-body-boundary gnus-article-treat-body-boundary))) (defvar gnus-article-mime-handle-alist nil) (defvar article-lapsed-timer nil) @@ -1700,11 +1729,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) @@ -2114,9 +2138,18 @@ MAP is an alist where the elements are on the form (\"from\" \"to\")." (when (article-goto-body) (let ((inhibit-read-only t)) (dolist (elem map) - (save-excursion - (while (search-forward (car elem) nil t) - (replace-match (cadr elem))))))))) + (let ((from (car elem)) + (to (cadr elem))) + (save-excursion + (if (stringp from) + (while (search-forward from nil t) + (replace-match to)) + (while (not (eobp)) + (if (eq (following-char) from) + (progn + (delete-char 1) + (insert to)) + (forward-char 1))))))))))) (defun article-treat-overstrike () "Translate overstrikes into bold text." @@ -2236,7 +2269,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)) @@ -2267,9 +2300,9 @@ long lines iff arg is positive." (insert "X-Boundary: ") (gnus-add-text-properties start (point) '(invisible t intangible t)) (insert (let (str) - (while (>= (1- (window-width)) (length str)) + (while (>= (window-width) (length str)) (setq str (concat str gnus-body-boundary-delimiter))) - (substring str 0 (1- (window-width)))) + (substring str 0 (window-width))) "\n") (gnus-put-text-property start (point) 'gnus-decoration 'header))))) @@ -2661,99 +2694,16 @@ If READ-CHARSET, ask for a coding system." (when (interactive-p) (gnus-treat-article nil)))) - -(defun article-wash-html (&optional read-charset) - "Format an HTML article. -If READ-CHARSET, ask for a coding system. If it is a number, the -charset defined in `gnus-summary-show-article-charset-alist' is used." - (interactive "P") - (save-excursion - (let ((inhibit-read-only t) - charset) - (if read-charset - (if (or (and (numberp read-charset) - (setq charset - (cdr - (assq read-charset - gnus-summary-show-article-charset-alist)))) - (setq charset (mm-read-coding-system "Charset: "))) - (let ((gnus-summary-show-article-charset-alist - (list (cons 1 charset)))) - (with-current-buffer gnus-summary-buffer - (gnus-summary-show-article 1))) - (error "No charset is given")) - (when (gnus-buffer-live-p gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (let* ((ct (gnus-fetch-field "content-type")) - (ctl (and ct (mail-header-parse-content-type ct)))) - (setq charset (and ctl - (mail-content-type-get ctl 'charset))) - (when (stringp charset) - (setq charset (intern (downcase charset))))))) - (unless charset - (setq charset gnus-newsgroup-charset))) - (article-goto-body) - (save-window-excursion - (save-restriction - (narrow-to-region (point) (point-max)) - (let* ((func (or gnus-article-wash-function mm-text-html-renderer)) - (entry (assq func mm-text-html-washer-alist))) - (when entry - (setq func (cdr entry))) - (cond - ((functionp func) - (funcall func)) - (t - (apply (car func) (cdr func)))))))))) - -;; 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) - (let ((w3-strict-width (window-width)) - (url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil)) - (condition-case () - (w3-region (point-min) (point-max)) - (error)))) - -;; 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))) - (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)))) - -(defvar charset) ;; Bound by `article-wash-html'. - -(defun gnus-article-wash-html-with-w3m-standalone () - "Wash the current buffer with w3m." - (if (mm-w3m-standalone-supports-m17n-p) - (progn - (unless (mm-coding-system-p charset) ;; Bound by `article-wash-html'. - ;; The default. - (setq charset 'iso-8859-1)) - (let ((coding-system-for-write charset) - (coding-system-for-read charset)) - (call-process-region - (point-min) (point-max) - "w3m" t t nil "-dump" "-T" "text/html" - "-I" (symbol-name charset) "-O" (symbol-name charset)))) - (mm-inline-wash-with-stdin nil "w3m" "-dump" "-T" "text/html"))) +(defun article-wash-html () + "Format an HTML article." + (interactive) + (let ((handles nil) + (buffer-read-only nil)) + (when (gnus-buffer-live-p gnus-original-article-buffer) + (setq handles (mm-dissect-buffer t t))) + (article-goto-body) + (delete-region (point) (point-max)) + (mm-inline-text-html handles))) (defvar gnus-article-browse-html-temp-list nil "List of temporary files created by `gnus-article-browse-html-parts'. @@ -2777,31 +2727,66 @@ summary buffer." (defun gnus-article-browse-delete-temp-files (&optional how) "Delete temp-files created by `gnus-article-browse-html-parts'." (when (and gnus-article-browse-html-temp-list - (or how - (setq how gnus-article-browse-delete-temp))) - (when (and (eq how 'ask) - (gnus-y-or-n-p (format - "Delete all %s temporary HTML file(s)? " - (length gnus-article-browse-html-temp-list))) - (setq how t))) + (progn + (or how (setq how gnus-article-browse-delete-temp)) + (if (eq how 'ask) + (let ((files (length gnus-article-browse-html-temp-list))) + (gnus-y-or-n-p (format + "Delete all %s temporary HTML file%s? " + files + (if (> files 1) "s" "")))) + how))) (dolist (file gnus-article-browse-html-temp-list) - (when (and (file-exists-p file) - (or (eq how t) - ;; `how' is neither `nil', `ask' nor `t' (i.e. `file'): - (gnus-y-or-n-p - (format "Delete temporary HTML file `%s'? " file)))) - (delete-file file))) + (cond ((file-directory-p file) + (when (or (not (eq how 'file)) + (gnus-y-or-n-p + (format + "Delete temporary HTML file(s) in directory `%s'? " + (file-name-as-directory file)))) + (gnus-delete-directory file))) + ((file-exists-p file) + (when (or (not (eq how 'file)) + (gnus-y-or-n-p + (format "Delete temporary HTML file `%s'? " file))) + (delete-file file))))) ;; Also remove file from the list when not deleted or if file doesn't ;; exist anymore. (setq gnus-article-browse-html-temp-list nil)) gnus-article-browse-html-temp-list) +(defun gnus-article-browse-html-save-cid-content (cid handles directory) + "Find CID content in HANDLES and save it in a file in DIRECTORY. +Return file name." + (save-match-data + (let (file type) + (catch 'found + (dolist (handle handles) + (cond + ((not (listp handle))) + ((equal (mm-handle-media-supertype handle) "multipart") + (when (setq file (gnus-article-browse-html-save-cid-content + cid handle directory)) + (throw 'found file))) + ((equal (concat "<" cid ">") (mm-handle-id handle)) + (setq file + (expand-file-name + (or (mail-content-type-get + (mm-handle-disposition handle) 'filename) + (mail-content-type-get + (setq type (mm-handle-type handle)) 'name) + (concat + (make-temp-name "cid") + (car (rassoc (car type) mailcap-mime-extensions)))) + directory)) + (mm-save-part-to-file handle file) + (throw 'found file)))))))) + (defun gnus-article-browse-html-parts (list &optional header) "View all \"text/html\" parts from LIST. 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 (type file charset tmp-file showed) + (let (type file charset content cid-dir tmp-file showed) ;; Find and show the html-parts. (dolist (handle list) ;; If HTML, show it: @@ -2824,16 +2809,42 @@ message header will be added to the bodies of the \"text/html\" parts." (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 charset (mail-content-type-get type 'charset) + content (mm-get-part handle)) + (with-temp-buffer + (if (eq charset 'gnus-decoded) + (mm-enable-multibyte) + (mm-disable-multibyte)) + (insert content) + ;; resolve cid contents + (let ((case-fold-search t) + cid-file) + (goto-char (point-min)) + (while (re-search-forward "\ +]+[\t\n ]+\\)*src=\"\\(cid:\\([^\"]+\\)\\)\"" + nil t) + (unless cid-dir + (setq cid-dir (mm-make-temp-file "cid" t)) + (add-to-list 'gnus-article-browse-html-temp-list cid-dir)) + (setq file nil + content nil) + (when (setq cid-file + (gnus-article-browse-html-save-cid-content + (match-string 2) + (with-current-buffer gnus-article-buffer + gnus-article-mime-handles) + cid-dir)) + (replace-match (concat "file://" cid-file) + nil nil nil 1)))) + (unless content (setq content (buffer-string)))) + (when (or 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) + (let (title eheader body hcharset coding force-charset) (with-temp-buffer (mm-enable-multibyte) (setq case-fold-search t) @@ -2856,8 +2867,8 @@ message header will be added to the bodies of the \"text/html\" parts." charset) title (when title (mm-encode-coding-string title charset)) - body (mm-encode-coding-string (mm-get-part handle) - charset)) + body (mm-encode-coding-string content charset) + force-charset t) (setq hcharset (mm-find-mime-charset-region (point-min) (point-max))) (cond ((= (length hcharset) 1) @@ -2878,7 +2889,7 @@ message header will be added to the bodies of the \"text/html\" parts." title (when title (mm-encode-coding-string title coding)) - body (mm-get-part handle)) + body content) (setq charset 'utf-8 eheader (mm-encode-coding-string (buffer-string) charset) @@ -2887,22 +2898,23 @@ message header will be added to the bodies of the \"text/html\" parts." title charset)) body (mm-encode-coding-string (mm-decode-coding-string - (mm-get-part handle) body) - charset)))) + content body) + charset) + force-charset t))) (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))) + body content)) (setq eheader (mm-string-as-unibyte (buffer-string)) - body (mm-get-part handle)))) + body content))) (erase-buffer) (mm-disable-multibyte) (insert body) (when charset - (mm-add-meta-html-tag handle charset)) + (mm-add-meta-html-tag handle charset force-charset)) (when title (goto-char (point-min)) (unless (search-forward "" nil t) @@ -2919,10 +2931,9 @@ message header will be added to the bodies of the \"text/html\" parts." (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))) + (mm-encode-coding-string content + (setq charset 'utf-8)) + content)) (if (or (mm-add-meta-html-tag handle charset) (not file)) (mm-write-region (point-min) (point-max) @@ -2967,26 +2978,33 @@ message header will be added to the bodies of the \"text/html\" parts." (setq showed t))))) showed)) -;; FIXME: Documentation in texi/gnus.texi missing. (defun gnus-article-browse-html-article (&optional arg) "View \"text/html\" parts of the current article with a WWW browser. +Inline images embedded in a message using the cid scheme, as they are +generally considered to be safe, will be processed properly. 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. +Warning: Spammers use links to images (using the http scheme) in HTML +articles to verify whether you have read the message. As +`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 -`mm-text-html-renderer' to nil." +If you always want to display HTML parts in the browser, set +`mm-text-html-renderer' to nil. + +This command creates temporary files to pass HTML contents including +images if any to the browser, and deletes them when exiting the group +\(if you want)." ;; Cf. `mm-w3m-safe-url-regexp' (interactive "P") (if arg (gnus-summary-show-article) (let ((gnus-visible-headers (or (get 'gnus-visible-headers 'standard-value) - gnus-visible-headers))) + gnus-visible-headers)) + ;; As we insert a <hr>, 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 @@ -3385,9 +3403,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) @@ -3715,7 +3739,8 @@ 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)) + ;; Ignore group parameter. See `article-hide-headers'. + (gnus-summary-buffer nil)) (with-current-buffer save-buffer (article-hide-headers 1 t)))) (save-window-excursion @@ -3846,10 +3871,13 @@ Directory to save to is default to `gnus-article-save-directory'." "Save %s in rmail file" filename gnus-rmail-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-rmail)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) + ;; Note that unlike gnus-summary-save-in-mail, there is no + ;; check to see if filename is Babyl. Rmail in Emacs 23 does + ;; not use Babyl. (gnus-output-to-rmail filename)))) filename) @@ -3861,14 +3889,14 @@ Directory to save to is default to `gnus-article-save-directory'." "Save %s in Unix mail file" filename gnus-mail-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-mail)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) (if (and (file-readable-p filename) (file-regular-p filename) (mail-file-babyl-p filename)) - (rmail-output-to-rmail-file filename t) + (gnus-output-to-rmail filename) (gnus-output-to-mail filename))))) filename) @@ -3882,7 +3910,7 @@ Directory to save to is default to `gnus-article-save-directory'." "Save %s in file" filename gnus-file-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-file)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) @@ -3914,7 +3942,7 @@ The directory to save in defaults to `gnus-article-save-directory'." "Save %s body in file" filename gnus-file-save-name gnus-newsgroup-name gnus-current-headers 'gnus-newsgroup-last-file)) - (gnus-eval-in-buffer-window gnus-save-article-buffer + (with-current-buffer gnus-save-article-buffer (save-excursion (save-restriction (widen) @@ -3939,39 +3967,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"))) + (with-current-buffer 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. @@ -4114,6 +4180,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (put-text-property (match-end 0) (point-max) 'face eface))))))))) +(autoload 'canlock-verify "canlock" nil t) ;; for XEmacs. + (defun article-verify-cancel-lock () "Verify Cancel-Lock header." (interactive) @@ -4202,7 +4270,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is "s" gnus-article-show-summary "\C-c\C-m" gnus-article-mail "?" gnus-article-describe-briefly - "e" gnus-summary-edit-article "<" beginning-of-buffer ">" end-of-buffer "\C-c\C-i" gnus-info-find-node @@ -4213,6 +4280,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "\C-hc" gnus-article-describe-key-briefly "\C-hb" gnus-article-describe-bindings + "e" gnus-article-read-summary-keys "\C-d" gnus-article-read-summary-keys "\M-*" gnus-article-read-summary-keys "\M-#" gnus-article-read-summary-keys @@ -4232,7 +4300,6 @@ If variable `gnus-use-long-file-name' is non-nil, it is (defun gnus-article-make-menu-bar () (unless (boundp 'gnus-article-commands-menu) (gnus-summary-make-menu-bar)) - (gnus-turn-off-edit-menu 'article) (unless (boundp 'gnus-article-article-menu) (easy-menu-define gnus-article-article-menu gnus-article-mode-map "" @@ -4267,6 +4334,8 @@ If variable `gnus-use-long-file-name' is non-nil, it is (gnus-run-hooks 'gnus-article-menu-hook))) +(defvar bookmark-make-record-function) + (defun gnus-article-mode () "Major mode for displaying an article. @@ -4305,11 +4374,12 @@ commands: (make-local-variable 'gnus-article-image-alist) (make-local-variable 'gnus-article-charset) (make-local-variable 'gnus-article-ignored-charsets) + (set (make-local-variable 'bookmark-make-record-function) + 'gnus-summary-bookmark-make-record) ;; 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 @@ -4369,9 +4439,11 @@ Internal variable.") (setq gnus-button-marker-list nil) (unless (eq major-mode 'gnus-article-mode) (gnus-article-mode)) + (setq truncate-lines gnus-article-truncate-lines) (current-buffer)) (with-current-buffer (gnus-get-buffer-create name) (gnus-article-mode) + (setq truncate-lines gnus-article-truncate-lines) (make-local-variable 'gnus-summary-buffer) (setq gnus-summary-buffer (gnus-summary-buffer-name gnus-newsgroup-name)) @@ -4672,6 +4744,43 @@ General format specifiers can also be used. See Info node (vector (caddr c) (car c) :active t)) gnus-mime-button-commands))) +(defvar gnus-url-button-commands + '((gnus-article-copy-string "u" "Copy URL to kill ring"))) + +(defvar gnus-url-button-map + (let ((map (make-sparse-keymap))) + (dolist (c gnus-url-button-commands) + (define-key map (cadr c) (car c))) + map)) + +(easy-menu-define + gnus-url-button-menu gnus-url-button-map "URL button menu." + `("Url Button" + ,@(mapcar (lambda (c) + (vector (caddr c) (car c) :active t)) + gnus-url-button-commands))) + +(defmacro gnus-bind-safe-url-regexp (&rest body) + "Bind `mm-w3m-safe-url-regexp' according to `gnus-safe-html-newsgroups'." + `(let ((mm-w3m-safe-url-regexp + (let ((group (if (and (eq major-mode 'gnus-article-mode) + (gnus-buffer-live-p + gnus-article-current-summary)) + (with-current-buffer gnus-article-current-summary + gnus-newsgroup-name) + gnus-newsgroup-name))) + (if (cond ((not group) + ;; Maybe we're in a mml-preview buffer + ;; and no group is selected. + t) + ((stringp gnus-safe-html-newsgroups) + (string-match gnus-safe-html-newsgroups group)) + ((consp gnus-safe-html-newsgroups) + (member group gnus-safe-html-newsgroups))) + nil + mm-w3m-safe-url-regexp)))) + ,@body)) + (defun gnus-mime-button-menu (event prefix) "Construct a context-sensitive menu of MIME commands." (interactive "e\nP") @@ -4697,7 +4806,7 @@ General format specifiers can also be used. See Info node (or (search-forward "\n\n") (goto-char (point-max))) (let ((inhibit-read-only t)) (delete-region (point) (point-max)) - (mm-display-parts handles)))))) + (gnus-bind-safe-url-regexp (mm-display-parts handles))))))) (defun gnus-article-jump-to-part (n) "Jump to MIME part N." @@ -4706,10 +4815,7 @@ General format specifiers can also be used. See Info node ;; FIXME: why is it necessary? (sit-for 0) (let ((parts (length gnus-article-mime-handle-alist))) - (or n (setq n - (string-to-number - (read-string ;; Emacs 21 doesn't have `read-number'. - (format "Jump to part (2..%s): " parts))))) + (or n (setq n (read-number (format "Jump to part (2..%s): " parts)))) (unless (and (integerp n) (<= n parts) (>= n 1)) (setq n (progn @@ -4728,6 +4834,10 @@ General format specifiers can also be used. See Info node (t (gnus-article-goto-part n))))) +(defvar gnus-mime-buttonized-part-id nil + "ID of a mime part that should be buttonized. +`gnus-mime-save-part-and-strip' and `gnus-mime-delete-part' bind it.") + (eval-when-compile (defsubst gnus-article-edit-part (handles &optional current-id) "Edit an article in order to delete a mime part. @@ -4770,26 +4880,24 @@ and `gnus-mime-delete-part', and not provided at run-time normally." ,(gnus-group-read-only-p) ,gnus-summary-buffer no-highlight)) t) - (gnus-article-edit-done) - (gnus-summary-expand-window) - (gnus-summary-show-article) + ;; Force buttonizing this part. + (let ((gnus-mime-buttonized-part-id current-id)) + (gnus-article-edit-done)) + (gnus-configure-windows 'article) (when (and current-id (integerp gnus-auto-select-part)) (gnus-article-jump-to-part - (if (text-property-any (point-min) (point-max) - 'gnus-part (+ current-id gnus-auto-select-part)) - (+ current-id gnus-auto-select-part) - (with-current-buffer gnus-article-buffer - (length gnus-article-mime-handle-alist))))))) + (min (max (+ current-id gnus-auto-select-part) 1) + (with-current-buffer gnus-article-buffer + (length gnus-article-mime-handle-alist))))))) (defun gnus-mime-replace-part (file) "Replace MIME part under point with an external body." ;; Useful if file has already been saved to disk (interactive (list - (mm-with-multibyte - (read-file-name "Replace MIME part with file: " - (or mm-default-directory default-directory) - nil nil)))) + (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) @@ -4861,7 +4969,7 @@ Deleting parts may malfunction or destroy the article; continue? ")) (unless data (error "No MIME part under point")) (with-current-buffer (mm-handle-buffer data) - (let ((bsize (format "%s" (buffer-size)))) + (let ((bsize (buffer-size))) (erase-buffer) (insert (concat @@ -4870,13 +4978,16 @@ Deleting parts may malfunction or destroy the article; continue? ")) "|\n" "| Type: " type "\n" "| Filename: " filename "\n" - "| Size (encoded): " bsize " Byte\n" + "| Size (encoded): " (format "%s byte%s\n" + bsize (if (= bsize 1) + "" + "s")) (when description (concat "| Description: " description "\n")) "`----\n")) (setcdr data (cdr (mm-make-handle - nil `("text/plain") nil nil + nil `("text/plain" (charset . gnus-decoded)) nil nil (list "attachment") (format "Deleted attachment (%s bytes)" bsize)))))) ;; (set-buffer gnus-summary-buffer) @@ -4890,13 +5001,14 @@ Deleting parts may malfunction or destroy the article; continue? ")) (when data (mm-save-part data)))) -(defun gnus-mime-pipe-part () - "Pipe the MIME part under point to a process." +(defun gnus-mime-pipe-part (&optional cmd) + "Pipe the MIME part under point to a process. +Use CMD as the process." (interactive) (gnus-article-check-buffer) (let ((data (get-text-property (point) 'gnus-data))) (when data - (mm-pipe-part data)))) + (mm-pipe-part data cmd)))) (defun gnus-mime-view-part () "Interactively choose a viewing method for the MIME part under point." @@ -4932,11 +5044,12 @@ available media-types." (unless mime-type (setq mime-type (let ((default (gnus-mime-view-part-as-type-internal))) - (completing-read - (format "View as MIME type (default %s): " - (car default)) - (mapcar #'list (mailcap-mime-types)) - pred nil nil nil + (gnus-completing-read + "View as MIME type" + (if pred + (gnus-remove-if-not pred (mailcap-mime-types)) + (mailcap-mime-types)) + nil nil nil (car default))))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) @@ -5100,10 +5213,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 @@ -5111,9 +5228,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 @@ -5123,18 +5241,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))) @@ -5170,7 +5288,7 @@ specified charset." (mm-enable-external t)) (if (not (stringp method)) (gnus-mime-view-part-as-type - nil (lambda (types) (stringp (mailcap-mime-info (car types))))) + nil (lambda (type) (stringp (mailcap-mime-info type)))) (when handle (if (mm-handle-undisplayer handle) (mm-remove-part handle) @@ -5191,16 +5309,16 @@ If no internal viewer is available, use an external viewer." (inhibit-read-only t)) (if (not (mm-inlinable-p handle)) (gnus-mime-view-part-as-type - nil (lambda (types) (mm-inlinable-p handle (car types)))) + nil (lambda (type) (mm-inlinable-p handle type))) (when handle (if (mm-handle-undisplayer handle) (mm-remove-part handle) - (mm-display-part handle)))))) + (gnus-bind-safe-url-regexp (mm-display-part handle))))))) (defun gnus-mime-action-on-part (&optional action) "Do something with the MIME attachment at \(point\)." (interactive - (list (completing-read "Action: " gnus-mime-action-alist nil t))) + (list (gnus-completing-read "Action" (mapcar 'car gnus-mime-action-alist) t))) (gnus-article-check-buffer) (let ((action-pair (assoc action gnus-mime-action-alist))) (if action-pair @@ -5369,7 +5487,9 @@ N is the numerical prefix." 1)) (defun gnus-article-view-part (&optional n) - "View MIME part N, which is the numerical prefix." + "View MIME part N, which is the numerical prefix. +If the part is already shown, hide the part. If N is nil, view +all parts." (interactive "P") (with-current-buffer gnus-article-buffer (or (numberp n) (setq n (gnus-article-mime-match-handle-first @@ -5416,7 +5536,7 @@ N is the numerical prefix." (save-restriction (narrow-to-region (point) (if (eobp) (point) (1+ (point)))) - (mm-display-part handle) + (gnus-bind-safe-url-regexp (mm-display-part handle)) ;; We narrow to the part itself and ;; then call the treatment functions. (goto-char (point-min)) @@ -5483,7 +5603,7 @@ N is the numerical prefix." :action 'gnus-widget-press-button :button-keymap gnus-mime-button-map :help-echo - (lambda (widget/window &optional overlay pos) + (lambda (widget) ;; Needed to properly clear the message due to a bug in ;; wid-edit (XEmacs only). (if (boundp 'help-echo-owns-message) @@ -5491,14 +5611,7 @@ N is the numerical prefix." (format "%S: %s the MIME part; %S: more options" (aref gnus-mouse-2 0) - ;; XEmacs will get a single widget arg; Emacs 21 will get - ;; window, overlay, position. - (if (mm-handle-displayed-p - (if overlay - (with-current-buffer (gnus-overlay-buffer overlay) - (widget-get (widget-at (gnus-overlay-start overlay)) - :mime-handle)) - (widget-get widget/window :mime-handle))) + (if (mm-handle-displayed-p (widget-get widget :mime-handle)) "hide" "show") (aref gnus-down-mouse-3 0)))))) @@ -5677,7 +5790,8 @@ If displaying \"text/html\" is discouraged \(see ((or (bobp) (eq (char-before (1- (point))) ?\n)) 0) (t 1)))) (when (or (not display) - (not (gnus-unbuttonized-mime-type-p type))) + (not (gnus-unbuttonized-mime-type-p type)) + (eq id gnus-mime-buttonized-part-id)) (gnus-insert-mime-button handle id (list (or display (and not-attachment text)))) (gnus-article-insert-newline) @@ -5695,7 +5809,7 @@ If displaying \"text/html\" is discouraged \(see (set-buffer gnus-summary-buffer) (error)) gnus-newsgroup-ignored-charsets))) - (mm-display-part handle t)) + (gnus-bind-safe-url-regexp (mm-display-part handle t))) (goto-char (point-max))) ((and text not-attachment) (when move @@ -5831,7 +5945,7 @@ If displaying \"text/html\" is discouraged \(see (mail-parse-ignored-charsets (with-current-buffer gnus-summary-buffer gnus-newsgroup-ignored-charsets))) - (mm-display-part preferred) + (gnus-bind-safe-url-regexp (mm-display-part preferred)) ;; Do highlighting. (save-excursion (save-restriction @@ -5993,39 +6107,51 @@ If given a numerical ARG, move forward ARG pages." (interactive "P") (setq arg (if arg (prefix-numeric-value arg) 0)) (with-current-buffer gnus-article-buffer - (goto-char (point-min)) (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 @@ -6040,7 +6166,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))) @@ -6063,13 +6189,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. @@ -6091,29 +6216,24 @@ Argument LINES specifies lines to be scrolled up." (gnus-article-next-page-1 lines) nil)) -(defmacro gnus-article-beginning-of-window () +(defun gnus-article-beginning-of-window () "Move point to the beginning of the window. In Emacs, the point is placed at the line number which `scroll-margin' specifies." (if (featurep 'xemacs) - '(move-to-window-line 0) - '(move-to-window-line - (min (max 0 scroll-margin) - (max 1 (- (window-height) - (if mode-line-format 1 0) - (if header-line-format 1 0))))))) + (move-to-window-line 0) + ;; There is an obscure bug in Emacs that makes it impossible to + ;; scroll past big pictures in the article buffer. Try to fix + ;; this by adding a sanity check by counting the lines visible. + (when (> (count-lines (window-start) (window-end)) 30) + (move-to-window-line + (min (max 0 scroll-margin) + (max 1 (- (window-height) + (if mode-line-format 1 0) + (if header-line-format 1 0) + 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)) - ;; Protect against the bug that Emacs 21.x hangs up when scrolling up for - ;; too many number of lines if `scroll-margin' is set as two or greater. - (setq lines (min lines - (max 0 (- (count-lines (window-start) (point-max)) - (symbol-value 'scroll-margin)))))) (condition-case () (let ((scroll-in-place nil)) (scroll-up lines)) @@ -6135,9 +6255,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))) @@ -6192,28 +6312,7 @@ not have a face in `gnus-article-boring-faces'." (defun gnus-article-describe-briefly () "Describe article mode commands briefly." (interactive) - (gnus-message 6 (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) - -(defun gnus-article-summary-command () - "Execute the last keystroke in the summary buffer." - (interactive) - (let ((obuf (current-buffer)) - (owin (current-window-configuration)) - func) - (switch-to-buffer gnus-article-current-summary 'norecord) - (setq func (lookup-key (current-local-map) (this-command-keys))) - (call-interactively func) - (set-buffer obuf) - (set-window-configuration owin) - (set-window-point (get-buffer-window (current-buffer)) (point)))) - -(defun gnus-article-summary-command-nosave () - "Execute the last keystroke in the summary buffer." - (interactive) - (let (func) - (pop-to-buffer gnus-article-current-summary) - (setq func (lookup-key (current-local-map) (this-command-keys))) - (call-interactively func))) + (gnus-message 6 "%s" (substitute-command-keys "\\<gnus-article-mode-map>\\[gnus-article-goto-next-page]:Next page \\[gnus-article-goto-prev-page]:Prev page \\[gnus-article-show-summary]:Show summary \\[gnus-info-find-node]:Run Info \\[gnus-article-describe-briefly]:This help"))) (defun gnus-article-check-buffer () "Beep if not in an article buffer." @@ -6257,7 +6356,7 @@ not have a face in `gnus-article-boring-faces'." (pop-to-buffer gnus-article-current-summary) ;; We disable the pick minor mode commands. (let (gnus-pick-mode) - (setq func (lookup-key (current-local-map) keys)))) + (setq func (key-binding keys t)))) (if (or (not func) (numberp func)) (ding) @@ -6282,9 +6381,9 @@ not have a face in `gnus-article-boring-faces'." (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)))))) + '((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)) @@ -6292,7 +6391,7 @@ not have a face in `gnus-article-boring-faces'." (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))) + (key-binding keys t))) (functionp func) (condition-case code (progn @@ -6324,6 +6423,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) @@ -6385,6 +6485,11 @@ KEY is a string or a vector." ;;`gnus-agent-mode' in gnus-agent.el will define it. (defvar gnus-agent-summary-mode) (defvar gnus-draft-mode) +;; Calling help-buffer will autoload help-mode. +(defvar help-xref-stack-item) +;; Emacs 22 doesn't load it in the batch mode. +(eval-when-compile + (autoload 'help-buffer "help-mode")) (defun gnus-article-describe-bindings (&optional prefix) "Show a list of all defined keys, and their definitions. @@ -6395,10 +6500,17 @@ then we display only bindings that start with that prefix." (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) + parent agent draft) (define-key keymap "S" map) (define-key map [t] nil) (with-current-buffer gnus-article-current-summary + (set-keymap-parent + keymap + (if (setq parent (keymap-parent gnus-article-mode-map)) + (prog1 + (setq parent (copy-keymap parent)) + (set-keymap-parent parent (current-local-map))) + (current-local-map))) (set-keymap-parent map (key-binding "S")) (let (key def gnus-pick-mode) (while sumkeys @@ -6428,9 +6540,7 @@ then we display only bindings that start with that 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 + (with-current-buffer (let (help-xref-following) (help-buffer)) (setq help-xref-stack-item item))))) (defun gnus-article-reply-with-original (&optional wide) @@ -6575,7 +6685,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 @@ -6678,6 +6794,18 @@ If given a prefix, show the hidden text instead." (point)) (set-buffer buf)))))) +(defun gnus-block-private-groups (group) + (if (gnus-news-group-p group) + ;; Block nothing in news groups. + nil + ;; Block everything anywhere else. + ".")) + +(defun gnus-blocked-images () + (if (functionp gnus-blocked-images) + (funcall gnus-blocked-images gnus-newsgroup-name) + gnus-blocked-images)) + ;;; ;;; Article editing ;;; @@ -6821,9 +6949,7 @@ groups." (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) ;; Flush original article as well. - (when (get-buffer gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (setq gnus-original-article nil))) + (gnus-flush-original-article-buffer) (when gnus-use-cache (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current))) @@ -6837,6 +6963,11 @@ groups." (set-window-point (get-buffer-window buf) (point))) (gnus-summary-show-article)) +(defun gnus-flush-original-article-buffer () + (when (get-buffer gnus-original-article-buffer) + (with-current-buffer gnus-original-article-buffer + (setq gnus-original-article nil)))) + (defun gnus-article-edit-exit () "Exit the article editing without updating." (interactive) @@ -6887,7 +7018,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 "]" "\\)")) @@ -6924,46 +7056,6 @@ man page." (function :tag "Other")) :group 'gnus-article-buttons) -(defcustom gnus-ctan-url "http://tug.ctan.org/tex-archive/" - "Top directory of a CTAN \(Comprehensive TeX Archive Network\) archive. -If the default site is too slow, try to find a CTAN mirror, see -<URL:http://tug.ctan.org/tex-archive/CTAN.sites?action=/index.html>. See also -the variable `gnus-button-handle-ctan'." - :version "22.1" - :group 'gnus-article-buttons - :link '(custom-manual "(gnus)Group Parameters") - :type '(choice (const "http://www.tex.ac.uk/tex-archive/") - (const "http://tug.ctan.org/tex-archive/") - (const "http://www.dante.de/CTAN/") - (string :tag "Other"))) - -(defcustom gnus-button-ctan-handler 'browse-url - "Function to use for displaying CTAN links. -The function must take one argument, the string naming the URL." - :version "22.1" - :type '(choice (function-item :tag "Browse Url" browse-url) - (function :tag "Other")) - :group 'gnus-article-buttons) - -(defcustom gnus-button-handle-ctan-bogus-regexp "^/?tex-archive/\\|^/" - "Bogus strings removed from CTAN URLs." - :version "22.1" - :group 'gnus-article-buttons - :type '(choice (const "^/?tex-archive/\\|/") - (regexp :tag "Other"))) - -(defcustom gnus-button-ctan-directory-regexp - (regexp-opt - (list "archive-tools" "biblio" "bibliography" "digests" "documentation" - "dviware" "fonts" "graphics" "help" "indexing" "info" "language" - "languages" "macros" "nonfree" "obsolete" "support" "systems" - "tds" "tools" "usergrps" "web") t) - "Regular expression for ctan directories. -It should match all directories in the top level of `gnus-ctan-url'." - :version "22.1" - :group 'gnus-article-buttons - :type 'regexp) - (defcustom gnus-button-mid-or-mail-regexp (concat "\\b\\(<?" gnus-button-valid-localpart-regexp "@" gnus-button-valid-fqdn-regexp @@ -7221,26 +7313,6 @@ Calls `describe-variable' or `describe-function'." (gnus-message 1 "Cannot locale library `%s'." url) (find-file-read-only file)))) -(defun gnus-button-handle-ctan (url) - "Call `browse-url' when pushing a CTAN URL button." - (funcall - gnus-button-ctan-handler - (concat - gnus-ctan-url - (gnus-replace-in-string url gnus-button-handle-ctan-bogus-regexp "")))) - -(defcustom gnus-button-tex-level 5 - "*Integer that says how many TeX-related buttons Gnus will show. -The higher the number, the more buttons will appear and the more false -positives are possible. Note that you can set this variable local to -specific groups. Setting it higher in TeX groups is probably a good idea. -See Info node `(gnus)Group Parameters' and the variable `gnus-parameters' on -how to set variables in specific groups." - :version "22.1" - :group 'gnus-article-buttons - :link '(custom-manual "(gnus)Group Parameters") - :type 'integer) - (defcustom gnus-button-man-level 5 "*Integer that says how many man-related buttons Gnus will show. The higher the number, the more buttons will appear and the more false @@ -7307,21 +7379,11 @@ positives are possible." 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) ("\\bmailto:\\([^ \n\t]+\\)" 0 (>= gnus-button-message-level 0) gnus-url-mailto 1) - ;; CTAN - ((concat "\\bCTAN:[ \t\n]?[^>)!;:,'\n\t ]*\\(" - gnus-button-ctan-directory-regexp - "[^][>)!;:,'\n\t ]+\\)") - 0 (>= gnus-button-tex-level 1) gnus-button-handle-ctan 1) - ((concat "\\btex-archive/\\(" - gnus-button-ctan-directory-regexp - "/[-_.a-z0-9/]+[-_./a-z0-9]+[/a-z0-9]\\)") - 1 (>= gnus-button-tex-level 6) gnus-button-handle-ctan 1) - ((concat - "\\b\\(" - gnus-button-ctan-directory-regexp - "/[-_.a-z0-9]+/[-_./a-z0-9]+[/a-z0-9]\\)") - 1 (>= gnus-button-tex-level 8) gnus-button-handle-ctan 1) - ;; This is info (home-grown style) <info://foo/bar+baz> + ;; Info Konqueror style <info:/foo/bar baz>. + ;; Must come before " Gnus home-grown style". + ("\\binfo://?\\([^'\">\n\t]+\\)" + 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) + ;; Info, Gnus home-grown style (deprecated) <info://foo/bar+baz> ("\\binfo://\\([^'\">\n\t ]+\\)" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-url 1) ;; Info GNOME style <info:foo#bar_baz> @@ -7332,9 +7394,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\\|<?[Ff]1>?\\)[ \t\n]+i[ \t\n]+d?[ \t\n]?m[ \t\n]+\\([^ ]+ ?[^ ]+\\)[ \t\n]+RET" - ;; Info links like `C-h i d m CC Mode RET' - 0 (>= gnus-button-emacs-level 1) gnus-button-handle-info-keystrokes 2) + ("\\b\\(C-h\\|<?[Ff]1>?\\)[ \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) @@ -7615,7 +7677,11 @@ specified by `gnus-button-alist'." (unless (and (eq (car entry) 'gnus-button-url-regexp) (gnus-article-extend-url-button from start end)) (gnus-article-add-button start end - 'gnus-button-push from))))))))) + 'gnus-button-push from) + (gnus-put-text-property + start end + 'gnus-string (buffer-substring-no-properties + start end)))))))))) (defun gnus-article-extend-url-button (beg start end) "Extend url button if url is folded into two or more lines. @@ -7707,7 +7773,7 @@ url is put as the `gnus-button-url' overlay property on the button." ;;; External functions: -(defun gnus-article-add-button (from to fun &optional data) +(defun gnus-article-add-button (from to fun &optional data text) "Create a button between FROM and TO with callback FUN and data DATA." (when gnus-article-button-face (gnus-overlay-put (gnus-make-overlay from to nil t) @@ -7719,8 +7785,21 @@ url is put as the `gnus-button-url' overlay property on the button." (list 'gnus-callback fun) (and data (list 'gnus-data data)))) (widget-convert-button 'link from to :action 'gnus-widget-press-button + :help-echo (or text "Follow the link") + :keymap gnus-url-button-map :button-keymap gnus-widget-button-keymap)) +(defun gnus-article-copy-string () + "Copy the string in the button to the kill ring." + (interactive) + (gnus-article-check-buffer) + (let ((data (get-text-property (point) 'gnus-string))) + (when data + (with-temp-buffer + (insert data) + (copy-region-as-kill (point-min) (point-max)) + (message "Copied %s" data))))) + ;;; Internal functions: (defun gnus-article-set-globals () @@ -7834,7 +7913,8 @@ url is put as the `gnus-button-url' overlay property on the button." (unless file (error "Couldn't find library %s" library)) (find-file file) - (goto-line (string-to-number line)))) + (goto-char (point-min)) + (forward-line (1- (string-to-number line))))) (defun gnus-button-handle-man (url) "Fetch a man page." @@ -7880,13 +7960,40 @@ url is put as the `gnus-button-url' overlay property on the button." ;; (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\\|<?[Ff]1>?\\)[ \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)) @@ -7991,9 +8098,6 @@ url is put as the `gnus-button-url' overlay property on the button." (defvar gnus-next-page-map (let ((map (make-sparse-keymap))) - (unless (>= emacs-major-version 21) - ;; XEmacs doesn't care. - (set-keymap-parent map gnus-article-mode-map)) (define-key map gnus-mouse-2 'gnus-button-next-page) (define-key map "\r" 'gnus-button-next-page) map)) @@ -8189,15 +8293,15 @@ For example: (interactive (list (or gnus-article-encrypt-protocol - (completing-read "Encrypt protocol: " - gnus-article-encrypt-protocol-alist - nil t)) + (gnus-completing-read "Encrypt protocol" + (mapcar 'car gnus-article-encrypt-protocol-alist) + 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."))) + (error "Encrypt aborted"))) (let ((func (cdr (assoc protocol gnus-article-encrypt-protocol-alist)))) (unless func (error "Can't find the encrypt protocol %s" protocol)) @@ -8253,9 +8357,7 @@ For example: (when gnus-keep-backlog (gnus-backlog-remove-article (car gnus-article-current) (cdr gnus-article-current))) - (when (get-buffer gnus-original-article-buffer) - (with-current-buffer gnus-original-article-buffer - (setq gnus-original-article nil))) + (gnus-flush-original-article-buffer) (when gnus-use-cache (gnus-cache-update-article (car gnus-article-current) (cdr gnus-article-current)))))))) @@ -8443,7 +8545,7 @@ For example: :action 'gnus-widget-press-button :button-keymap gnus-mime-security-button-map :help-echo - (lambda (widget/window &optional overlay pos) + (lambda (widget) ;; Needed to properly clear the message due to a bug in ;; wid-edit (XEmacs only). (when (boundp 'help-echo-owns-message) @@ -8505,5 +8607,4 @@ For example: (run-hooks 'gnus-art-load-hook) -;; arch-tag: 2654516f-6279-48f9-a83b-05c1fa450c33 ;;; gnus-art.el ends here