diff options
Diffstat (limited to 'lisp/gnus')
30 files changed, 337 insertions, 612 deletions
diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index 4788deba5d..8043620c6b 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -459,10 +459,7 @@ manipulated as follows: (let ((def (or (gnus-group-group-name) gnus-newsgroup-name))) (when def (setq def (gnus-group-decoded-name def))) - (gnus-group-completing-read (if def - (concat "Group Name (" def "): ") - "Group Name: ") - nil nil t nil nil def))) + (gnus-group-completing-read nil nil t nil nil def))) ;;; Fetching setup functions. @@ -816,9 +813,9 @@ be a select method." (interactive (list (intern - (completing-read - "Add to category: " - (mapcar (lambda (cat) (list (symbol-name (car cat)))) + (gnus-completing-read + "Add to category" + (mapcar (lambda (cat) (symbol-name (car cat))) gnus-category-alist) nil t)) current-prefix-arg)) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 6e5cd4d8d1..4e2d43cc65 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -5131,11 +5131,10 @@ 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" + (remove-if-not pred (mailcap-mime-types)) + nil nil nil (car default))))) (gnus-article-check-buffer) (let ((handle (get-text-property (point) 'gnus-data))) @@ -5404,7 +5403,7 @@ If no internal viewer is available, use an external viewer." (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 @@ -8370,9 +8369,9 @@ 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 diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index 137479b4e7..423750893d 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -289,8 +289,8 @@ So the cdr of each bookmark is an alist too.") (interactive) (gnus-bookmark-maybe-load-default-file) (let* ((bookmark (or bmk-name - (completing-read "Jump to bookmarked article: " - gnus-bookmark-alist))) + (gnus-completing-read "Jump to bookmarked article" + (mapcar 'car gnus-bookmark-alist)))) (bmk-record (cadr (assoc bookmark gnus-bookmark-alist))) (group (cdr (assoc 'group bmk-record))) (message-id (cdr (assoc 'message-id bmk-record)))) diff --git a/lisp/gnus/gnus-diary.el b/lisp/gnus/gnus-diary.el index 18130bbb0f..76d469b66f 100644 --- a/lisp/gnus/gnus-diary.el +++ b/lisp/gnus/gnus-diary.el @@ -368,11 +368,11 @@ If ARG (or prefix) is non-nil, force prompting for all fields." header ": "))) (setq value (if (listp (nth 1 head)) - (completing-read prompt (cons '("*" nil) (nth 1 head)) - nil t value - gnus-diary-header-value-history) + (gnus-completing-read prompt (cons '("*" nil) (nth 1 head)) + t value + 'gnus-diary-header-value-history) (read-string prompt value - gnus-diary-header-value-history)))) + 'gnus-diary-header-value-history)))) (setq ask nil) (setq invalid nil) (condition-case () diff --git a/lisp/gnus/gnus-dired.el b/lisp/gnus/gnus-dired.el index f9502b43c0..da20c66ddb 100644 --- a/lisp/gnus/gnus-dired.el +++ b/lisp/gnus/gnus-dired.el @@ -152,12 +152,8 @@ filenames." (setq destination (if (= (length bufs) 1) (get-buffer (car bufs)) - (completing-read "Attach to which mail composition buffer: " - (mapcar - (lambda (b) - (cons b (get-buffer b))) - bufs) - nil t))) + (gnus-completing-read "Attach to which mail composition buffer" + bufs t))) ;; setup a new mail composition buffer (let ((mail-user-agent gnus-dired-mail-mode) ;; A workaround to prevent Gnus from displaying the Gnus diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el index 14e224051b..2af975b09c 100644 --- a/lisp/gnus/gnus-gravatar.el +++ b/lisp/gnus/gnus-gravatar.el @@ -33,14 +33,13 @@ (defcustom gnus-gravatar-size 32 "How big should gravatars be displayed." :type 'integer + :version "24.1" :group 'gnus-gravatar) -(defcustom gnus-gravatar-relief 1 - "If non-nil, adds a shadow rectangle around the image. The -value, relief, specifies the width of the shadow lines, in -pixels. If relief is negative, shadows are drawn so that the -image appears as a pressed button; otherwise, it appears as an -unpressed button." +(defcustom gnus-gravatar-properties '(:ascent center :relief 1) + "List of image properties applied to Gravatar images." + :type 'list + :version "24.1" :group 'gnus-gravatar) (defun gnus-gravatar-transform-address (header category) @@ -88,7 +87,7 @@ Set image category to CATEGORY." (point (point)) (gravatar (append gravatar - `(:ascent center :relief ,gnus-gravatar-relief)))) + gnus-gravatar-properties))) (gnus-put-image gravatar nil category) (put-text-property point (point) 'gnus-gravatar address) (gnus-add-wash-type category) diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index 7dddb9b6f7..eb594f3e71 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -2164,44 +2164,35 @@ be permanent." group))) (goto-char start))))) -(defun gnus-group-completing-read (prompt &optional collection predicate - require-match initial-input hist def - &rest args) +(defun gnus-group-completing-read (&optional prompt collection + require-match initial-input hist def) "Read a group name with completion. Non-ASCII group names are allowed. The arguments are the same as `completing-read' except that COLLECTION and HIST default to `gnus-active-hashtb' and `gnus-group-history' respectively if they are omitted." - (let ((completion-styles (and (boundp 'completion-styles) - completion-styles)) - group) - (push 'substring completion-styles) - (mapatoms (lambda (symbol) - (setq group (symbol-name symbol)) - (set (intern (if (string-match "[^\000-\177]" group) - (gnus-group-decoded-name group) - group) - collection) - group)) - (prog1 - (or collection - (setq collection (or gnus-active-hashtb [0]))) - (setq collection (gnus-make-hashtable (length collection))))) - (setq group (apply 'completing-read prompt collection predicate - require-match initial-input - (or hist 'gnus-group-history) - def args)) - (or (prog1 - (symbol-value (intern-soft group collection)) - (setq collection nil)) - (mm-encode-coding-string group (gnus-group-name-charset nil group))))) + (let* ((choices (mapcar (lambda (symbol) + (let ((group (symbol-name symbol))) + (if (string-match "[^\000-\177]" group) + (gnus-group-decoded-name group) + group))) + (remove-if-not + 'symbolp + (or collection (or gnus-active-hashtb [0]))))) + (group + (gnus-completing-read (or prompt "Group") choices + require-match initial-input + (or hist 'gnus-group-history) + def))) + (or (symbol-value (intern-soft group collection)) + (mm-encode-coding-string group (gnus-group-name-charset nil group))))) ;;;###autoload (defun gnus-fetch-group (group &optional articles) "Start Gnus if necessary and enter GROUP. If ARTICLES, display those articles. Returns whether the fetching was successful or not." - (interactive (list (gnus-group-completing-read "Group name: " - nil nil nil + (interactive (list (gnus-group-completing-read nil + nil nil (gnus-group-name-at-point)))) (unless (gnus-alive-p) (gnus-no-server)) @@ -2261,7 +2252,7 @@ Return the name of the group if selection was successful." (interactive (list ;; (gnus-read-group "Group name: ") - (gnus-group-completing-read "Group: ") + (gnus-group-completing-read) (gnus-read-method "From method: "))) ;; Transform the select method into a unique server. (when (stringp method) @@ -2328,7 +2319,7 @@ specified by `gnus-gmane-group-download-format'." ;; See <http://gmane.org/export.php> for more information. (interactive (list - (gnus-group-completing-read "Gmane group: ") + (gnus-group-completing-read "Gmane group") (read-number "Start article number: ") (read-number "How many articles: "))) (unless range (setq range 500)) @@ -2362,7 +2353,7 @@ Valid input formats include: ;; prompt the user to decide: "View via `browse-url' or in Gnus? " ;; (`gnus-read-ephemeral-gmane-group-url') (interactive - (list (gnus-group-completing-read "Gmane URL: "))) + (list (gnus-group-completing-read "Gmane URL"))) (let (group start range) (cond ;; URLs providing `group', `start' and `range': @@ -2456,13 +2447,13 @@ If PROMPT (the prefix) is a number, use the prompt specified in `gnus-group-jump-to-group-prompt'." (interactive (list (gnus-group-completing-read - "Group: " nil nil (gnus-read-active-file-p) - (if current-prefix-arg - (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt)) - (or (and (stringp gnus-group-jump-to-group-prompt) - gnus-group-jump-to-group-prompt) - (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt)))) - (and (stringp p) p))))))) + nil nil (gnus-read-active-file-p) + (if current-prefix-arg + (cdr (assq current-prefix-arg gnus-group-jump-to-group-prompt)) + (or (and (stringp gnus-group-jump-to-group-prompt) + gnus-group-jump-to-group-prompt) + (let ((p (cdr (assq 0 gnus-group-jump-to-group-prompt)))) + (and (stringp p) p))))))) (when (equal group "") (error "Empty group name")) @@ -2653,7 +2644,7 @@ If EXCLUDE-GROUP, do not go to that group." (defun gnus-group-make-group-simple (&optional group) "Add a new newsgroup. The user will be prompted for GROUP." - (interactive (list (gnus-group-completing-read "Group: "))) + (interactive (list (gnus-group-completing-read))) (gnus-group-make-group (gnus-group-real-name group) (gnus-group-server group) nil nil t)) @@ -2912,8 +2903,9 @@ and NEW-NAME will be prompted for." (defun gnus-group-make-useful-group (group method) "Create one of the groups described in `gnus-useful-groups'." (interactive - (let ((entry (assoc (completing-read "Create group: " gnus-useful-groups - nil t) + (let ((entry (assoc (gnus-completing-read "Create group" + (mapcar 'car gnus-useful-groups) + t) gnus-useful-groups))) (list (cadr entry) ;; Don't use `caddr' here since macros within the `interactive' @@ -3005,11 +2997,11 @@ If SOLID (the prefix), create a solid group." (symbol-name (caar nnweb-type-definition)))) (type (gnus-string-or - (completing-read - (format "Search engine type (default %s): " default-type) - (mapcar (lambda (elem) (list (symbol-name (car elem)))) + (gnus-completing-read + "Search engine type" + (mapcar (lambda (elem) (symbol-name (car elem))) nnweb-type-definition) - nil t nil 'gnus-group-web-type-history) + t nil 'gnus-group-web-type-history) default-type)) (search (read-string @@ -3100,8 +3092,8 @@ mail messages or news articles in files that have numeric names." "Add the current group to a virtual group." (interactive (list current-prefix-arg - (completing-read "Add to virtual group: " gnus-newsrc-hashtb nil t - "nnvirtual:"))) + (gnus-group-completing-read "Add to virtual group" + nil t "nnvirtual:"))) (unless (eq (car (gnus-find-method-for-group vgroup)) 'nnvirtual) (error "%s is not an nnvirtual group" vgroup)) (gnus-close-group vgroup) @@ -3672,7 +3664,7 @@ If given numerical prefix, toggle the N next groups." Killed newsgroups are subscribed. If SILENT, don't try to update the group line." (interactive (list (gnus-group-completing-read - "Group: " nil nil (gnus-read-active-file-p)))) + nil (gnus-read-active-file-p)))) (let ((newsrc (gnus-group-entry group))) (cond ((string-match "^[ \t]*$" group) @@ -4013,7 +4005,7 @@ If DONT-SCAN is non-nil, scan non-activated groups as well." If given a prefix argument, prompt for a group." (interactive (list (or (when current-prefix-arg - (gnus-group-completing-read "Group: ")) + (gnus-group-completing-read)) (gnus-group-group-name) gnus-newsgroup-name))) (unless group @@ -4314,18 +4306,18 @@ If called interactively, this function will ask for a select method If not, METHOD should be a list where the first element is the method and the second element is the address." (interactive - (list (let ((how (completing-read - "Which back end: " - (append gnus-valid-select-methods gnus-server-alist) - nil t (cons "nntp" 0) 'gnus-method-history))) + (list (let ((how (gnus-completing-read + "Which back end" + (mapcar 'car (append gnus-valid-select-methods gnus-server-alist)) + t (cons "nntp" 0) 'gnus-method-history))) ;; We either got a back end name or a virtual server name. ;; If the first, we also need an address. (if (assoc how gnus-valid-select-methods) (list (intern how) ;; Suggested by [email protected]. - (completing-read - "Address: " - (mapcar 'list gnus-secondary-servers))) + (gnus-completing-read + "Address" + gnus-secondary-servers)) ;; We got a server name. how)))) (gnus-browse-foreign-server method)) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index 3245b16997..33d020f2a1 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -94,11 +94,10 @@ If CONFIRM is non-nil, the user will be asked for an NNTP server." (when confirm ;; Read server name with completion. (setq gnus-nntp-server - (completing-read "NNTP server: " - (mapcar 'list - (cons (list gnus-nntp-server) - gnus-secondary-servers)) - nil nil gnus-nntp-server))) + (gnus-completing-read "NNTP server" + (cons gnus-nntp-server + gnus-secondary-servers) + nil gnus-nntp-server))) (when (and gnus-nntp-server (stringp gnus-nntp-server) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index a2a2652b08..a3794f28a9 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -578,8 +578,8 @@ If ARG is 1, prompt for a group name to find the posting style." (if arg (if (= 1 (prefix-numeric-value arg)) (gnus-group-completing-read - "Use posting style of group: " - nil nil (gnus-read-active-file-p)) + "Use posting style of group" + nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) ;; #### see comment in gnus-setup-message -- drv @@ -607,8 +607,8 @@ network. The corresponding back end must have a 'request-post method." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group: " - nil nil + (gnus-group-completing-read "Use group" + nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) @@ -628,7 +628,7 @@ a news." (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Newsgroup: " nil nil + (gnus-group-completing-read "Newsgroup" nil (gnus-read-active-file-p)) (gnus-group-group-name)) "")) @@ -654,8 +654,8 @@ posting style." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group: " - nil nil + (gnus-group-completing-read "Use group" + nil (gnus-read-active-file-p)) "") gnus-newsgroup-name)) @@ -684,8 +684,8 @@ network. The corresponding back end must have a 'request-post method." (setq gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Use group: " - nil nil + (gnus-group-completing-read "Use group" + nil (gnus-read-active-file-p)) "") gnus-newsgroup-name)) @@ -710,7 +710,7 @@ a news." (let ((gnus-newsgroup-name (if arg (if (= 1 (prefix-numeric-value arg)) - (gnus-group-completing-read "Newsgroup: " nil nil + (gnus-group-completing-read "Newsgroup" nil (gnus-read-active-file-p)) "") gnus-newsgroup-name)) @@ -1028,8 +1028,8 @@ If SILENT, don't prompt the user." gnus-last-posting-server) ;; Just use the last value. gnus-last-posting-server - (completing-read - "Posting method: " method-alist nil t + (gnus-completing-read + "Posting method" (mapcar 'car method-alist) t (cons (or gnus-last-posting-server "") 0)))) method-alist)))) ;; Override normal method. @@ -1487,7 +1487,7 @@ If YANK is non-nil, include the original article." (defun gnus-summary-yank-message (buffer n) "Yank the current article into a composed message." (interactive - (list (completing-read "Buffer: " (mapcar 'list (message-buffers)) nil t) + (list (gnus-completing-read "Buffer" (message-buffers) t) current-prefix-arg)) (gnus-summary-iterate n (let ((gnus-inhibit-treatment t)) diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index a30847b0e2..c7dd012d53 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -857,12 +857,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (defun gnus-registry-read-mark () "Read a mark name from the user with completion." - (let ((mark (gnus-completing-read-with-default - (symbol-name gnus-registry-default-mark) - "Label" - (mapcar (lambda (x) ; completion list - (cons (symbol-name (car-safe x)) (car-safe x))) - gnus-registry-marks)))) + (let ((mark (gnus-completing-read + "Label" + (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + nil nil nil + (symbol-name gnus-registry-default-mark)))) (when (stringp mark) (intern mark)))) @@ -1173,10 +1172,6 @@ Returns the first place where the trail finds a group name." ;;; we could call it here: (customize-variable 'gnus-registry-install) gnus-registry-install) -(when (or (eq gnus-registry-install t) - (gnus-registry-install-p)) - (gnus-registry-initialize)) - ;; TODO: a few things (provide 'gnus-registry) diff --git a/lisp/gnus/gnus-score.el b/lisp/gnus/gnus-score.el index 03ff30d2b4..26c3ca34e7 100644 --- a/lisp/gnus/gnus-score.el +++ b/lisp/gnus/gnus-score.el @@ -680,14 +680,14 @@ file for the command instead of the current score file." (and gnus-extra-headers (equal (nth 1 entry) "extra") (intern ; need symbol - (gnus-completing-read-with-default - (symbol-name (car gnus-extra-headers)) ; default response - "Score extra header" ; prompt - (mapcar (lambda (x) ; completion list - (cons (symbol-name x) x)) - gnus-extra-headers) - nil ; no completion limit - t)))) ; require match + (let ((collection (mapcar 'symbol-name gnus-extra-headers))) + (gnus-completing-read + "Score extra header" ; prompt + collection ; completion list + t ; require match + nil ; no history + nil ; no initial-input + (car collection)))))) ; default value ;; extra is now nil or a symbol. ;; We have all the data, so we enter this score. @@ -913,10 +913,13 @@ MATCH is the string we are looking for. TYPE is the score type. SCORE is the score to add. EXTRA is the possible non-standard header." - (interactive (list (completing-read "Header: " - gnus-header-index - (lambda (x) (fboundp (nth 2 x))) - t) + (interactive (list (gnus-completing-read "Header" + (mapcar + 'car + (remove-if-not + (lambda (x) (fboundp (nth 2 x))) + gnus-header-index)) + t) (read-string "Match: ") (if (y-or-n-p "Use regexp match? ") 'r 's) (string-to-number (read-string "Score: ")))) diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index 11164a8df6..2b13f39ddb 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -571,8 +571,9 @@ The following commands are available: (defun gnus-server-add-server (how where) (interactive - (list (intern (completing-read "Server method: " - gnus-valid-select-methods nil t)) + (list (intern (gnus-completing-read "Server method" + (mapcar 'car gnus-valid-select-methods) + t)) (read-string "Server name: "))) (when (assq where gnus-server-alist) (error "Server with that name already defined")) @@ -582,7 +583,7 @@ The following commands are available: (defun gnus-server-goto-server (server) "Jump to a server line." (interactive - (list (completing-read "Goto server: " gnus-server-alist nil t))) + (list (gnus-completing-read "Goto server" (mapcar 'car gnus-server-alist) t))) (let ((to (text-property-any (point-min) (point-max) 'gnus-server (intern server)))) (when to diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index b8b17b3991..4cd716803b 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -7999,10 +7999,9 @@ If FORCE, go to the article even if it isn't displayed. If FORCE is a number, it is the line the article is to be displayed on." (interactive (list - (completing-read - "Article number or Message-ID: " - (mapcar (lambda (number) (list (int-to-string number))) - gnus-newsgroup-limit)) + (gnus-completing-read + "Article number or Message-ID" + (mapcar 'int-to-string gnus-newsgroup-limit)) current-prefix-arg t)) (prog1 @@ -8256,16 +8255,13 @@ articles that are younger than AGE days." (interactive (let ((header (intern - (gnus-completing-read-with-default - (symbol-name (car gnus-extra-headers)) + (gnus-completing-read (if current-prefix-arg "Exclude extra header" "Limit extra header") - (mapcar (lambda (x) - (cons (symbol-name x) x)) - gnus-extra-headers) - nil - t)))) + (mapcar 'symbol-name gnus-extra-headers) + t nil nil + (symbol-name (car gnus-extra-headers)))))) (list header (read-string (format "%s header %s (regexp): " (if current-prefix-arg "Exclude" "Limit to") @@ -9234,14 +9230,14 @@ If HEADER is an empty string (or nil), the match is done on the entire article. If BACKWARD (the prefix) is non-nil, search backward instead." (interactive (list (let ((completion-ignore-case t)) - (completing-read - "Header name: " - (mapcar (lambda (header) (list (format "%s" header))) + (gnus-completing-read + "Header name" + (mapcar 'symbol-name (append - '("Number" "Subject" "From" "Lines" "Date" - "Message-ID" "Xref" "References" "Body") + '(Number Subject From Lines Date + Message-ID Xref References Body) gnus-extra-headers)) - nil 'require-match)) + 'require-match)) (read-string "Regexp: ") (read-key-sequence "Command: ") current-prefix-arg)) @@ -9937,9 +9933,9 @@ latter case, they will be copied into the relevant groups." (car (gnus-find-method-for-group gnus-newsgroup-name))))) (method - (gnus-completing-read-with-default - methname "Backend to use when respooling" - methods nil t nil 'gnus-mail-method-history)) + (gnus-completing-read + "Backend to use when respooling" + methods t nil 'gnus-mail-method-history methname)) ms) (cond ((zerop (length (setq ms (gnus-servers-using-backend @@ -9949,7 +9945,7 @@ latter case, they will be copied into the relevant groups." (car ms)) (t (let ((ms-alist (mapcar (lambda (m) (cons (cadr m) m)) ms))) - (cdr (assoc (completing-read "Server name: " ms-alist nil t) + (cdr (assoc (gnus-completing-read "Server name" ms-alist t) ms-alist)))))))) (unless method (error "No method given for respooling")) @@ -11904,7 +11900,8 @@ save those articles instead." (nreverse split-name))) (defun gnus-valid-move-group-p (group) - (and (boundp group) + (and (symbolp group) + (boundp group) (symbol-name group) (symbol-value group) (gnus-get-function (gnus-find-method-for-group @@ -11921,29 +11918,20 @@ save those articles instead." (format "these %d articles" (length articles)) "this article"))) (to-newsgroup - (let (active group) - (when (or (null split-name) (= 1 (length split-name))) - (setq active (gnus-make-hashtable (length gnus-active-hashtb))) - (mapatoms (lambda (symbol) - (setq group (symbol-name symbol)) - (when (string-match "[^\000-\177]" group) - (setq group (gnus-group-decoded-name group))) - (set (intern group active) group)) - gnus-active-hashtb)) - (cond - ((null split-name) - (gnus-completing-read-with-default - default prom active 'gnus-valid-move-group-p nil prefix - 'gnus-group-history)) - ((= 1 (length split-name)) - (gnus-completing-read-with-default - (car split-name) prom active 'gnus-valid-move-group-p nil nil - 'gnus-group-history)) - (t - (gnus-completing-read-with-default - nil prom (mapcar 'list (nreverse split-name)) nil nil nil - 'gnus-group-history))))) - (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) + (cond + ((null split-name) + (gnus-group-completing-read + prom + (remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb) + nil prefix nil default)) + ((= 1 (length split-name)) + (gnus-group-completing-read + prom (remove-if-not 'gnus-valid-move-group-p gnus-active-hashtb) + nil prefix 'gnus-group-history (car split-name))) + (t + (gnus-completing-read + prom (nreverse split-name) nil nil 'gnus-group-history)))) + (to-method (gnus-server-to-method (gnus-group-method to-newsgroup))) encoded) (when to-newsgroup (if (or (string= to-newsgroup "") diff --git a/lisp/gnus/gnus-topic.el b/lisp/gnus/gnus-topic.el index 7c710357b9..b600fac353 100644 --- a/lisp/gnus/gnus-topic.el +++ b/lisp/gnus/gnus-topic.el @@ -161,9 +161,7 @@ See Info node `(gnus)Formatting Variables'." (defun gnus-topic-jump-to-topic (topic) "Go to TOPIC." (interactive - (list (completing-read "Go to topic: " - (mapcar 'list (gnus-topic-list)) - nil t))) + (list (gnus-completing-read "Go to topic" (gnus-topic-list) t))) (let ((buffer-read-only nil)) (dolist (topic (gnus-current-topics topic)) (unless (gnus-topic-goto-topic topic) @@ -1303,7 +1301,7 @@ When used interactively, PARENT will be the topic under point." If COPYP, copy the groups instead." (interactive (list current-prefix-arg - (gnus-completing-read "Move to topic" gnus-topic-alist nil t + (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t 'gnus-topic-history))) (let ((use-marked (and (not n) (not (gnus-region-active-p)) gnus-group-marked t)) @@ -1350,7 +1348,7 @@ If COPYP, copy the groups instead." "Copy the current group to a topic." (interactive (list current-prefix-arg - (completing-read "Copy to topic: " gnus-topic-alist nil t))) + (gnus-completing-read "Copy to topic" (mapcar 'car gnus-topic-alist) t))) (gnus-topic-move-group n topic t)) (defun gnus-topic-kill-group (&optional n discard) @@ -1443,7 +1441,8 @@ If PERMANENT, make it stay shown in subsequent sessions as well." (gnus-topic-remove-topic t nil) (let ((topic (gnus-topic-find-topology - (completing-read "Show topic: " gnus-topic-alist nil t)))) + (gnus-completing-read "Show topic" + (mapcar 'car gnus-topic-alist) t)))) (setcar (cddr (cadr topic)) nil) (setcar (cdr (cadr topic)) 'visible) (gnus-group-list-groups))))) @@ -1491,7 +1490,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (let (topic) (nreverse (list - (setq topic (completing-read "Move to topic: " gnus-topic-alist nil t)) + (setq topic (gnus-completing-read "Move to topic" + (mapcar 'car gnus-topic-alist) t)) (read-string (format "Move to %s (regexp): " topic)))))) (gnus-group-mark-regexp regexp) (gnus-topic-move-group nil topic copyp)) @@ -1502,7 +1502,8 @@ If NON-RECURSIVE (which is the prefix) is t, don't unmark its subtopics." (let (topic) (nreverse (list - (setq topic (completing-read "Copy to topic: " gnus-topic-alist nil t)) + (setq topic (gnus-completing-read "Copy to topic" + (mapcar 'car gnus-topic-alist) t)) (read-string (format "Copy to %s (regexp): " topic)))))) (gnus-topic-move-matching regexp topic t)) @@ -1723,8 +1724,9 @@ If REVERSE, sort in reverse order." "Sort topics in TOPIC alphabetically by topic name. If REVERSE, reverse the sorting order." (interactive - (list (completing-read "Sort topics in : " gnus-topic-alist nil t - (gnus-current-topic)) + (list (gnus-completing-read "Sort topics in" + (mapcar 'car gnus-topic-alist) t + (gnus-current-topic)) current-prefix-arg)) (let ((topic-topology (or (and topic (cdr (gnus-topic-find-topology topic))) gnus-topic-topology))) @@ -1738,7 +1740,7 @@ If REVERSE, reverse the sorting order." (interactive (list (gnus-group-topic-name) - (completing-read "Move to topic: " gnus-topic-alist nil t))) + (gnus-completing-read "Move to topic" (mapcar 'car gnus-topic-alist) t))) (unless (and current to) (error "Can't find topic")) (let ((current-top (cdr (gnus-topic-find-topology current))) diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 5ebccc03f0..2f9bdd62e6 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -44,6 +44,32 @@ (defmacro with-no-warnings (&rest body) `(progn ,@body)))) +(defcustom gnus-completing-read-function + #'gnus-std-completing-read + "Function to do a completing read." + :group 'gnus-meta + :type '(radio (function-item + :doc "Use Emacs' standard `completing-read' function." + gnus-std-completing-read) + (function-item :doc "Use iswitchb's completing-read function." + gnus-icompleting-read) + (function-item :doc "Use ido's completing-read function." + gnus-ido-completing-read) + (function))) + +(defcustom gnus-completion-styles + (if (and (boundp 'completion-styles-alist) + (boundp 'completion-styles)) + (append (when (and (assq 'substring completion-styles-alist) + (not (memq 'substring completion-styles))) + (list 'substring)) + completion-styles) + nil) + "Value of `completion-styles' to use when completing." + :version "24.1" + :group 'gnus-meta + :type 'list) + ;; Fixme: this should be a gnus variable, not nnmail-. (defvar nnmail-pathname-coding-system) (defvar nnmail-active-file-coding-system) @@ -344,16 +370,6 @@ TIME defaults to the current time." (define-key keymap key (pop plist)) (pop plist))))) -(defun gnus-completing-read-with-default (default prompt &rest args) - ;; Like `completing-read', except that DEFAULT is the default argument. - (let* ((prompt (if default - (concat prompt " (default " default "): ") - (concat prompt ": "))) - (answer (apply 'completing-read prompt args))) - (if (or (null answer) (zerop (length answer))) - default - answer))) - ;; Two silly functions to ensure that all `y-or-n-p' questions clear ;; the echo area. ;; @@ -1574,21 +1590,50 @@ SPEC is a predicate specifier that contains stuff like `or', `and', `(,(car spec) ,@(mapcar 'gnus-make-predicate-1 (cdr spec))) (error "Invalid predicate specifier: %s" spec))))) -(defun gnus-completing-read (prompt table &optional predicate require-match - history) - (when (and history - (not (boundp history))) - (set history nil)) - (completing-read - (if (symbol-value history) - (concat prompt " (" (car (symbol-value history)) "): ") - (concat prompt ": ")) - table - predicate - require-match - nil - history - (car (symbol-value history)))) +(defun gnus-std-completing-read (prompt collection &optional require-match + initial-input history def) + (completing-read prompt collection nil require-match + initial-input history def)) + +(defun gnus-icompleting-read (prompt collection &optional require-match + initial-input history def) + (require 'iswitchb) + (let ((iswitchb-make-buflist-hook + (lambda () + (setq iswitchb-temp-buflist + (let ((choices (append (list) + (when initial-input (list initial-input)) + (symbol-value history) collection)) + filtered-choices) + (while choices + (when (and (car choices) (not (member (car choices) filtered-choices))) + (setq filtered-choices (cons (car choices) filtered-choices))) + (setq choices (cdr choices))) + (nreverse filtered-choices)))))) + (unwind-protect + (progn + (when (not iswitchb-mode) + (add-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup)) + (iswitchb-read-buffer prompt def require-match)) + (when (not iswitchb-mode) + (remove-hook 'minibuffer-setup-hook 'iswitchb-minibuffer-setup))))) + +(defun gnus-ido-completing-read (prompt collection &optional require-match + initial-input history def) + (require 'ido) + (ido-completing-read prompt collection nil require-match + initial-input history def)) + +(defun gnus-completing-read (prompt collection &optional require-match + initial-input history def) + "Do a completing read with the configured `gnus-completing-read-function'." + (let ((completion-styles gnus-completion-styles)) + (funcall + gnus-completing-read-function + (concat prompt (when def + (concat " (default " def ")")) + ": ") + collection require-match initial-input history def))) (defun gnus-graphic-display-p () (if (featurep 'xemacs) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 2024721ab0..53a30efd22 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -1427,6 +1427,7 @@ no need to set this variable." :group 'gnus-message :type '(choice (const :tag "default" nil) string)) +(make-obsolete-variable 'gnus-local-domain nil "24.1") (defvar gnus-local-organization nil "String with a description of what organization (if any) the user belongs to. @@ -4241,9 +4242,9 @@ Allow completion over sensible values." gnus-predefined-server-alist gnus-server-alist)) (method - (completing-read - prompt servers - nil t nil 'gnus-method-history))) + (gnus-completing-read + prompt (mapcar 'car servers) + t nil 'gnus-method-history))) (cond ((equal method "") (setq method gnus-select-method)) diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index 9b756edae4..7562e57ca8 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -1323,11 +1323,11 @@ Use CMD as the process." "Display HANDLE using METHOD." (let* ((type (mm-handle-media-type handle)) (methods - (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) + (mapcar (lambda (i) (cdr (assoc 'viewer i))) (mailcap-mime-info type 'all))) (method (let ((minibuffer-local-completion-map mm-viewer-completion-map)) - (completing-read "Viewer: " methods)))) + (gnus-completing-read "Viewer" methods)))) (when (string= method "") (error "No method given")) (if (string-match "^[^% \t]+$" method) diff --git a/lisp/gnus/mm-util.el b/lisp/gnus/mm-util.el index c997a36a1b..65543d11bb 100644 --- a/lisp/gnus/mm-util.el +++ b/lisp/gnus/mm-util.el @@ -68,11 +68,11 @@ . ,(lambda (prompt) "Return a charset." (intern - (completing-read + (gnus-completing-read prompt - (mapcar (lambda (e) (list (symbol-name (car e)))) + (mapcar (lambda (e) (symbol-name (car e))) mm-mime-mule-charset-alist) - nil t)))) + t)))) ;; `subst-char-in-string' is not available in XEmacs 21.4. (subst-char-in-string . ,(lambda (from to string &optional inplace) @@ -281,8 +281,8 @@ to the contents of the accessible portion of the buffer." 'read-coding-system)) (t (lambda (prompt &optional default-coding-system) "Prompt the user for a coding system." - (completing-read - prompt (mapcar (lambda (s) (list (symbol-name (car s)))) + (gnus-completing-read + prompt (mapcar (lambda (s) (symbol-name (car s))) mm-mime-mule-charset-alist))))))) (defvar mm-coding-system-list nil) @@ -316,8 +316,8 @@ the alias. Else windows-NUMBER is used." (cp-supported-codepages) ;; Removed in Emacs 23 (unicode), so signal an error: (error "`codepage-setup' not present in this Emacs version")))) - (list (completing-read "Setup DOS Codepage: (default 437) " candidates - nil t nil nil "437")))) + (list (gnus-completing-read "Setup DOS Codepage" candidates + t nil nil "437")))) (when alias (setq alias (if (stringp alias) (intern alias) diff --git a/lisp/gnus/mm-view.el b/lisp/gnus/mm-view.el index 1a2d940e2e..566908ce1c 100644 --- a/lisp/gnus/mm-view.el +++ b/lisp/gnus/mm-view.el @@ -31,6 +31,7 @@ (require 'mm-decode) (require 'smime) +(autoload 'gnus-completing-read "gnus-util") (autoload 'gnus-article-prepare-display "gnus-art") (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") @@ -676,11 +677,9 @@ (if (= (length smime-keys) 1) (cadar smime-keys) (smime-get-key-by-email - (completing-read - (concat "Decipher using key" - (if smime-keys (concat "(default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) + (gnus-completing-read + "Decipher using key" + smime-keys nil nil nil (car-safe (car-safe smime-keys)))))) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n")) diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index a99538be0a..62e742f93a 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -161,10 +161,10 @@ Whether the passphrase is cached at all is controlled by ""))))) (and from (smime-get-key-by-email from))) (smime-get-key-by-email - (completing-read "Sign this part with what signature? " - smime-keys nil nil - (and (listp (car-safe smime-keys)) - (caar smime-keys)))))))) + (gnus-completing-read "Sign this part with what signature" + smime-keys nil nil + (and (listp (car-safe smime-keys)) + (caar smime-keys)))))))) (defun mml-smime-get-file-cert () (ignore-errors @@ -213,15 +213,16 @@ Whether the passphrase is cached at all is controlled by (quit)) result)) -(autoload 'gnus-completing-read-with-default "gnus-util") +(autoload 'gnus-completing-read "gnus-util") (defun mml-smime-openssl-encrypt-query () ;; todo: try dns/ldap automatically first, before prompting user (let (certs done) (while (not done) - (ecase (read (gnus-completing-read-with-default - "ldap" "Fetch certificate from" - '(("dns") ("ldap") ("file")) nil t)) + (ecase (read (gnus-completing-read + "Fetch certificate from" + '(("dns") ("ldap") ("file")) t nil nil + "ldap")) (dns (setq certs (append certs (mml-smime-get-dns-cert)))) (ldap (setq certs (append certs diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 15b1bb7096..3cf0f3701f 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -40,6 +40,7 @@ (autoload 'message-make-message-id "message") (declare-function gnus-setup-posting-charset "gnus-msg" (group)) (autoload 'gnus-make-local-hook "gnus-util") +(autoload 'gnus-completing-read "gnus-util") (autoload 'message-fetch-field "message") (autoload 'message-mark-active-p "message") (autoload 'message-info "message") @@ -1188,9 +1189,10 @@ If not set, `default-directory' will be used." ;; looks like, and offer text/plain if it looks ;; like text/plain. "application/octet-stream")) - (string (completing-read - (format "Content type (default %s): " default) - (mapcar 'list (mailcap-mime-types))))) + (string (gnus-completing-read + "Content type" + (mailcap-mime-types) + nil nil nil default))) (if (not (equal string "")) string default))) @@ -1204,10 +1206,10 @@ If not set, `default-directory' will be used." (defun mml-minibuffer-read-disposition (type &optional default filename) (unless default (setq default (mml-content-disposition type filename))) - (let ((disposition (completing-read - (format "Disposition (default %s): " default) - '(("attachment") ("inline") ("")) - nil t nil nil default))) + (let ((disposition (gnus-completing-read + "Disposition" + '("attachment" "inline") + t nil nil default))) (if (not (equal disposition "")) disposition default))) @@ -1395,11 +1397,11 @@ TYPE is the MIME type to use." (defun mml-insert-multipart (&optional type) (interactive (if (message-in-body-p) - (list (completing-read "Multipart type (default mixed): " - '(("mixed") ("alternative") - ("digest") ("parallel") - ("signed") ("encrypted")) - nil nil "mixed")) + (list (gnus-completing-read "Multipart type" + '("mixed" "alternative" + "digest" "parallel" + "signed" "encrypted") + nil "mixed")) (error "Use this command in the message body"))) (or type (setq type "mixed")) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 15e5e82c6f..588eeb1168 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -280,6 +280,11 @@ from the document.") (t (nnheader-insert "211 %d %d %d %s\n" number 1 number group))))) +(deffoo nndoc-retrieve-groups (groups &optional server) + (dolist (group groups) + (nndoc-request-group group server)) + t) + (deffoo nndoc-request-type (group &optional article) (cond ((not article) 'unknown) (nndoc-post-type nndoc-post-type) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index 5dc51f321c..98c14d4cab 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -224,7 +224,7 @@ are generated if and only if they are also in `message-draft-headers'.") (let* ((nnmh-allow-delete-final t) (nnmail-expiry-target (or (gnus-group-find-parameter - (gnus-group-prefixed-name "nndraft" (list 'nndraft server)) + (gnus-group-prefixed-name group (list 'nndraft server)) 'expiry-target t) nnmail-expiry-target)) (res (nnoo-parent-function 'nndraft diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index a61a02899c..1dd561ab6a 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -70,6 +70,9 @@ Values are `ssl', `network', `starttls' or `shell'.") "How mail is split. Uses the same syntax as nnmail-split-methods") +(make-obsolete-variable 'nnimap-split-rule "see `nnimap-split-methods'" + "Gnus 5.13") + (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. Possible choices are nil (use default methods) or `anonymous'.") @@ -342,15 +345,6 @@ textual parts.") (when (eq nnimap-stream 'starttls) (nnimap-command "STARTTLS") (starttls-negotiate (nnimap-process nnimap-object))) - ;; If this is a STARTTLS-capable server, then sever the - ;; connection and start a STARTTLS connection instead. - (when (and (eq nnimap-stream 'network) - (member "STARTTLS" (nnimap-capabilities nnimap-object))) - (let ((nnimap-stream 'starttls)) - (delete-process (nnimap-process nnimap-object)) - (kill-buffer (current-buffer)) - (return - (nnimap-open-connection buffer)))) (when nnimap-server-port (push (format "%s" nnimap-server-port) ports)) (unless (equal connection-result "PREAUTH") @@ -428,7 +422,12 @@ textual parts.") (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) (goto-char (point-min)) (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) - (setq structure (ignore-errors (read (current-buffer))) + (setq structure (ignore-errors + (let ((start (point))) + (forward-sexp 1) + (downcase-region start (point)) + (goto-char (point)) + (read (current-buffer)))) parts (nnimap-find-wanted-parts structure)))) (when (if parts (nnimap-get-partial-article article parts structure) @@ -509,8 +508,15 @@ textual parts.") t)) (defun nnimap-insert-partial-structure (structure parts &optional subp) - (let ((type (car (last structure 4))) - (boundary (cadr (member "BOUNDARY" (car (last structure 3)))))) + (let (type boundary) + (let ((bstruc structure)) + (while (consp (car bstruc)) + (pop bstruc)) + (setq type (car bstruc)) + (setq bstruc (car (cdr bstruc))) + (when (and (stringp (car bstruc)) + (string= (downcase (car bstruc)) "boundary")) + (setq boundary (cadr bstruc)))) (when subp (insert (format "Content-type: multipart/%s; boundary=%S\n\n" (downcase type) boundary))) @@ -768,6 +774,7 @@ textual parts.") (when (nnimap-possibly-change-group group server) (let (sequence) (with-current-buffer (nnimap-buffer) + (erase-buffer) ;; Just send all the STORE commands without waiting for ;; response. If they're successful, they're successful. (dolist (action actions) @@ -789,6 +796,7 @@ textual parts.") (deffoo nnimap-request-accept-article (group &optional server last) (when (nnimap-possibly-change-group nil server) (nnmail-check-syntax) + (nnimap-add-cr) (let ((message (buffer-string)) (message-id (message-field-value "message-id")) sequence) @@ -1288,7 +1296,9 @@ textual parts.") (defun nnimap-split-incoming-mail () (with-current-buffer (nnimap-buffer) (let ((nnimap-incoming-split-list nil) - (nnmail-split-methods nnimap-split-methods) + (nnmail-split-methods (if (eq nnimap-split-methods 'default) + nnmail-split-methods + nnimap-split-methods)) (nnmail-inhibit-default-split-group t) (groups (nnimap-get-groups)) new-articles) @@ -1339,6 +1349,7 @@ textual parts.") (defun nnimap-mark-and-expunge-incoming (range) (when range (setq range (nnimap-article-ranges range)) + (erase-buffer) (let ((sequence (nnimap-send-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" range))) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index db8b397178..455a0fdaa6 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -1588,7 +1588,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." (let ((sym (car parmspec)) (prompt (cdr parmspec))) (if (listp prompt) - (let* ((result (apply 'completing-read prompt)) + (let* ((result (gnus-completing-read prompt nil)) (mapping (or (assoc result nnir-imap-search-arguments) (assoc nil nnir-imap-search-arguments)))) (cons sym (format (cdr mapping) result))) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index bca549a683..9672c04b49 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -848,8 +848,8 @@ called interactively, user will be asked for parameters." All necessary information will be queried from the user." (interactive) (let* ((name (read-string "Name of the mairix server: ")) - (server (completing-read "Back end server (TAB for completion): " - (nnmairix-get-valid-servers) nil 1)) + (server (gnus-completing-read "Back end server" + (nnmairix-get-valid-servers) t)) (mairix (read-string "Command to call mairix: " "mairix")) (defaultgroup (read-string "Default search group: ")) (backend (symbol-name (car (gnus-server-to-method server)))) @@ -1165,7 +1165,7 @@ nnmairix server. Only marks from current session will be set." If SKIPDEFAULT is t, the default search group will not be updated. If UPDATEDB is t, database for SERVERNAME will be updated first." - (interactive (list (completing-read "Update groups on server: " + (interactive (list (gnus-completing-read "Update groups on server" (nnmairix-get-nnmairix-servers)))) (save-excursion (when (string-match ".*:\\(.*\\)" servername) @@ -1302,7 +1302,7 @@ Otherwise, ask user for server." (while (equal '("") (setq nnmairix-last-server - (list (completing-read "Server: " openedserver nil 1 + (list (gnus-completing-read "Server" openedserver t (or nnmairix-last-server "nnmairix:")))))) nnmairix-last-server) @@ -1492,10 +1492,10 @@ group." (when (not found) (setq mairixserver (gnus-server-to-method - (completing-read - (format "Cannot determine which nnmairix server indexes %s. Please specify: " + (gnus-completing-read + (format "Cannot determine which nnmairix server indexes %s. Please specify" (gnus-method-to-server server)) - (nnmairix-get-nnmairix-servers) nil nil "nnmairix:"))) + (nnmairix-get-nnmairix-servers) nil "nnmairix:"))) ;; Save result in parameter of default search group so that ;; we don't have to ask again (setq defaultgroup (gnus-group-prefixed-name @@ -1643,9 +1643,9 @@ search in raw mode." (gnus-registry-add-group mid cur))))) (if (> (length allgroups) 1) (setq group - (completing-read - "Message exists in more than one group. Choose: " - allgroups nil t)) + (gnus-completing-read + "Message exists in more than one group. Choose" + allgroups t)) (setq group (car allgroups)))) (if group ;; show article in summary buffer @@ -1748,9 +1748,9 @@ SERVER." (gnus-group-prefixed-name group (car cur)) allgroups)))) (if (> (length allgroups) 1) - (setq group (completing-read - "Group %s exists on more than one IMAP server. Choose: " - allgroups nil t)) + (setq group (gnus-completing-read + "Group %s exists on more than one IMAP server. Choose" + allgroups t)) (setq group (car allgroups)))) group)) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index aa3b79a102..94fd55ebbf 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -1048,9 +1048,9 @@ whether they are `offsite' or `onsite'." (cdr (assoc "feedid" listinfo))))) feedinfo))) (cdr (assoc - (completing-read - "Multiple feeds found. Select one: " - selection nil t) urllist))))))))) + (gnus-completing-read + "Multiple feeds found. Select one" + selection t) urllist))))))))) (defun nnrss-rss-p (data) "Test if DATA is an RSS feed. diff --git a/lisp/gnus/pop3.el b/lisp/gnus/pop3.el index d2953dcffc..20fe560915 100644 --- a/lisp/gnus/pop3.el +++ b/lisp/gnus/pop3.el @@ -82,6 +82,15 @@ valid value is 'apop'." :version "22.1" ;; Oort Gnus :group 'pop3) +(defcustom pop3-stream-length 100 + "How many messages should be requested at one time. +The lower the number, the more latency-sensitive the fetching +will be. If your pop3 server doesn't support streaming at all, +set this to 1." + :type 'number + :version "24.1" + :group 'pop3) + (defcustom pop3-leave-mail-on-server nil "*Non-nil if the mail is to be left on the POP server after fetching. @@ -156,7 +165,7 @@ Use streaming commands." (while (>= count i) (process-send-string process (format "%s %d\r\n" command i)) ;; Only do 100 messages at a time to avoid pipe stalls. - (when (zerop (% i 100)) + (when (zerop (% i pop3-stream-length)) (pop3-wait-for-messages process i total-size)) (incf i))) (pop3-wait-for-messages process count total-size)) diff --git a/lisp/gnus/smime.el b/lisp/gnus/smime.el index a266819946..2492007f58 100644 --- a/lisp/gnus/smime.el +++ b/lisp/gnus/smime.el @@ -371,12 +371,9 @@ KEYFILE should contain a PEM encoded key and certificate." (if keyfile keyfile (smime-get-key-with-certs-by-email - (completing-read - (concat "Sign using key" - (if smime-keys - (concat " (default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil (car-safe (car-safe smime-keys)))))) + (gnus-completing-read + "Sign using key" + smime-keys nil (car-safe (car-safe smime-keys)))))) (error "Signing failed")))) (defun smime-encrypt-buffer (&optional certfiles buffer) @@ -502,11 +499,9 @@ in the buffer specified by `smime-details-buffer'." (expand-file-name (or keyfile (smime-get-key-by-email - (completing-read - (concat "Decipher using key" - (if smime-keys (concat " (default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil (car-safe (car-safe smime-keys))))))))) + (gnus-completing-read + "Decipher using key" + smime-keys nil (car-safe (car-safe smime-keys))))))))) ;; Various operations @@ -660,6 +655,7 @@ A string or a list of strings is returned." (define-key smime-mode-map "f" 'smime-certificate-info)) (autoload 'gnus-run-mode-hooks "gnus-util") +(autoload 'gnus-completing-read "gnus-util") (defun smime-mode () "Major mode for browsing, viewing and fetching certificates. diff --git a/lisp/gnus/webmail.el b/lisp/gnus/webmail.el index 86d443aa90..f3b8849085 100644 --- a/lisp/gnus/webmail.el +++ b/lisp/gnus/webmail.el @@ -4,7 +4,7 @@ ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Shenghuo Zhu <[email protected]> -;; Keywords: hotmail netaddress my-deja netscape +;; Keywords: hotmail netaddress ;; This file is part of GNU Emacs. @@ -115,39 +115,7 @@ (article-snarf . webmail-netaddress-article) (trash-url "http://www.netaddress.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1" - webmail-session id)) - (netscape - (paranoid cookie post agent) - (address . "webmail.netscape.com") - (open-url "http://ureg.netscape.com/iiop/UReg2/login/login?U2_LA=en&U2_BACK_FROM_CJ=true&U2_CS=iso-8859-1&U2_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_NEW_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_EXITURL=http://home.netscape.com/&U2_SOURCE=Webmail") - (open-snarf . webmail-netscape-open) - (login-url - content - ("http://ureg.netscape.com/iiop/UReg2/login/loginform") - "U2_USERNAME=%s&U2_PASSWORD=%s%s" - user password webmail-aux) - (login-snarf . webmail-netaddress-login) - (list-url - "http://webmail.netscape.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True" - webmail-session) - (list-snarf . webmail-netaddress-list) - (article-url "http://webmail.netscape.com/") - (article-snarf . webmail-netscape-article) - (trash-url - "http://webmail.netscape.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1" - webmail-session id)) - (my-deja - (paranoid cookie post) - (address . "www.my-deja.com") - ;;(open-snarf . webmail-my-deja-open) - (login-url - content - ("http://mydeja.google.com/cgi-bin/deja/maillogin.py") - "userid=%s&password=%s" - user password) - (list-snarf . webmail-my-deja-list) - (article-snarf . webmail-my-deja-article) - (trash-url webmail-aux id)))) + webmail-session id)))) (defvar webmail-variables '(address article-snarf article-url list-snarf list-url @@ -683,15 +651,6 @@ ;;; netaddress -(defun webmail-netscape-open () - (goto-char (point-min)) - (setq webmail-aux "") - (while (re-search-forward - "TYPE=hidden *NAME=\\([^ ]+\\) *VALUE=\"\\([^\"]+\\)" - nil t) - (setq webmail-aux (concat webmail-aux "&" (match-string 1) "=" - (match-string 2))))) - (defun webmail-netaddress-open () (goto-char (point-min)) (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t) @@ -872,280 +831,6 @@ (insert ">")))) (mm-append-to-file (point-min) (point-max) file))) -(defun webmail-netscape-article (file id) - (let (p p1 attachment count mime type) - (save-restriction - (webmail-encode-8bit) - (goto-char (point-min)) - (if (not (search-forward "Trash" nil t)) - (webmail-error "article@1")) - (if (not (search-forward "<form>" nil t)) - (webmail-error "article@2")) - (delete-region (point-min) (match-beginning 0)) - (if (not (search-forward "</form>" nil t)) - (webmail-error "article@3")) - (narrow-to-region (point-min) (match-end 0)) - (goto-char (point-min)) - (while (re-search-forward "[\040\t\r\n]+" nil t) - (replace-match " ")) - (goto-char (point-min)) - (while (re-search-forward "<a href=[^>]*>[^<]*</a>" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (search-forward "<b>" nil t) - (replace-match "\n")) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^\040+\\|\040+$" nil t) - (replace-match "")) - (goto-char (point-min)) - (while (re-search-forward "\040+" nil t) - (replace-match " ")) - (goto-char (point-max)) - (widen) - (insert "\n\n") - (setq p (point)) - (unless (search-forward "<!-- Data -->" nil t) - (webmail-error "article@4")) - (forward-line 14) - (delete-region p (point)) - (goto-char (point-max)) - (unless (re-search-backward - "<form name=\"Transfer2\"" p t) - (webmail-error "article@5")) - (delete-region (point) (point-max)) - (goto-char p) - (while (search-forward - "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" - nil t 2) - (setq mime t) - (unless (search-forward "</TABLE>" nil t) - (webmail-error "article@6")) - (setq p1 (point)) - (if (search-backward "<IMG " p t) - (progn - (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t) - (webmail-error "article@7")) - (setq attachment (match-string 1)) - (setq type (match-string 2)) - (unless (search-forward "</TABLE>" nil t) - (webmail-error "article@8")) - (delete-region p (point)) - (let (bufname);; Attachment - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert (concat (car webmail-open-url) attachment)) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (insert "<#part type=" type) - (insert " buffer=\"" bufname "\"") - (insert " disposition=\"inline\"") - (insert "><#/part>\n") - (setq p (point)))) - (delete-region p p1) - (narrow-to-region - p - (if (search-forward - "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" - nil t) - (match-beginning 0) - (point-max))) - (webmail-netaddress-single-part) - (goto-char (point-max)) - (setq p (point)) - (widen))) - (unless mime - (narrow-to-region p (point-max)) - (setq mime (webmail-netaddress-single-part)) - (widen)) - (goto-char (point-min)) - ;; Some blank line to separate mails. - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if id - (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address))) - (unless (looking-at "$") - (if (search-forward "\n\n" nil t) - (forward-line -1) - (webmail-error "article@2"))) - (when mime - (narrow-to-region (point-min) (point)) - (goto-char (point-min)) - (while (not (eobp)) - (if (looking-at "MIME-Version\\|Content-Type") - (delete-region (point) - (progn - (forward-line 1) - (if (re-search-forward "^[^ \t]" nil t) - (goto-char (match-beginning 0)) - (point-max)))) - (forward-line 1))) - (goto-char (point-max)) - (widen) - (narrow-to-region (point) (point-max)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max)))) - (goto-char (point-min)) - (widen)) - (let (case-fold-search) - (while (re-search-forward "^From " nil t) - (beginning-of-line) - (insert ">")))) - (mm-append-to-file (point-min) (point-max) file))) - -;;; my-deja - -(defun webmail-my-deja-open () - (webmail-refresh-redirect) - (goto-char (point-min)) - (if (re-search-forward "action=\"\\([^\"]+maillogin\\.py[^\"]*\\)\"" - nil t) - (setq webmail-aux (match-string 1)) - (webmail-error "open@1"))) - -(defun webmail-my-deja-list () - (let (item id newp base) - (goto-char (point-min)) - (when (re-search-forward "href=\"\\(\\([^\"]*\\)/mailnf\\.[^\"]*\\)\"" - nil t) - (let ((url (match-string 1))) - (setq base (match-string 2)) - (erase-buffer) - (mm-url-insert url))) - (goto-char (point-min)) - (when (re-search-forward - "(\\([0-9]+\\) Message.?-[^>]*\\([0-9]+\\) New" - nil t) - (message "Found %s mail(s), %s unread" - (match-string 1) (match-string 2))) - (goto-char (point-min)) - (while (re-search-forward - "newmail\\.gif\\|href=\"[^\"]*\\(mailnf\\.[^\"]+act=view[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" - nil t) - (if (setq id (match-string 2)) - (when (and (or newp (not webmail-newmail-only)) - (not (assoc id webmail-articles))) - (push (cons id (setq webmail-aux - (concat base "/" (match-string 1)))) - webmail-articles) - (setq newp nil)) - (setq newp t))) - (setq webmail-articles (nreverse webmail-articles)))) - -(defun webmail-my-deja-article-part (base) - (let (p) - (cond - ((looking-at "[\t\040\r\n]*<!--[^>]*>") - (replace-match "")) - ((looking-at "[\t\040\r\n]*</PRE>") - (replace-match "")) - ((looking-at "[\t\040\r\n]*<PRE>") - ;; text/plain - (replace-match "") - (save-restriction - (narrow-to-region (point) - (if (re-search-forward "</?PRE>" nil t) - (match-beginning 0) - (point-max))) - (goto-char (point-min)) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-max)))) - ((looking-at "[\t\040\r\n]*<TABLE") - (save-restriction - (narrow-to-region (point) - (if (search-forward "</TABLE>" nil t 2) - (point) - (point-max))) - (goto-char (point-min)) - (let (name type url bufname) - (if (and (search-forward "File Name:" nil t) - (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t)) - (setq name (match-string 1))) - (if (and (search-forward "File Type:" nil t) - (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t)) - (setq type (match-string 1))) - (unless (re-search-forward "action=\"getattach\\.cgi/\\([^\"]+\\)" - nil t) - (webmail-error "article@5")) - (setq url (concat base "/getattach.cgi/" (match-string 1) - "?sm=Download")) - (while (re-search-forward - "type=hidden name=\"\\([^\"]+\\)\" value=\"\\([^\"]+\\)" - nil t) - (setq url (concat url "&" (match-string 1) "=" - (match-string 2)))) - (delete-region (point-min) (point-max)) - (save-excursion - (set-buffer (generate-new-buffer " *webmail-att*")) - (mm-url-insert url) - (push (current-buffer) webmail-buffer-list) - (setq bufname (buffer-name))) - (insert "<#part type=\"" type "\"") - (if name (insert " filename=\"" name "\"")) - (insert " buffer=\"" bufname "\"") - (insert " disposition=inline><#/part>")))) - (t - (insert "<#part type=\"text/html\" disposition=inline>") - (goto-char (point-max)) - (insert "<#/part>"))))) - -(defun webmail-my-deja-article (file id) - (let (base) - (goto-char (point-min)) - (unless (string-match "\\([^\"]+\\)/mail" webmail-aux) - (webmail-error "article@0")) - (setq base (match-string 1 webmail-aux)) - (when (re-search-forward - "href=\"[^\"]*\\(mailnf\\.[^\"]+act=move[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" - nil t) - (setq webmail-aux (concat base "/" (match-string 1))) - (string-match "mid=[^\"&]+" webmail-aux) - (setq webmail-aux (replace-match "mid=%s" nil nil webmail-aux))) - (unless (search-forward "<HR noshade>" nil t) - (webmail-error "article@1")) - (delete-region (point-min) (point)) - (unless (search-forward "<HR noshade>" nil t) - (webmail-error "article@2")) - (save-restriction - (narrow-to-region (point-min) (point)) - (while (search-forward "\r\n" nil t) - (replace-match "\n")) - (mm-url-remove-markup) - (mm-url-decode-entities-nbsp) - (goto-char (point-min)) - (while (re-search-forward "\n\n+" nil t) - (replace-match "\n")) - (goto-char (point-max))) - (save-restriction - (narrow-to-region (point) (point-max)) - (goto-char (point-max)) - (unless (search-backward "<HR noshade>" nil t) - (webmail-error "article@3")) - (unless (search-backward "</TT>" nil t) - (webmail-error "article@4")) - (delete-region (point) (point-max)) - (goto-char (point-min)) - (while (not (eobp)) - (webmail-my-deja-article-part base)) - (insert "MIME-Version: 1.0\n" - (prog1 - (mml-generate-mime) - (delete-region (point-min) (point-max))))) - (goto-char (point-min)) - (insert "\n\nFrom nobody " (current-time-string) "\n") - (insert "X-Gnus-Webmail: " (symbol-value 'user) - "@" (symbol-name webmail-type) "\n") - (if (eq (char-after) ?\n) - (delete-char 1)) - (mm-append-to-file (point-min) (point-max) file))) - (provide 'webmail) ;;; webmail.el ends here |