X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=f9013bc266dd08dae3835d7db7e0007b2fa26f4b;hb=4f25b95aa4e068a6cba478de95115e2ea1ca2b09;hp=63b468ca13d904779b10bf3bdf2b795e57a0cd29;hpb=ab852d855212572cf219d1e446eb6db3cea1081d;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 63b468ca1..f9013bc26 100644 --- a/lisp/nnimap.el +++ b/lisp/nnimap.el @@ -37,6 +37,7 @@ (require 'gnus) (require 'nnoo) (require 'netrc) +(require 'parse-time) (nnoo-declare nnimap) @@ -50,7 +51,7 @@ it will default to `imap'.") (defvoo nnimap-stream 'ssl "How nnimap will talk to the IMAP server. -Values are `ssl' and `network'.") +Values are `ssl', `network', `starttls' or `shell'.") (defvoo nnimap-shell-program (if (boundp 'imap-shell-program) (if (listp imap-shell-program) @@ -61,11 +62,23 @@ Values are `ssl' and `network'.") (defvoo nnimap-inbox nil "The mail box where incoming mail arrives and should be split out of.") -(defvoo nnimap-expunge-inbox nil - "If non-nil, expunge the inbox after fetching mail. +(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-connection-alist nil) (defvoo nnimap-current-infos nil) @@ -78,14 +91,15 @@ not done by default on servers that doesn't support that command.") "Internal variable with default value for `nnimap-split-download-body'.") (defstruct nnimap - group process commands capabilities select-result) + group process commands capabilities select-result newlinep server + last-command-time) (defvar nnimap-object nil) (defvar nnimap-mark-alist - '((read "\\Seen") - (tick "\\Flagged") - (reply "\\Answered") + '((read "\\Seen" %Seen) + (tick "\\Flagged" %Flagged) + (reply "\\Answered" %Answered) (expire "gnus-expire") (dormant "gnus-dormant") (score "gnus-score") @@ -122,23 +136,37 @@ not done by default on servers that doesn't support that command.") (nnimap-transform-headers)) (insert-buffer-substring (nnimap-find-process-buffer (current-buffer)))) - t)) + 'headers)) (defun nnimap-transform-headers () (goto-char (point-min)) - (let (article bytes lines) + (let (article bytes lines size string) (block nil (while (not (eobp)) (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) (delete-region (point) (progn (forward-line 1) (point))) (when (eobp) (return))) - (setq article (match-string 1) - bytes (nnimap-get-length) + (setq article (match-string 1)) + ;; Unfold quoted {number} strings. + (while (re-search-forward "[^]] {\\([0-9]+\\)}\r\n" + (1+ (line-end-position)) t) + (setq size (string-to-number (match-string 1))) + (delete-region (+ (match-beginning 0) 2) (point)) + (setq string (delete-region (point) (+ (point) size))) + (insert (format "%S" string))) + (setq bytes (nnimap-get-length) lines nil) (beginning-of-line) + (setq size + (and (re-search-forward "RFC822.SIZE \\([0-9]+\\)" + (line-end-position) + t) + (match-string 1))) + (beginning-of-line) (when (search-forward "BODYSTRUCTURE" (line-end-position) t) - (let ((structure (ignore-errors (read (current-buffer))))) + (let ((structure (ignore-errors + (read (current-buffer))))) (while (and (consp structure) (not (stringp (car structure)))) (setq structure (car structure))) @@ -146,7 +174,8 @@ not done by default on servers that doesn't support that command.") (delete-region (line-beginning-position) (line-end-position)) (insert (format "211 %s Article retrieved." article)) (forward-line 1) - (insert (format "Bytes: %d\n" bytes)) + (when size + (insert (format "Chars: %s\n" size))) (when lines (insert (format "Lines: %s\n" lines))) (re-search-forward "^\r$") @@ -192,19 +221,20 @@ not done by default on servers that doesn't support that command.") (buffer-disable-undo) (gnus-add-buffer) (set (make-local-variable 'after-change-functions) nil) - (set (make-local-variable 'nnimap-object) (make-nnimap)) + (set (make-local-variable 'nnimap-object) + (make-nnimap :server (nnoo-current-server 'nnimap))) (push (list buffer (current-buffer)) nnimap-connection-alist) (current-buffer))) (defun nnimap-open-shell-stream (name buffer host port) - (let ((process (start-process name buffer shell-file-name - shell-command-switch - (format-spec - nnimap-shell-program - (format-spec-make - ?s host - ?p port))))) - process)) + (let ((process-connection-type nil)) + (start-process name buffer shell-file-name + shell-command-switch + (format-spec + nnimap-shell-program + (format-spec-make + ?s host + ?p port))))) (defun nnimap-credentials (address ports) (let (port credentials) @@ -236,6 +266,11 @@ not done by default on servers that doesn't support that command.") "*nnimap*" (current-buffer) nnimap-address (or nnimap-server-port "imap")) '("imap")) + ((eq nnimap-stream 'starttls) + (starttls-open-stream + "*nnimap*" (current-buffer) nnimap-address + (or nnimap-server-port "imap")) + '("imap")) ((eq nnimap-stream 'ssl) (open-tls-stream "*nnimap*" (current-buffer) nnimap-address @@ -252,9 +287,19 @@ not done by default on servers that doesn't support that command.") '(open run))) (gnus-set-process-query-on-exit-flag (nnimap-process nnimap-object) nil) (when (setq connection-result (nnimap-wait-for-connection)) + (when (eq nnimap-stream 'starttls) + (nnimap-send-command "STARTTLS") + (starttls-negotiate (nnimap-process nnimap-object))) (unless (equal connection-result "PREAUTH") (if (not (setq credentials - (nnimap-credentials nnimap-address ports))) + (if (eq nnimap-authenticator 'anonymous) + (list "anonymous" + (message-make-address)) + (nnimap-credentials + nnimap-address + (if nnimap-server-port + (cons (format "%s" nnimap-server-port) ports) + ports))))) (setq nnimap-object nil) (setq login-result (nnimap-command "LOGIN %S %S" (car credentials) @@ -302,7 +347,8 @@ 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))) + (let ((result (nnimap-possibly-change-group group server)) + parts) (when (stringp article) (setq article (nnimap-find-article-by-message-id group article))) (when (and result @@ -310,15 +356,27 @@ 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) + (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))) + 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 to-buffer + (with-current-buffer (or to-buffer nntp-server-buffer) (insert-buffer-substring buffer) (goto-char (point-min)) (let ((bytes (nnimap-get-length))) @@ -327,12 +385,35 @@ not done by default on servers that doesn't support that command.") (goto-char (+ (point) bytes)) (delete-region (point) (point-max)) (nnheader-ms-strip-cr)) - t))))))) + (cons group article)))))))) + +(defun nnimap-find-wanted-parts (structure) + (message-flatten-list (nnimap-find-wanted-parts-1 structure ""))) + +(defun nnimap-find-wanted-parts-1 (structure prefix) + (let ((num 1) + parts) + (while (consp (car structure)) + (let ((sub (pop structure))) + (if (consp (car sub)) + (push (nnimap-find-wanted-parts-1 + sub (if (string= prefix "") + (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 "") + (number-to-string num) + (format "%s.%s" prefix num)) + parts))) + (incf num)))) + (nreverse parts))) (deffoo nnimap-request-group (group &optional server dont-check info) - (with-current-buffer nntp-server-buffer - (let ((result (nnimap-possibly-change-group group server)) - articles active marks high low) + (let ((result (nnimap-possibly-change-group group server)) + articles active marks high low) + (with-current-buffer nntp-server-buffer (when result (if (and dont-check (setq active (nth 2 (assoc group nnimap-current-infos)))) @@ -344,7 +425,7 @@ not done by default on servers that doesn't support that command.") (with-current-buffer (nnimap-buffer) (erase-buffer) (let ((group-sequence - (nnimap-send-command "SELECT %S" (utf7-encode group))) + (nnimap-send-command "SELECT %S" (utf7-encode group t))) (flag-sequence (nnimap-send-command "UID FETCH 1:* FLAGS"))) (nnimap-wait-for-response flag-sequence) @@ -355,20 +436,31 @@ not done by default on servers that doesn't support that command.") (when info (nnimap-update-infos marks (list info))) (goto-char (point-max)) - (cond - (marks - (setq high (nth 3 (car marks)) - low (nth 4 (car marks)))) - ((re-search-backward "UIDNEXT \\([0-9]+\\)" nil t) - (setq high (string-to-number (match-string 1)) - low 1))))) + (let ((uidnext (nth 5 (car marks)))) + (setq high (if uidnext + (1- uidnext) + (nth 3 (car marks))) + low (or (nth 4 (car marks)) uidnext))))) (erase-buffer) (insert (format - "211 %d %d %d %S\n" - (1+ (- high low)) - low high group)))) - t))) + "211 %d %d %d %S\n" (1+ (- high low)) low high group))) + t)))) + +(deffoo nnimap-request-create-group (group &optional server args) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "CREATE %S" (utf7-encode group t)))))) + +(deffoo nnimap-request-delete-group (group &optional force server) + (when (nnimap-possibly-change-group nil server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "DELETE %S" (utf7-encode group t)))))) + +(deffoo nnimap-request-expunge-group (group &optional server) + (when (nnimap-possibly-change-group group server) + (with-current-buffer (nnimap-buffer) + (car (nnimap-command "EXPUNGE"))))) (defun nnimap-get-flags (spec) (let ((articles nil) @@ -390,22 +482,23 @@ not done by default on servers that doesn't support that command.") (deffoo nnimap-request-move-article (article group server accept-form &optional last internal-move-group) - (when (nnimap-possibly-change-group group server) - ;; If the move is internal (on the same server), just do it the easy - ;; way. - (let ((message-id (message-field-value "message-id"))) - (if internal-move-group - (let ((result - (with-current-buffer (nnimap-buffer) - (nnimap-command "UID COPY %d %S" - article - (utf7-encode internal-move-group t))))) - (when (car result) - (nnimap-delete-article article) - (cons internal-move-group - (nnimap-find-article-by-message-id - internal-move-group message-id)))) - (with-temp-buffer + (with-temp-buffer + (when (nnimap-request-article article group server (current-buffer)) + ;; If the move is internal (on the same server), just do it the easy + ;; way. + (let ((message-id (message-field-value "message-id"))) + (if internal-move-group + (let ((result + (with-current-buffer (nnimap-buffer) + (nnimap-command "UID COPY %d %S" + article + (utf7-encode internal-move-group t))))) + (when (car result) + (nnimap-delete-article article) + (cons internal-move-group + (nnimap-find-article-by-message-id + internal-move-group message-id)))) + ;; Move the article to a different method. (let ((result (eval accept-form))) (when result (nnimap-delete-article article) @@ -413,14 +506,72 @@ not done by default on servers that doesn't support that command.") (deffoo nnimap-request-expire-articles (articles group &optional server force) (cond + ((null articles) + nil) ((not (nnimap-possibly-change-group group server)) articles) - (force + ((and force + (eq nnmail-expiry-target 'delete)) (unless (nnimap-delete-article articles) (message "Article marked for deletion, but not expunged.")) nil) (t - articles))) + (let ((deletable-articles + (if (or force + (eq nnmail-expiry-wait 'immediate)) + articles + (gnus-sorted-intersection + articles + (nnimap-find-expired-articles group))))) + (if (null deletable-articles) + articles + (if (eq nnmail-expiry-target 'delete) + (nnimap-delete-article deletable-articles) + (setq deletable-articles + (nnimap-process-expiry-targets + deletable-articles group server))) + ;; Return the articles we didn't delete. + (gnus-sorted-complement articles deletable-articles)))))) + +(defun nnimap-process-expiry-targets (articles group server) + (let ((deleted-articles nil)) + (dolist (article articles) + (let ((target nnmail-expiry-target)) + (with-temp-buffer + (when (nnimap-request-article article group server (current-buffer)) + (message "Expiring article %s:%d" group article) + (when (functionp target) + (setq target (funcall target group))) + (when (and target + (not (eq target 'delete))) + (if (or (gnus-request-group target t) + (gnus-request-create-group target)) + (nnmail-expiry-target-group target group) + (setq target nil))) + (when target + (push article deleted-articles)))))) + ;; Change back to the current group again. + (nnimap-possibly-change-group group server) + (setq deleted-articles (nreverse deleted-articles)) + (nnimap-delete-article deleted-articles) + deleted-articles)) + +(defun nnimap-find-expired-articles (group) + (let ((cutoff (nnmail-expired-article-p group nil nil))) + (with-current-buffer (nnimap-buffer) + (let ((result + (nnimap-command + "UID SEARCH SENTBEFORE %s" + (format-time-string + (format "%%d-%s-%%Y" + (upcase + (car (rassoc (nth 4 (decode-time cutoff)) + parse-time-months)))) + cutoff)))) + (and (car result) + (delete 0 (mapcar #'string-to-number + (cdr (assoc "SEARCH" (cdr result)))))))))) + (defun nnimap-find-article-by-message-id (group message-id) (when (nnimap-possibly-change-group group nil) @@ -438,16 +589,23 @@ not done by default on servers that doesn't support that command.") (with-current-buffer (nnimap-buffer) (nnimap-command "UID STORE %s +FLAGS.SILENT (\\Deleted)" (nnimap-article-ranges articles)) - (when (member "UIDPLUS" (nnimap-capabilities nnimap-object)) - (nnimap-send-command "UID EXPUNGE %s" - (nnimap-article-ranges articles)) - t))) + (cond + ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + (nnimap-command "UID EXPUNGE %s" + (nnimap-article-ranges articles)) + t) + (nnimap-expunge + (nnimap-command "EXPUNGE") + t) + (t (gnus-message 7 (concat "nnimap: nnimap-expunge is not set and the " + "server doesn't support UIDPLUS, so we won't " + "delete this article now")))))) (deffoo nnimap-request-scan (&optional group server) (when (and (nnimap-possibly-change-group nil server) - (equal group nnimap-inbox) nnimap-inbox nnimap-split-methods) + (message "nnimap %s splitting mail..." server) (nnimap-split-incoming-mail))) (defun nnimap-marks-to-flags (marks) @@ -476,7 +634,8 @@ not done by default on servers that doesn't support that command.") (mapconcat #'identity flags " "))))))) ;; Wait for the last command to complete to avoid later ;; syncronisation problems with the stream. - (nnimap-wait-for-response sequence))))) + (when sequence + (nnimap-wait-for-response sequence)))))) (deffoo nnimap-request-accept-article (group &optional server last) (when (nnimap-possibly-change-group nil server) @@ -489,7 +648,10 @@ not done by default on servers that doesn't support that command.") "APPEND %S {%d}" (utf7-encode group t) (length message))) (process-send-string (get-buffer-process (current-buffer)) message) - (process-send-string (get-buffer-process (current-buffer)) "\r\n") + (process-send-string (get-buffer-process (current-buffer)) + (if (nnimap-newlinep nnimap-object) + "\n" + "\r\n")) (let ((result (nnimap-get-response sequence))) (when result (cons group @@ -521,6 +683,7 @@ not done by default on servers that doesn't support that command.") sequences responses) (when groups (with-current-buffer (nnimap-buffer) + (setf (nnimap-group nnimap-object) nil) (dolist (group groups) (push (list (nnimap-send-command "EXAMINE %S" (utf7-encode group t)) group) @@ -570,6 +733,7 @@ not done by default on servers that doesn't support that command.") groups)) ;; Then request the data. (erase-buffer) + (setf (nnimap-group nnimap-object) nil) (dolist (elem groups) (if (and qresyncp (nth 2 elem)) @@ -606,7 +770,19 @@ not done by default on servers that doesn't support that command.") (nnimap-update-infos (nnimap-flags-to-marks (nnimap-parse-flags (nreverse sequences))) - infos)))) + 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) @@ -615,27 +791,32 @@ not done by default on servers that doesn't support that command.") (defun nnimap-update-info (info marks) (when marks - (destructuring-bind (existing flags high low uidnext start-article) marks + (destructuring-bind (existing flags high low uidnext start-article + permanent-flags) marks (let ((group (gnus-info-group info)) (completep (and start-article (= start-article 1)))) + (when uidnext + (setq high (1- uidnext))) ;; First set the active ranges based on high/low. (if (or completep (not (gnus-active group))) (gnus-set-active group - (if high + (if (and low high) (cons low high) ;; No articles in this group. - (cons (1- uidnext) uidnext))) - (setcdr (gnus-active group) high)) + (cons uidnext (1- uidnext)))) + (setcdr (gnus-active group) (or high (1- uidnext)))) + (unless high + (setq high (1- uidnext))) ;; Then update the list of read articles. (let* ((unread (gnus-compress-sequence (gnus-set-difference (gnus-set-difference existing - (cdr (assoc "\\Seen" flags))) - (cdr (assoc "\\Flagged" flags))))) + (cdr (assoc '%Seen flags))) + (cdr (assoc '%Flagged flags))))) (read (gnus-range-difference (cons start-article high) unread))) (when (> start-article 1) @@ -657,8 +838,11 @@ not done by default on servers that doesn't support that command.") (push (cons 'active (gnus-active group)) marks))) (dolist (type (cdr nnimap-mark-alist)) (let ((old-marks (assoc (car type) marks)) - (new-marks (gnus-compress-sequence - (cdr (assoc (cadr type) flags))))) + (new-marks + (gnus-compress-sequence + (cdr (or (assoc (caddr type) flags) ; %Flagged + (assoc (intern (cadr type) obarray) flags) + (assoc (cadr type) flags)))))) ; "\Flagged" (setq marks (delq old-marks marks)) (pop old-marks) (when (and old-marks @@ -680,12 +864,13 @@ not done by default on servers that doesn't support that command.") (push (list group info active) nnimap-current-infos)))) (defun nnimap-flags-to-marks (groups) - (let (data group totalp uidnext articles start-article mark) + (let (data group totalp uidnext articles start-article mark permanent-flags) (dolist (elem groups) (setq group (car elem) - uidnext (cadr elem) - start-article (caddr elem) - articles (cdddr elem)) + uidnext (nth 1 elem) + start-article (nth 2 elem) + permanent-flags (nth 3 elem) + articles (nthcdr 4 elem)) (let ((high (caar articles)) marks low existing) (dolist (article articles) @@ -695,36 +880,49 @@ not done by default on servers that doesn't support that command.") (setq mark (assoc flag marks)) (if (not mark) (push (list flag (car article)) marks) - (setcdr mark (cons (car article) (cdr mark))))) - (push (list group existing marks high low uidnext start-article) - data)))) + (setcdr mark (cons (car article) (cdr mark)))))) + (push (list group existing marks high low uidnext start-article + permanent-flags) + data))) data)) (defun nnimap-parse-flags (sequences) (goto-char (point-min)) - (let (start end articles groups uidnext elems) + ;; Change \Delete etc to %Delete, so that the reader can read it. + (subst-char-in-region (point-min) (point-max) + ?\\ ?% t) + (let (start end articles groups uidnext elems permanent-flags) (dolist (elem sequences) (destructuring-bind (group-sequence flag-sequence totalp group) elem + (setq start (point)) ;; The EXAMINE was successful. (when (and (search-forward (format "\n%d OK " group-sequence) nil t) (progn (forward-line 1) - (setq start (point)) - (if (re-search-backward "UIDNEXT \\([0-9]+\\)" - (or end (point-min)) t) - (setq uidnext (string-to-number (match-string 1))) - (setq uidnext nil)) - (goto-char start)) + (setq end (point)) + (goto-char start) + (setq permanent-flags + (and (search-forward "PERMANENTFLAGS " + (or end (point-min)) t) + (read (current-buffer)))) + (goto-char start) + (setq uidnext + (and (search-forward "UIDNEXT " + (or end (point-min)) t) + (read (current-buffer)))) + (goto-char end) + (forward-line -1)) ;; The UID FETCH FLAGS was successful. (search-forward (format "\n%d OK " flag-sequence) nil t)) - (setq end (point)) - (goto-char start) - (while (re-search-forward "^\\* [0-9]+ FETCH (\\(.*\\))" end t) - (setq elems (nnimap-parse-line (match-string 1))) - (push (cons (string-to-number (cadr (member "UID" elems))) - (cadr (member "FLAGS" elems))) + (setq start (point)) + (goto-char end) + (while (search-forward " FETCH " start t) + (setq elems (read (current-buffer))) + (push (cons (cadr (memq 'UID elems)) + (cadr (memq 'FLAGS elems))) articles)) - (push (nconc (list group uidnext totalp) articles) groups) + (push (nconc (list group uidnext totalp permanent-flags) articles) + groups) (setq articles nil)))) groups)) @@ -773,9 +971,12 @@ not done by default on servers that doesn't support that command.") (process-send-string (get-buffer-process (current-buffer)) (nnimap-log-command - (format "%d %s\r\n" + (format "%d %s%s\n" (incf nnimap-sequence) - (apply #'format args)))) + (apply #'format args) + (if (nnimap-newlinep nnimap-object) + "" + "\r")))) nnimap-sequence) (defun nnimap-log-command (command) @@ -786,12 +987,15 @@ not done by default on servers that doesn't support that command.") (defun nnimap-command (&rest args) (erase-buffer) + (setf (nnimap-last-command-time) (current-time)) (let* ((sequence (apply #'nnimap-send-command args)) (response (nnimap-get-response sequence))) (if (equal (caar response) "OK") (cons t response) (nnheader-report 'nnimap "%s" - (mapconcat #'identity (car response) " ")) + (mapconcat (lambda (a) + (format "%s" a)) + (car response) " ")) nil))) (defun nnimap-get-response (sequence) @@ -803,22 +1007,25 @@ not done by default on servers that doesn't support that command.") (goto-char (point-min)) (while (and (memq (process-status process) '(open run)) - (not (re-search-forward "^\\* " nil t))) + (not (re-search-forward "^\\* .*\n" nil t))) (nnheader-accept-process-output process) (goto-char (point-min))) - (and (looking-at "[A-Z0-9]+") - (match-string 0)))) + (forward-line -1) + (and (looking-at "\\* \\([A-Z0-9]+\\)") + (match-string 1)))) (defun nnimap-wait-for-response (sequence &optional messagep) - (goto-char (point-max)) - (while (or (bobp) - (progn - (forward-line -1) - (not (looking-at (format "^%d .*\n" sequence))))) - (when messagep - (message "Read %dKB" (/ (buffer-size) 1000))) - (nnheader-accept-process-output (get-buffer-process (current-buffer))) - (goto-char (point-max)))) + (let ((process (get-buffer-process (current-buffer)))) + (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))) + (when messagep + (message "Read %dKB" (/ (buffer-size) 1000))) + (nnheader-accept-process-output process) + (goto-char (point-max))))) (defun nnimap-parse-response () (let ((lines (split-string (nnimap-last-response-string) "\r\n" t)) @@ -897,7 +1104,7 @@ not done by default on servers that doesn't support that command.") "BODY.PEEK[HEADER] BODY.PEEK" "RFC822.PEEK")) (if nnimap-split-download-body-default - "" + "[]" "[1]"))) t)) @@ -919,47 +1126,55 @@ not done by default on servers that doesn't support that command.") (nnmail-split-incoming (current-buffer) #'nnimap-save-mail-spec nil nil - #'nnimap-dummy-active-number) + #'nnimap-dummy-active-number + #'nnimap-save-mail-spec) (when nnimap-incoming-split-list (let ((specs (nnimap-make-split-specs nnimap-incoming-split-list)) - sequences) + sequences junk-articles) ;; Create any groups that doesn't already exist on the ;; server first. (dolist (spec specs) - (unless (member (car spec) groups) + (when (and (not (member (car spec) groups)) + (not (eq (car spec) 'junk))) (nnimap-command "CREATE %S" (utf7-encode (car spec) t)))) ;; Then copy over all the messages. (erase-buffer) (dolist (spec specs) (let ((group (car spec)) (ranges (cdr spec))) - (push (list (nnimap-send-command "UID COPY %s %S" - (nnimap-article-ranges ranges) - (utf7-encode group t)) - ranges) - sequences))) + (if (eq group 'junk) + (setq junk-articles ranges) + (push (list (nnimap-send-command + "UID COPY %s %S" + (nnimap-article-ranges ranges) + (utf7-encode group t)) + ranges) + sequences)))) ;; Wait for the last COPY response... (when sequences (nnimap-wait-for-response (caar sequences)) ;; And then mark the successful copy actions as deleted, ;; and possibly expunge them. (nnimap-mark-and-expunge-incoming - (nnimap-parse-copied-articles sequences))))))))) + (nnimap-parse-copied-articles sequences))) + (nnimap-mark-and-expunge-incoming junk-articles))))))) (defun nnimap-mark-and-expunge-incoming (range) (when range (setq range (nnimap-article-ranges range)) - (nnimap-send-command - "UID STORE %s +FLAGS.SILENT (\\Deleted)" range) - (cond - ;; If the server supports it, we now delete the message we have - ;; just copied over. - ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) - (nnimap-send-command "UID EXPUNGE %s" range)) - ;; If it doesn't support UID EXPUNGE, then we only expunge if the - ;; user has configured it. - (nnimap-expunge-inbox - (nnimap-send-command "EXPUNGE"))))) + (let ((sequence + (nnimap-send-command + "UID STORE %s +FLAGS.SILENT (\\Deleted)" range))) + (cond + ;; If the server supports it, we now delete the message we have + ;; just copied over. + ((member "UIDPLUS" (nnimap-capabilities nnimap-object)) + (setq sequence (nnimap-send-command "UID EXPUNGE %s" range))) + ;; If it doesn't support UID EXPUNGE, then we only expunge if the + ;; user has configured it. + (nnimap-expunge + (setq sequence (nnimap-send-command "EXPUNGE")))) + (nnimap-wait-for-response sequence)))) (defun nnimap-parse-copied-articles (sequences) (let (sequence copied range) @@ -974,8 +1189,8 @@ not done by default on servers that doesn't support that command.") (let (new) (dolist (elem flags) (when (or (null (cdr elem)) - (and (not (member "\\Deleted" (cdr elem))) - (not (member "\\Seen" (cdr elem))))) + (and (not (memq '%Deleted (cdr elem))) + (not (memq '%Seen (cdr elem))))) (push (car elem) new))) (gnus-compress-sequence (nreverse new)))) @@ -1022,7 +1237,10 @@ not done by default on servers that doesn't support that command.") (if (not (re-search-forward "X-nnimap-article: \\([0-9]+\\)" nil t)) (error "Invalid nnimap mail") (setq article (string-to-number (match-string 1)))) - (push (list article group-art) + (push (list article + (if (eq group-art 'junk) + (list (cons 'junk 1)) + group-art)) nnimap-incoming-split-list))) (provide 'nnimap)