Mercurial > emacs
changeset 110250:77821d09740a
Merge from mainline.
author | Katsumi Yamaoka <yamaoka@jpl.org> |
---|---|
date | Mon, 06 Sep 2010 00:55:41 +0000 |
parents | c3d85dc16abc (current diff) 109e3a627792 (diff) |
children | 51163d71c385 |
files | |
diffstat | 11 files changed, 215 insertions(+), 376 deletions(-) [+] |
line wrap: on
line diff
--- a/lisp/ChangeLog Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/ChangeLog Mon Sep 06 00:55:41 2010 +0000 @@ -1,3 +1,32 @@ +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el (imap-message-map): Removed optional buffer parameter, + since no callers use it. + (imap-message-get): Ditto. + (imap-message-put): Ditto. + (imap-mailbox-map): Ditto. + (imap-mailbox-put): Ditto. + (imap-mailbox-get): Ditto. + (imap-mailbox-get): Revert last change for this function. + +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el (imap-fetch-safe): Removed function, and altered all + callers to use `imap-fetch' instead. According to the comments, this + should be safe, since all other IMAP clients use the 1:* syntax. + (imap-enable-exchange-bug-workaround): Removed. + (imap-debug): Removed -- doesn't seem very useful. + +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * net/imap.el (imap-log): New convenience function used throughout + instead of repeating the same code all over the place. + +2010-09-05 David De La Harpe Golden <david@harpegolden.net> + + * mouse.el (mouse-save-then-kill): Save region to kill-ring + when mouse-drag-copy-region is non-nil (Bug#6956). + 2010-09-05 Chong Yidong <cyd@stupidchicken.com> * dired.el (dired-ls-sorting-switches, dired-sort-by-name-regexp):
--- a/lisp/gnus/ChangeLog Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/ChangeLog Mon Sep 06 00:55:41 2010 +0000 @@ -1,3 +1,40 @@ +2010-09-05 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * gnus-start.el (gnus-get-unread-articles): Don't bother with groups + that aren't going to be activated. + (gnus-get-unread-articles): Fix up the last commit. + + * gnus-html.el (gnus-article-html): Allow calling without specifying + the handle. In that case, dissect the buffer first. + + * gnus-sum.el (gnus-set-mode-line): Don't pad the mode line string. + + * nnimap.el (nnimap-open-connection): Revert the change that would look + into authinfo for imaps instead of imap. + + * gnus-start.el (gnus-activate-group): Take an optional parameter to + say that you don't want to call gnus-request-group with don-check, but + do check the reponse. This is for virtual groups only. + (gnus-get-unread-articles): Count the archive groups as secondary, so + that they're activated the same way as before. + + * nnimap.el (nnimap-request-list): Servers may return \NoSelect + case-insensitively. + (nnimap-debug): Removed. + + * mail-source.el (mail-source-fetch): Don't message if we're fetching + mail from a file, and the file doesn't exist. + + * pop3.el (pop3-streaming-movemail): Return t for success. + + * nnimap.el (nnimap-open-connection): Look for the "imaps" entry in the + .authinfo if we're using ssl connection. + + * nnvirtual.el (nnvirtual-create-mapping): Use the active info we + already have if we're in a main Gnus `g' run. + + * gnus-start.el (gnus-method-rank): Get info for virtual groups last. + 2010-09-05 Katsumi Yamaoka <yamaoka@jpl.org> * gnus-start.el (gnus-method-rank): Replace equalp with equal.
--- a/lisp/gnus/gnus-html.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/gnus-html.el Mon Sep 06 00:55:41 2010 +0000 @@ -73,8 +73,10 @@ map)) ;;;###autoload -(defun gnus-article-html (handle) +(defun gnus-article-html (&optional handle) (let ((article-buffer (current-buffer))) + (unless handle + (setq handle (mm-dissect-buffer t))) (save-restriction (narrow-to-region (point) (point)) (save-excursion
--- a/lisp/gnus/gnus-start.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/gnus-start.el Mon Sep 06 00:55:41 2010 +0000 @@ -1526,7 +1526,8 @@ (when (> (cdr cache-active) (cdr active)) (setcdr active (cdr cache-active)))))))) -(defun gnus-activate-group (group &optional scan dont-check method) +(defun gnus-activate-group (group &optional scan dont-check method + dont-sub-check) "Check whether a group has been activated or not. If SCAN, request a scan of that group as well." (let ((method (or method (inline (gnus-find-method-for-group group)))) @@ -1541,9 +1542,11 @@ (gnus-request-scan group method)) t) (if (or debug-on-error debug-on-quit) - (inline (gnus-request-group group dont-check method)) + (inline (gnus-request-group group (or dont-sub-check dont-check) + method)) (condition-case nil - (inline (gnus-request-group group dont-check method)) + (inline (gnus-request-group group (or dont-sub-check dont-check) + method)) ;;(error nil) (quit (message "Quit activating %s" group) @@ -1685,6 +1688,7 @@ (methods-cache nil) (type-cache nil) (gnus-agent-article-local-times 0) + (archive-method (gnus-server-to-method "archive")) infos info group active method cmethod method-type method-group-list) (gnus-message 6 "Checking new news...") @@ -1720,7 +1724,9 @@ (unless method-group-list (setq method-type (cond - ((gnus-secondary-method-p method) + ((or (gnus-secondary-method-p method) + (and (gnus-archive-server-wanted-p) + (gnus-methods-equal-p archive-method method))) 'secondary) ((inline (gnus-server-equal gnus-select-method method)) 'primary) @@ -1728,8 +1734,13 @@ 'foreign))) (push (setq method-group-list (list method method-type nil)) type-cache)) - (setcar (nthcdr 2 method-group-list) - (cons info (nth 2 method-group-list)))) + ;; Only add groups that need updating. + (when (<= (gnus-info-level info) + (if (eq (cadr method-group-list) 'foreign) + foreign-level + alevel)) + (setcar (nthcdr 2 method-group-list) + (cons info (nth 2 method-group-list))))) ;; Sort the methods based so that the primary and secondary ;; methods come first. This is done for legacy reasons to try to @@ -1747,23 +1758,20 @@ infos (nth 2 (car type-cache))) (pop type-cache) - (when method + (when (and method + infos) ;; See if any of the groups from this method require updating. - (when (block nil - (dolist (info infos) - (when (<= (gnus-info-level info) - (if (eq method-type 'foreign) - foreign-level - alevel)) - (return t)))) - (gnus-read-active-for-groups method infos) - (dolist (info infos) - (inline (gnus-get-unread-articles-in-group - info (gnus-active (gnus-info-group info)))))))) + (gnus-read-active-for-groups method infos) + (dolist (info infos) + (inline (gnus-get-unread-articles-in-group + info (gnus-active (gnus-info-group info))))))) (gnus-message 6 "Checking new news...done"))) (defun gnus-method-rank (type method) (cond + ;; Get info for virtual groups last. + ((eq (car method) 'nnvirtual) + 200) ((eq type 'primary) 1) ;; Compute the rank of the secondary methods based on where they @@ -1793,7 +1801,7 @@ (gnus-read-active-file-1 method nil)) (t (dolist (info infos) - (gnus-activate-group (gnus-info-group info) nil nil method)))))) + (gnus-activate-group (gnus-info-group info) nil nil method t)))))) ;; Create a hash table out of the newsrc alist. The `car's of the ;; alist elements are used as keys.
--- a/lisp/gnus/gnus-sum.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/gnus-sum.el Mon Sep 06 00:55:41 2010 +0000 @@ -6051,9 +6051,7 @@ (when (> (length mode-string) max-len) (setq mode-string (concat (truncate-string-to-width mode-string (- max-len 3)) - "..."))) - ;; Pad the mode string a bit. - (setq mode-string (format (format "%%-%ds" max-len) mode-string)))) + "..."))))) ;; Update the mode line. (setq mode-line-buffer-identification (gnus-mode-line-buffer-identification (list mode-string)))
--- a/lisp/gnus/mail-source.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/mail-source.el Mon Sep 06 00:55:41 2010 +0000 @@ -544,11 +544,16 @@ (mail-source-bind-common source (if (or mail-source-plugged plugged) (save-excursion - (nnheader-message 4 "%sReading incoming mail from %s..." - (if method - (format "%s: " method) - "") - (car source)) + ;; Special-case the `file' handler since it's so common and + ;; just adds noise. + (when (or (not (eq (car source) 'file)) + (mail-source-bind (file source) + (file-exists-p path))) + (nnheader-message 4 "%sReading incoming mail from %s..." + (if method + (format "%s: " method) + "") + (car source))) (let ((function (cadr (assq (car source) mail-source-fetcher-alist))) (found 0)) (unless function
--- a/lisp/gnus/nnimap.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/nnimap.el Mon Sep 06 00:55:41 2010 +0000 @@ -588,11 +588,12 @@ (imap-mailbox-select decoded-group examine)) (let (minuid maxuid) (when (> (imap-mailbox-get 'exists) 0) - (imap-fetch-safe '("1,*" . "1,*:*") "UID" nil 'nouidfetch) - (imap-message-map (lambda (uid Uid) - (setq minuid (if minuid (min minuid uid) uid) - maxuid (if maxuid (max maxuid uid) uid))) - 'UID)) + (imap-fetch "1:*" "UID" nil 'nouidfetch) + (imap-message-map + (lambda (uid Uid) + (setq minuid (if minuid (min minuid uid) uid) + maxuid (if maxuid (max maxuid uid) uid))) + 'UID)) (list (imap-mailbox-get 'exists) minuid maxuid)))))) (defun nnimap-possibly-change-group (group &optional server) @@ -833,8 +834,8 @@ nnimap-authinfo-file) (netrc-parse nnimap-authinfo-file))) (port (if nnimap-server-port - (int-to-string nnimap-server-port) - "imap")) + (int-to-string nnimap-server-port) + "imap")) (auth-info (auth-source-user-or-password '("login" "password") server port)) (auth-user (nth 0 auth-info)) @@ -1114,14 +1115,16 @@ (dolist (pattern (nnimap-pattern-to-list-arguments nnimap-list-pattern)) (dolist (mbx (funcall nnimap-request-list-method (cdr pattern) (car pattern))) - (or (member "\\NoSelect" (imap-mailbox-get 'list-flags mbx)) - (let* ((encoded-mbx (nnimap-encode-group-name mbx)) - (info (nnimap-find-minmax-uid encoded-mbx 'examine))) - (when info - (with-current-buffer nntp-server-buffer - (insert (format "\"%s\" %d %d y\n" - encoded-mbx (or (nth 2 info) 0) - (max 1 (or (nth 1 info) 1))))))))))) + (unless (member "\\noselect" + (mapcar #'downcase + (imap-mailbox-get 'list-flags mbx))) + (let* ((encoded-mbx (nnimap-encode-group-name mbx)) + (info (nnimap-find-minmax-uid encoded-mbx 'examine))) + (when info + (with-current-buffer nntp-server-buffer + (insert (format "\"%s\" %d %d y\n" + encoded-mbx (or (nth 2 info) 0) + (max 1 (or (nth 1 info) 1))))))))))) (gnus-message 5 "nnimap: Generating active list%s...done" (if (> (length server) 0) (concat " for " server) "")) t)) @@ -1807,68 +1810,6 @@ "Return t if MARK can be permanently (between IMAP sessions) saved on articles, in GROUP." (imap-message-flag-permanent-p (nnimap-mark-to-flag mark))) -(when nnimap-debug - (require 'trace) - (buffer-disable-undo (get-buffer-create nnimap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f nnimap-debug-buffer)) - '( - nnimap-possibly-change-server - nnimap-verify-uidvalidity - nnimap-find-minmax-uid - nnimap-before-find-minmax-bugworkaround - nnimap-possibly-change-group - ;;nnimap-replace-whitespace - nnimap-retrieve-headers-progress - nnimap-retrieve-which-headers - nnimap-group-overview-filename - nnimap-retrieve-headers-from-file - nnimap-retrieve-headers-from-server - nnimap-retrieve-headers - nnimap-open-connection - nnimap-open-server - nnimap-server-opened - nnimap-close-server - nnimap-request-close - nnimap-status-message - ;;nnimap-demule - nnimap-request-article-part - nnimap-request-article - nnimap-request-head - nnimap-request-body - nnimap-request-group - nnimap-close-group - nnimap-pattern-to-list-arguments - nnimap-request-list - nnimap-request-post - nnimap-retrieve-groups - nnimap-request-update-info-internal - nnimap-request-type - nnimap-request-set-mark - nnimap-split-to-groups - nnimap-split-find-rule - nnimap-split-find-inbox - nnimap-split-articles - nnimap-request-scan - nnimap-request-newgroups - nnimap-request-create-group - nnimap-time-substract - nnimap-date-days-ago - nnimap-request-expire-articles-progress - nnimap-request-expire-articles - nnimap-request-move-article - nnimap-request-accept-article - nnimap-request-delete-group - nnimap-request-rename-group - gnus-group-nnimap-expunge - gnus-group-nnimap-edit-acl - gnus-group-nnimap-edit-acl-done - nnimap-group-mode-hook - nnimap-mark-to-predicate - nnimap-mark-to-flag-1 - nnimap-mark-to-flag - nnimap-mark-permanent-p - ))) - (provide 'nnimap) ;;; nnimap.el ends here
--- a/lisp/gnus/nnvirtual.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/nnvirtual.el Mon Sep 06 00:55:41 2010 +0000 @@ -260,13 +260,11 @@ (nnheader-report 'nnvirtual "No component groups in %s" group)) (t (setq nnvirtual-current-group group) - (when (or (not dont-check) - nnvirtual-always-rescan) - (nnvirtual-create-mapping) - (when nnvirtual-always-rescan - (nnvirtual-request-update-info - (nnvirtual-current-group) - (gnus-get-info (nnvirtual-current-group))))) + (nnvirtual-create-mapping dont-check) + (when nnvirtual-always-rescan + (nnvirtual-request-update-info + (nnvirtual-current-group) + (gnus-get-info (nnvirtual-current-group)))) (nnheader-insert "211 %d 1 %d %s\n" nnvirtual-mapping-len nnvirtual-mapping-len group)))) @@ -670,7 +668,7 @@ carticles)) -(defun nnvirtual-create-mapping () +(defun nnvirtual-create-mapping (dont-check) "Build the tables necessary to map between component (group, article) to virtual article. Generate the set of read messages and marks for the virtual group based on the marks on the component groups." @@ -689,7 +687,9 @@ ;; Into all-marks we put (g marks). ;; We also increment cnt and tot here, and compute M (max of sizes). (mapc (lambda (g) - (setq active (gnus-activate-group g) + (setq active (or (and dont-check + (gnus-active g)) + (gnus-activate-group g)) min (car active) max (cdr active)) (when (and active (>= max min) (not (zerop max)))
--- a/lisp/gnus/pop3.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/gnus/pop3.el Mon Sep 06 00:55:41 2010 +0000 @@ -145,7 +145,8 @@ (unless pop3-leave-mail-on-server (pop3-send-streaming-command process "DELE" message-count nil)))) - (pop3-quit process))) + (pop3-quit process) + t)) (defun pop3-send-streaming-command (process command count total-size) (erase-buffer)
--- a/lisp/mouse.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/mouse.el Mon Sep 06 00:55:41 2010 +0000 @@ -43,7 +43,10 @@ :group 'mouse) (defcustom mouse-drag-copy-region nil - "If non-nil, mouse drag copies region to kill-ring." + "If non-nil, copy to kill-ring upon mouse adjustments of the region. + +This affects `mouse-save-then-kill' (\\[mouse-save-then-kill]) in +addition to mouse drags." :type 'boolean :version "24.1" :group 'mouse) @@ -1348,8 +1351,13 @@ have selected whole words or lines, move point or mark to the word or line boundary closest to CLICK instead. +If `mouse-drag-copy-region' is non-nil, this command also saves the +new region to the kill ring (replacing the previous kill if the +previous region was just saved to the kill ring). + If this command is called a second consecutive time with the same -CLICK position, kill the region." +CLICK position, kill the region (or delete it +if `mouse-drag-copy-region' is non-nil)" (interactive "e") (mouse-minibuffer-check click) (let* ((posn (event-start click)) @@ -1371,7 +1379,11 @@ ((and (eq last-command 'mouse-save-then-kill) (eq click-pt mouse-save-then-kill-posn) (eq window (selected-window))) - (kill-region (mark t) (point)) + (if mouse-drag-copy-region + ;; Region already saved in the previous click; + ;; don't make a duplicate entry, just delete. + (delete-region (mark t) (point)) + (kill-region (mark t) (point))) (setq mouse-selection-click-count 0) (setq mouse-save-then-kill-posn nil)) @@ -1394,6 +1406,9 @@ (goto-char (nth 1 range))) (setq deactivate-mark nil) (mouse-set-region-1) + (when mouse-drag-copy-region + ;; Region already copied to kill-ring once, so replace. + (kill-new (filter-buffer-substring (mark t) (point)) t)) ;; Arrange for a repeated mouse-3 to kill the region. (setq mouse-save-then-kill-posn click-pt))) @@ -1405,6 +1420,8 @@ (if before-scroll (goto-char before-scroll))) (exchange-point-and-mark) (mouse-set-region-1) + (when mouse-drag-copy-region + (kill-new (filter-buffer-substring (mark t) (point)))) (setq mouse-save-then-kill-posn click-pt)))))
--- a/lisp/net/imap.el Sun Sep 05 22:45:59 2010 +0000 +++ b/lisp/net/imap.el Mon Sep 06 00:55:41 2010 +0000 @@ -448,18 +448,6 @@ The function should take two arguments, the first the IMAP tag and the second the status (OK, NO, BAD etc) of the command.") -(defvar imap-enable-exchange-bug-workaround nil - "Send FETCH UID commands as *:* instead of *. - -When non-nil, use an alternative UIDS form. Enabling appears to -be required for some servers (e.g., Microsoft Exchange 2007) -which otherwise would trigger a response 'BAD The specified -message set is invalid.'. We don't unconditionally use this -form, since this is said to be significantly inefficient. - -This variable is set to t automatically per server if the -canonical form fails.") - ;; Utility functions: @@ -515,6 +503,16 @@ ;; Server functions; stream stuff: +(defun imap-log (string-or-buffer) + (when imap-log + (with-current-buffer (get-buffer-create imap-log-buffer) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (if (bufferp string-or-buffer) + (insert-buffer-substring string-or-buffer) + (insert string-or-buffer))))) + (defun imap-kerberos4-stream-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) @@ -569,12 +567,6 @@ (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) (erase-buffer) (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd (if response (concat "done, " response) "failed")) @@ -645,12 +637,7 @@ (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (message "GSSAPI IMAP connection: %s" (or response "failed")) (if (and response (let ((case-fold-search nil)) @@ -701,12 +688,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process)))))) @@ -740,12 +722,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (memq (process-status process) '(open run)) process)))) @@ -764,12 +741,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (memq (process-status process) '(open run)) process)))) @@ -803,12 +775,7 @@ (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process))))) @@ -845,11 +812,7 @@ (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (and (setq tls-info (starttls-negotiate process)) (memq (process-status process) '(open run))) (setq done process))) @@ -1340,40 +1303,38 @@ ;; Mailbox functions: -(defun imap-mailbox-put (propname value &optional mailbox buffer) - (with-current-buffer (or buffer (current-buffer)) - (if imap-mailbox-data - (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) - propname value) - (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" - propname value mailbox (current-buffer))) - t)) +(defun imap-mailbox-put (propname value &optional mailbox) + (if imap-mailbox-data + (put (intern (or mailbox imap-current-mailbox) imap-mailbox-data) + propname value) + (error "Imap-mailbox-data is nil, prop %s value %s mailbox %s buffer %s" + propname value mailbox (current-buffer))) + t) (defsubst imap-mailbox-get-1 (propname &optional mailbox) (get (intern-soft (or mailbox imap-current-mailbox) imap-mailbox-data) propname)) (defun imap-mailbox-get (propname &optional mailbox buffer) - (let ((mailbox (imap-utf7-encode mailbox))) - (with-current-buffer (or buffer (current-buffer)) - (imap-mailbox-get-1 propname (or mailbox imap-current-mailbox))))) + (with-current-buffer (or buffer (current-buffer)) + (imap-mailbox-get-1 propname (or (imap-utf7-encode mailbox) + imap-current-mailbox)))) -(defun imap-mailbox-map-1 (func &optional mailbox-decoder buffer) - (with-current-buffer (or buffer (current-buffer)) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (if mailbox-decoder - (funcall mailbox-decoder (symbol-name s)) - (symbol-name s))) result)) - imap-mailbox-data) - result))) +(defun imap-mailbox-map-1 (func &optional mailbox-decoder) + (let (result) + (mapatoms + (lambda (s) + (push (funcall func (if mailbox-decoder + (funcall mailbox-decoder (symbol-name s)) + (symbol-name s))) result)) + imap-mailbox-data) + result)) -(defun imap-mailbox-map (func &optional buffer) +(defun imap-mailbox-map (func) "Map a function across each mailbox in `imap-mailbox-data', returning a list. Function should take a mailbox name (a string) as the only argument." - (imap-mailbox-map-1 func 'imap-utf7-decode buffer)) + (imap-mailbox-map-1 func 'imap-utf7-decode)) (defun imap-current-mailbox (&optional buffer) (with-current-buffer (or buffer (current-buffer)) @@ -1687,29 +1648,26 @@ uids) (imap-message-get uids receive)))))) -(defun imap-message-put (uid propname value &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (if imap-message-data - (put (intern (number-to-string uid) imap-message-data) - propname value) - (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" - uid propname value (current-buffer))) - t)) +(defun imap-message-put (uid propname value) + (if imap-message-data + (put (intern (number-to-string uid) imap-message-data) + propname value) + (error "Imap-message-data is nil, uid %s prop %s value %s buffer %s" + uid propname value (current-buffer))) + t) -(defun imap-message-get (uid propname &optional buffer) - (with-current-buffer (or buffer (current-buffer)) - (get (intern-soft (number-to-string uid) imap-message-data) - propname))) +(defun imap-message-get (uid propname) + (get (intern-soft (number-to-string uid) imap-message-data) + propname)) -(defun imap-message-map (func propname &optional buffer) +(defun imap-message-map (func propname) "Map a function across each message in `imap-message-data', returning a list." - (with-current-buffer (or buffer (current-buffer)) - (let (result) - (mapatoms - (lambda (s) - (push (funcall func (get s 'UID) (get s propname)) result)) - imap-message-data) - result))) + (let (result) + (mapatoms + (lambda (s) + (push (funcall func (get s 'UID) (get s propname)) result)) + imap-message-data) + result)) (defmacro imap-message-envelope-date (uid &optional buffer) `(with-current-buffer (or ,buffer (current-buffer)) @@ -1805,48 +1763,6 @@ (format "String %s cannot be converted to a Lisp integer" number)) number))) -(defun imap-fetch-safe (uids props &optional receive nouidfetch buffer) - "Like `imap-fetch', but DTRT with Exchange 2007 bug. -However, UIDS here is a cons, where the car is the canonical form -of the UIDS specification, and the cdr is the one which works with -Exchange 2007 or, potentially, other buggy servers. -See `imap-enable-exchange-bug-workaround'." - ;; The first time we get here for a given, we'll try the canonical - ;; form. If we get the known error from the buggy server, set the - ;; flag buffer-locally (to account for connections to multiple - ;; servers), then re-try with the alternative UIDS spec. We don't - ;; unconditionally use the alternative form, since the - ;; currently-used alternatives are seriously inefficient with some - ;; servers (although they are valid). - ;; - ;; FIXME: Maybe it would be cleaner to have a flag to not signal - ;; the error (which otherwise gives a message), and test - ;; `imap-failed-tags'. Also, Other IMAP clients use other forms of - ;; request which work with Exchange, e.g. Claws does "UID FETCH 1:* - ;; (UID)" rather than "FETCH UID 1,*". Is there a good reason not - ;; to do the same? - (condition-case data - ;; Binding `debug-on-error' allows us to get the error from - ;; `imap-parse-response' -- it's normally caught by Emacs around - ;; execution of a process filter. - (let ((debug-on-error t)) - (imap-fetch (if imap-enable-exchange-bug-workaround - (cdr uids) - (car uids)) - props receive nouidfetch buffer)) - (error - (if (and (not imap-enable-exchange-bug-workaround) - ;; This is the Exchange 2007 response. It may be more - ;; robust just to check for a BAD response to the - ;; attempted fetch. - (string-match "The specified message set is invalid" - (cadr data))) - (with-current-buffer (or buffer (current-buffer)) - (set (make-local-variable 'imap-enable-exchange-bug-workaround) - t) - (imap-fetch (cdr uids) props receive nouidfetch)) - (signal (car data) (cdr data)))))) - (defun imap-message-copyuid-1 (mailbox) (if (imap-capability 'UIDPLUS) (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) @@ -1856,7 +1772,7 @@ (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch-safe '("*" . "*:*") "UID") + (and (imap-fetch "*:*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1902,7 +1818,7 @@ (imap-message-data (make-vector 2 0))) (when (imap-mailbox-examine-1 mailbox) (prog1 - (and (imap-fetch-safe '("*" . "*:*") "UID") + (and (imap-fetch "*:*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map (lambda (uid prop) uid) 'UID)))) @@ -1959,12 +1875,7 @@ (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert cmdstr))) + (imap-log cmdstr) (process-send-string imap-process cmdstr)) (defun imap-send-command (command &optional buffer) @@ -2002,13 +1913,7 @@ (stream imap-stream) (eol imap-client-eol)) (with-current-buffer cmd - (and imap-log - (with-current-buffer (get-buffer-create - imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring cmd))) + (imap-log cmd) (process-send-region process (point-min) (point-max))) (process-send-string process imap-client-eol)))) @@ -2084,12 +1989,7 @@ (with-current-buffer (process-buffer proc) (goto-char (point-max)) (insert string) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert string))) + (imap-log string) (let (end) (goto-char (point-min)) (while (setq end (imap-find-next-line)) @@ -2992,105 +2892,6 @@ (imap-forward) (nreverse body))))) -(when imap-debug ; (untrace-all) - (require 'trace) - (buffer-disable-undo (get-buffer-create imap-debug-buffer)) - (mapc (lambda (f) (trace-function-background f imap-debug-buffer)) - '( - imap-utf7-encode - imap-utf7-decode - imap-error-text - imap-kerberos4s-p - imap-kerberos4-open - imap-ssl-p - imap-ssl-open - imap-network-p - imap-network-open - imap-interactive-login - imap-kerberos4a-p - imap-kerberos4-auth - imap-cram-md5-p - imap-cram-md5-auth - imap-login-p - imap-login-auth - imap-anonymous-p - imap-anonymous-auth - imap-open-1 - imap-open - imap-opened - imap-ping-server - imap-authenticate - imap-close - imap-capability - imap-namespace - imap-send-command-wait - imap-mailbox-put - imap-mailbox-get - imap-mailbox-map-1 - imap-mailbox-map - imap-current-mailbox - imap-current-mailbox-p-1 - imap-current-mailbox-p - imap-mailbox-select-1 - imap-mailbox-select - imap-mailbox-examine-1 - imap-mailbox-examine - imap-mailbox-unselect - imap-mailbox-expunge - imap-mailbox-close - imap-mailbox-create-1 - imap-mailbox-create - imap-mailbox-delete - imap-mailbox-rename - imap-mailbox-lsub - imap-mailbox-list - imap-mailbox-subscribe - imap-mailbox-unsubscribe - imap-mailbox-status - imap-mailbox-acl-get - imap-mailbox-acl-set - imap-mailbox-acl-delete - imap-current-message - imap-list-to-message-set - imap-fetch-asynch - imap-fetch - imap-fetch-safe - imap-message-put - imap-message-get - imap-message-map - imap-search - imap-message-flag-permanent-p - imap-message-flags-set - imap-message-flags-del - imap-message-flags-add - imap-message-copyuid-1 - imap-message-copyuid - imap-message-copy - imap-message-appenduid-1 - imap-message-appenduid - imap-message-append - imap-body-lines - imap-envelope-from - imap-send-command-1 - imap-send-command - imap-wait-for-tag - imap-sentinel - imap-find-next-line - imap-arrival-filter - imap-parse-greeting - imap-parse-response - imap-parse-resp-text - imap-parse-resp-text-code - imap-parse-data-list - imap-parse-fetch - imap-parse-status - imap-parse-acl - imap-parse-flag-list - imap-parse-envelope - imap-parse-body-extension - imap-parse-body - ))) - (provide 'imap) ;;; imap.el ends here