X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fnnimap.el;h=e43cd2d8afbdcaadd124b3f99c8a880fb787e139;hb=74a489ff1213794152d6e13f7a11e16c89f62602;hp=630540c0ab6b6c5f8566e5930865c597f473658e;hpb=fd09fffaa1b98a0cd1149c705dd31887ac63740d;p=gnus diff --git a/lisp/nnimap.el b/lisp/nnimap.el index 630540c0a..e43cd2d8a 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) @@ -70,6 +71,15 @@ not done by default on servers that doesn't support that command.") "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 nil) + (defvoo nnimap-connection-alist nil) (defvoo nnimap-current-infos nil) @@ -130,7 +140,7 @@ Possible choices are nil (use default methods) or `anonymous'.") (defun nnimap-transform-headers () (goto-char (point-min)) - (let (article bytes lines) + (let (article bytes lines size) (block nil (while (not (eobp)) (while (not (looking-at "^\\* [0-9]+ FETCH.*UID \\([0-9]+\\)")) @@ -141,6 +151,12 @@ Possible choices are nil (use default methods) or `anonymous'.") 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))))) (while (and (consp structure) @@ -150,7 +166,8 @@ Possible choices are nil (use default methods) or `anonymous'.") (delete-region (line-beginning-position) (line-end-position)) (insert (format "211 %s Article retrieved." article)) (forward-line 1) - (insert (format "Chars: %d\n" bytes)) + (when size + (insert (format "Chars: %s\n" size))) (when lines (insert (format "Lines: %s\n" lines))) (re-search-forward "^\r$") @@ -261,7 +278,11 @@ Possible choices are nil (use default methods) or `anonymous'.") (if (eq nnimap-authenticator 'anonymous) (list "anonymous" (message-make-address)) - (nnimap-credentials nnimap-address ports)))) + (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) @@ -309,7 +330,8 @@ Possible choices are nil (use default methods) or `anonymous'.") (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 @@ -317,6 +339,14 @@ Possible choices are nil (use default methods) or `anonymous'.") (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)) @@ -338,12 +368,35 @@ Possible choices are nil (use default methods) or `anonymous'.") (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)))) @@ -355,7 +408,7 @@ Possible choices are nil (use default methods) or `anonymous'.") (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) @@ -371,15 +424,28 @@ Possible choices are nil (use default methods) or `anonymous'.") (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)) + (setq high (1- (string-to-number (match-string 1))) low 1))))) (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) @@ -401,22 +467,23 @@ Possible choices are nil (use default methods) or `anonymous'.") (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) @@ -424,14 +491,71 @@ Possible choices are nil (use default methods) or `anonymous'.") (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 force + 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) @@ -449,10 +573,14 @@ Possible choices are nil (use default methods) or `anonymous'.") (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)))) (deffoo nnimap-request-scan (&optional group server) (when (and (nnimap-possibly-change-group nil server) @@ -487,7 +615,8 @@ Possible choices are nil (use default methods) or `anonymous'.") (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) @@ -820,7 +949,9 @@ Possible choices are nil (use default methods) or `anonymous'.") (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) @@ -832,21 +963,25 @@ Possible choices are nil (use default methods) or `anonymous'.") (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 (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 (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)) @@ -925,7 +1060,7 @@ Possible choices are nil (use default methods) or `anonymous'.") "BODY.PEEK[HEADER] BODY.PEEK" "RFC822.PEEK")) (if nnimap-split-download-body-default - "" + "[]" "[1]"))) t)) @@ -977,17 +1112,19 @@ Possible choices are nil (use default methods) or `anonymous'.") (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-inbox + (setq sequence (nnimap-send-command "EXPUNGE")))) + (nnimap-wait-for-response sequence)))) (defun nnimap-parse-copied-articles (sequences) (let (sequence copied range)