X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=f3cb77f5201f90407cb5f6276519f85046f40c79;hb=ec4494efb6e3c93d7aa42bd30c3dd612d4a0a289;hp=7f88685596d4080cc56cc6fd28881abc638b4535;hpb=37698126d1dba6bbcdf845ad1d5d0cf1e4380123;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 7f8868559..f3cb77f52 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -62,22 +62,23 @@ Values are `ssl', `network', `starttls' or `shell'.") (defvoo nnimap-inbox nil "The mail box where incoming mail arrives and should be split out of.") +(defvoo nnimap-split-methods nil + "How mail is split. +Uses the same syntax as nnmail-split-methods") + (defvoo nnimap-authenticator nil "How nnimap authenticate itself to the server. Possible choices are nil (use default methods) or `anonymous'.") -(defvoo nnimap-fetch-partial-articles nil - "If non-nil, nnimap will fetch partial articles. -If t, nnimap will fetch only the first part. If a string, it -will fetch all parts that have types that match that string. A -likely value would be \"text/\" to automatically fetch all -textual parts.") - (defvoo nnimap-expunge t "If non-nil, expunge articles after deleting them. This is always done if the server supports UID EXPUNGE, but it's not done by default on servers that doesn't support that command.") +(defvoo nnimap-streaming t + "If non-nil, try to use streaming commands with IMAP servers. +Switching this off will make nnimap slower, but it helps with +some servers.") (defvoo nnimap-connection-alist nil) @@ -110,8 +111,6 @@ not done by default on servers that doesn't support that command.") (download "gnus-download") (forward "gnus-forward"))) -(defvar nnimap-split-methods nil) - (defun nnimap-buffer () (nnimap-find-process-buffer nntp-server-buffer)) @@ -128,8 +127,7 @@ not done by default on servers that doesn't support that command.") (nnimap-article-ranges (gnus-compress-sequence articles)) (format "(UID RFC822.SIZE BODYSTRUCTURE %s)" (format - (if (member "IMAP4REV1" - (nnimap-capabilities nnimap-object)) + (if (nnimap-ver4-p) "BODY.PEEK[HEADER.FIELDS %s]" "RFC822.HEADER.LINES %s") (append '(Subject From Date Message-Id @@ -273,44 +271,52 @@ not done by default on servers that doesn't support that command.") (with-current-buffer (nnimap-make-process-buffer buffer) (let* ((coding-system-for-read 'binary) (coding-system-for-write 'binary) + (port nil) (ports (cond ((eq nnimap-stream 'network) (open-network-stream "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port - (if (netrc-find-service-number "imap") - "imap" - "143"))) + (setq port + (or nnimap-server-port + (if (netrc-find-service-number "imap") + "imap" + "143")))) '("143" "imap")) ((eq nnimap-stream 'shell) (nnimap-open-shell-stream "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port "imap")) + (setq port (or nnimap-server-port "imap"))) '("imap")) ((eq nnimap-stream 'starttls) (starttls-open-stream "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port "imap")) + (setq port (or nnimap-server-port "imap"))) '("imap")) ((eq nnimap-stream 'ssl) (open-tls-stream "*nnimap*" (current-buffer) nnimap-address - (or nnimap-server-port - (if (netrc-find-service-number "imaps") - "imaps" - "993"))) + (setq port + (or nnimap-server-port + (if (netrc-find-service-number "imaps") + "imaps" + "993")))) '("143" "993" "imap" "imaps")))) connection-result login-result credentials) (setf (nnimap-process nnimap-object) (get-buffer-process (current-buffer))) - (when (and (nnimap-process nnimap-object) - (memq (process-status (nnimap-process nnimap-object)) - '(open run))) + (if (not (and (nnimap-process nnimap-object) + (memq (process-status (nnimap-process nnimap-object)) + '(open run)))) + (nnheader-report 'nnimap "Unable to contact %s:%s via %s" + nnimap-address port nnimap-stream) (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil) - (when (setq connection-result (nnimap-wait-for-connection)) + (if (not (setq connection-result (nnimap-wait-for-connection))) + (nnheader-report 'nnimap + "%s" (buffer-substring + (point) (line-end-position))) (when (eq nnimap-stream 'starttls) - (nnimap-send-command "STARTTLS") + (nnimap-command "STARTTLS") (starttls-negotiate (nnimap-process nnimap-object))) (unless (equal connection-result "PREAUTH") (if (not (setq credentials @@ -370,7 +376,7 @@ not done by default on servers that doesn't support that command.") (deffoo nnimap-request-article (article &optional group server to-buffer) (with-current-buffer nntp-server-buffer (let ((result (nnimap-possibly-change-group group server)) - parts) + parts structure) (when (stringp article) (setq article (nnimap-find-article-by-message-id group article))) (when (and result @@ -378,36 +384,113 @@ not done by default on servers that doesn't support that command.") (erase-buffer) (with-current-buffer (nnimap-buffer) (erase-buffer) - (when nnimap-fetch-partial-articles - (if (eq nnimap-fetch-partial-articles t) + (when gnus-fetch-partial-articles + (if (eq gnus-fetch-partial-articles t) (setq parts '(1)) (nnimap-command "UID FETCH %d (BODYSTRUCTURE)" article) (goto-char (point-min)) (when (re-search-forward "FETCH.*BODYSTRUCTURE" nil t) - (let ((structure (ignore-errors (read (current-buffer))))) - (setq parts (nnimap-find-wanted-parts structure)))))) - (setq result - (nnimap-command - (if (member "IMAP4REV1" (nnimap-capabilities nnimap-object)) - "UID FETCH %d BODY.PEEK[]" - "UID FETCH %d RFC822.PEEK") - article)) - ;; Check that we really got an article. - (goto-char (point-min)) - (unless (looking-at "\\* [0-9]+ FETCH") - (setq result nil))) - (let ((buffer (nnimap-find-process-buffer (current-buffer)))) - (when (car result) - (with-current-buffer (or to-buffer nntp-server-buffer) - (insert-buffer-substring buffer) - (goto-char (point-min)) - (let ((bytes (nnimap-get-length))) - (delete-region (line-beginning-position) - (progn (forward-line 1) (point))) - (goto-char (+ (point) bytes)) - (delete-region (point) (point-max)) - (nnheader-ms-strip-cr)) - (cons group article)))))))) + (setq structure (ignore-errors (read (current-buffer))) + parts (nnimap-find-wanted-parts structure))))) + (when (if parts + (nnimap-get-partial-article article parts structure) + (nnimap-get-whole-article article)) + (let ((buffer (current-buffer))) + (with-current-buffer (or to-buffer nntp-server-buffer) + (erase-buffer) + (insert-buffer-substring buffer) + (nnheader-ms-strip-cr) + (cons group article))))))))) + +(defun nnimap-get-whole-article (article) + (let ((result + (nnimap-command + (if (nnimap-ver4-p) + "UID FETCH %d BODY.PEEK[]" + "UID FETCH %d RFC822.PEEK") + article))) + ;; Check that we really got an article. + (goto-char (point-min)) + (unless (looking-at "\\* [0-9]+ FETCH") + (setq result nil)) + (when result + (goto-char (point-min)) + (let ((bytes (nnimap-get-length))) + (delete-region (line-beginning-position) + (progn (forward-line 1) (point))) + (goto-char (+ (point) bytes)) + (delete-region (point) (point-max))) + t))) + +(defun nnimap-ver4-p () + (member "IMAP4REV1" (nnimap-capabilities nnimap-object))) + +(defun nnimap-get-partial-article (article parts structure) + (let ((result + (nnimap-command + "UID FETCH %d (%s %s)" + article + (if (nnimap-ver4-p) + "BODY.PEEK[HEADER]" + "RFC822.HEADER") + (if (nnimap-ver4-p) + (mapconcat (lambda (part) + (format "BODY.PEEK[%s]" part)) + parts " ") + (mapconcat (lambda (part) + (format "RFC822.PEEK[%s]" part)) + parts " "))))) + (when result + (nnimap-convert-partial-article structure)))) + +(defun nnimap-convert-partial-article (structure) + ;; First just skip past the headers. + (goto-char (point-min)) + (let ((bytes (nnimap-get-length)) + id parts) + ;; Delete "FETCH" line. + (delete-region (line-beginning-position) + (progn (forward-line 1) (point))) + (goto-char (+ (point) bytes)) + ;; Collect all the body parts. + (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]") + (setq id (match-string 1) + bytes (nnimap-get-length)) + (beginning-of-line) + (delete-region (point) (progn (forward-line 1) (point))) + (push (list id (buffer-substring (point) (+ (point) bytes))) + parts) + (delete-region (point) (+ (point) bytes))) + ;; Delete trailing junk. + (delete-region (point) (point-max)) + ;; Now insert all the parts again where they fit in the structure. + (nnimap-insert-partial-structure structure 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)))))) + (when subp + (insert (format "Content-type: multipart/%s; boundary=%S\n\n" + (downcase type) boundary))) + (while (not (stringp (car structure))) + (insert "\n--" boundary "\n") + (if (consp (caar structure)) + (nnimap-insert-partial-structure (pop structure) parts t) + (let ((bit (pop structure))) + (insert (format "Content-type: %s/%s" + (downcase (nth 0 bit)) + (downcase (nth 1 bit)))) + (if (member "CHARSET" (nth 2 bit)) + (insert (format + "; charset=%S\n" (cadr (member "CHARSET" (nth 2 bit))))) + (insert "\n")) + (insert (format "Content-transfer-encoding: %s\n" + (nth 5 bit))) + (insert "\n") + (when (assoc (nth 9 bit) parts) + (insert (cadr (assoc (nth 9 bit) parts))))))) + (insert "\n--" boundary "--\n"))) (defun nnimap-find-wanted-parts (structure) (message-flatten-list (nnimap-find-wanted-parts-1 structure ""))) @@ -423,13 +506,14 @@ not done by default on servers that doesn't support that command.") (number-to-string num) (format "%s.%s" prefix num))) parts) - (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub)))) - (when (string-match nnimap-fetch-partial-articles type) - (push (if (string= prefix "") + (let ((type (format "%s/%s" (nth 0 sub) (nth 1 sub))) + (id (if (string= prefix "") (number-to-string num) - (format "%s.%s" prefix num)) - parts))) - (incf num)))) + (format "%s.%s" prefix num)))) + (setcar (nthcdr 9 sub) id) + (when (string-match gnus-fetch-partial-articles type) + (push id parts)))) + (incf num))) (nreverse parts))) (deffoo nnimap-request-group (group &optional server dont-check info) @@ -777,7 +861,12 @@ not done by default on servers that doesn't support that command.") (nnimap-send-command "UID FETCH %d:* FLAGS" start) start (car elem)) - sequences)))) + sequences))) + ;; Some servers apparently can't have many outstanding + ;; commands, so throttle them. + (when (and (not nnimap-streaming) + (car sequences)) + (nnimap-wait-for-response (caar sequences)))) sequences)))) (deffoo nnimap-finish-retrieve-group-infos (server infos sequences) @@ -785,26 +874,26 @@ not done by default on servers that doesn't support that command.") (nnimap-possibly-change-group nil server)) (with-current-buffer (nnimap-buffer) ;; Wait for the final data to trickle in. - (nnimap-wait-for-response (cadar sequences)) - ;; Now we should have all the data we need, no matter whether - ;; we're QRESYNCING, fetching all the flags from scratch, or - ;; just fetching the last 100 flags per group. - (nnimap-update-infos (nnimap-flags-to-marks - (nnimap-parse-flags - (nreverse sequences))) - infos) - ;; Finally, just return something resembling an active file in - ;; the nntp buffer, so that the agent can save the info, too. - (with-current-buffer nntp-server-buffer - (erase-buffer) - (dolist (info infos) - (let* ((group (gnus-info-group info)) - (active (gnus-active group))) - (when active - (insert (format "%S %d %d y\n" - (gnus-group-real-name group) - (cdr active) - (car active)))))))))) + (when (nnimap-wait-for-response (cadar sequences)) + ;; Now we should have all the data we need, no matter whether + ;; we're QRESYNCING, fetching all the flags from scratch, or + ;; just fetching the last 100 flags per group. + (nnimap-update-infos (nnimap-flags-to-marks + (nnimap-parse-flags + (nreverse sequences))) + infos) + ;; Finally, just return something resembling an active file in + ;; the nntp buffer, so that the agent can save the info, too. + (with-current-buffer nntp-server-buffer + (erase-buffer) + (dolist (info infos) + (let* ((group (gnus-info-group info)) + (active (gnus-active group))) + (when active + (insert (format "%S %d %d y\n" + (gnus-group-real-name group) + (cdr active) + (car active))))))))))) (defun nnimap-update-infos (flags infos) (dolist (info infos) @@ -824,12 +913,20 @@ not done by default on servers that doesn't support that command.") (if (or completep (not (gnus-active group))) (gnus-set-active group - (if (and low high) - (cons low high) + (cond + ((and low high) + (cons low high)) + (uidnext ;; No articles in this group. - (cons uidnext (1- uidnext)))) + (cons uidnext (1- uidnext))) + (start-article + (cons start-article (1- start-article))) + (t + ;; No articles and no uidnext. + nil))) (setcdr (gnus-active group) (or high (1- uidnext)))) - (unless high + (when (and (not high) + uidnext) (setq high (1- uidnext))) ;; Then update the list of read articles. (let* ((unread @@ -1037,17 +1134,22 @@ not done by default on servers that doesn't support that command.") (match-string 1)))) (defun nnimap-wait-for-response (sequence &optional messagep) - (let ((process (get-buffer-process (current-buffer)))) + (let ((process (get-buffer-process (current-buffer))) + openp) (goto-char (point-max)) - (while (and (memq (process-status process) - '(open run)) - (not (re-search-backward (format "^%d .*\n" sequence) - (max (point-min) (- (point) 500)) - t))) + (while (and (setq openp (memq (process-status process) + '(open run))) + (not (re-search-backward + (format "^%d .*\n" sequence) + (if nnimap-streaming + (max (point-min) (- (point) 500)) + (point-min)) + t))) (when messagep (message "Read %dKB" (/ (buffer-size) 1000))) (nnheader-accept-process-output process) - (goto-char (point-max))))) + (goto-char (point-max))) + openp)) (defun nnimap-parse-response () (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) @@ -1121,8 +1223,7 @@ not done by default on servers that doesn't support that command.") (nnimap-article-ranges articles) (format "(UID %s%s)" (format - (if (member "IMAP4REV1" - (nnimap-capabilities nnimap-object)) + (if (nnimap-ver4-p) "BODY.PEEK[HEADER] BODY.PEEK" "RFC822.PEEK")) (if nnimap-split-download-body-default