Index: lisp/imap.el =================================================================== RCS file: /usr/local/cvsroot/gnus/lisp/imap.el,v retrieving revision 6.67 diff -u -w -r6.67 imap.el --- lisp/imap.el 17 Nov 2003 05:55:15 -0000 6.67 +++ lisp/imap.el 11 Dec 2003 15:35:47 -0000 @@ -1420,7 +1420,9 @@ (defun imap-list-to-message-set (list) (mapconcat (lambda (item) - (number-to-string item)) + (if (numberp item) + (number-to-string item) + item)) (if (listp list) list (list list)) @@ -1430,9 +1432,9 @@ (mapconcat (lambda (item) (if (consp item) - (format "%d:%d" + (format "%s:%s" (car item) (cdr item)) - (format "%d" item))) + (format "%s" item))) (if (and (listp range) (not (listp (cdr range)))) (list range) ;; make (1 . 2) into ((1 . 2)) range) @@ -1472,7 +1474,10 @@ (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) + (put (intern (typecase uid + (number (number-to-string uid)) + (t 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))) @@ -1480,7 +1485,10 @@ (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) + (get (intern-soft (typecase uid + (number (number-to-string uid)) + (t uid)) + imap-message-data) propname))) (defun imap-message-map (func propname &optional buffer) @@ -1586,7 +1594,7 @@ (and (imap-fetch "*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map - (lambda (uid prop) uid) 'UID)))) + (lambda (uid prop) uid) 'UIDINT)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) @@ -1630,7 +1638,7 @@ (and (imap-fetch "*" "UID") (list (imap-mailbox-get-1 'uidvalidity mailbox) (apply 'max (imap-message-map - (lambda (uid prop) uid) 'UID)))) + (lambda (uid prop) uid) 'UIDINT)))) (if old-mailbox (imap-mailbox-select old-mailbox (eq state 'examine)) (imap-mailbox-unselect))))))) @@ -1850,6 +1858,14 @@ (string-to-number (match-string 0)) (goto-char (match-end 0))))) +;; Keep uids as strings because Emacs integers are < 32 bits. + +(defun imap-parse-uid () + (when (looking-at "0*\\([0-9]+\\)") + (prog1 + (match-string 1) + (goto-char (match-end 0))))) + ;; literal = "{" number "}" CRLF *CHAR8 ;; ; Number represents the number of CHAR8s @@ -2297,9 +2313,7 @@ (let ((token (read (current-buffer)))) (imap-forward) (cond ((eq token 'UID) - (setq uid (condition-case () - (read (current-buffer)) - (error)))) + (setq uid (imap-parse-uid))) ((eq token 'FLAGS) (setq flags (imap-parse-flag-list)) (if (not flags) @@ -2332,6 +2346,7 @@ (when uid (setq imap-current-message uid) (imap-message-put uid 'UID uid) + (imap-message-put uid 'UIDINT (string-to-number uid)) (and (or flags flags-empty) (imap-message-put uid 'FLAGS flags)) (and envelope (imap-message-put uid 'ENVELOPE envelope)) (and internaldate (imap-message-put uid 'INTERNALDATE internaldate)) Index: lisp/nnimap.el =================================================================== RCS file: /usr/local/cvsroot/gnus/lisp/nnimap.el,v retrieving revision 6.71 diff -u -w -r6.71 nnimap.el --- lisp/nnimap.el 4 Sep 2003 22:22:18 -0000 6.71 +++ lisp/nnimap.el 11 Dec 2003 15:35:51 -0000 @@ -438,6 +438,184 @@ (setq nnimap-current-server (or server nnimap-current-server) nnimap-server-buffer (nnimap-get-server-buffer nnimap-current-server))) + +(defun nnimap-uid-cmp (a b) + (let ((la (length a)) + (lb (length b))) + (if (/= la lb ) + (- la lb) + (let ((idx 0)) + (while (and (< idx la) + (char-equal (aref a idx) (aref b idx))) + (setq idx (1+ idx))) + (if (< idx la) + (- (aref a idx) (aref b idx)) + 0))))) + +;; The imap-uid-to-msg-map is an alist of (MSG-NUMBER . UID) that is +;; *sorted* by MSG-NUMBER. MSG-NUMBER is an integer and UID is a +;; string. + +(defun nnimap-update-uid-map (group server) + "Update the UID to Gnus idea of a message number for this group" + (let* ((gnusgroup (gnus-group-prefixed-name group + (gnus-server-to-method + (format "nnimap:%s" server)))) + (uidmap (cons + nil + (gnus-group-find-parameter gnusgroup 'imap-uid-to-msg-map t))) + (msghigh (gnus-group-find-parameter gnusgroup 'msg-high)) + (uids (progn + (imap-fetch "1:*" "UID") + (sort (imap-message-map #'(lambda (uid Uid) uid) 'UID) + #'(lambda (a b) (minusp (nnimap-uid-cmp a b)))))) + (tailptr uidmap)) + ;; First remove disappeared UIDs + (while (and (not (null uids)) + (consp (cdr tailptr))) + (let ((cmp (nnimap-uid-cmp (car uids) (cdadr tailptr)))) + (cond + ((zerop cmp) + ;; OK, already in the list... Skip that + (setq uids (cdr uids) + tailptr (cdr tailptr))) + ((plusp cmp) + ;; The current UID from the map jas been expunged, remove it + ;; from the map + (setcdr tailptr (cddr tailptr))) + (t (error "This should not happen !"))))) + ;; All remaining in the map have been deleted + (setcdr tailptr nil) + ;; Add new UIDS + (if (null msghigh) + (setq msghigh (if (null (car tailptr)) + 0 + (caar tailptr)))) + (while (consp uids) + (setcdr tailptr (cons (cons (setq msghigh (1+ msghigh)) + (car uids)) + nil)) + (setq tailptr (cdr tailptr) + uids (cdr uids))) + ;; XXX - Don't set this now if it was not already set to allow + ;; cohabitation of the two style of message numbering. + (if (gnus-group-find-parameter gnusgroup 'msg-high) + (gnus-group-set-parameter gnusgroup 'msg-high msghigh)) + (gnus-group-set-parameter gnusgroup 'imap-uid-to-msg-map (cdr uidmap)))) + +(defun nnimap-following-uid (gnusgroup uid) + "Returns the uid just following `uid' in `gnusgroup'." + (if (gnus-group-find-parameter gnusgroup 'msg-high) + (let ((uidmap (gnus-group-find-parameter gnusgroup + 'imap-uid-to-msg-map + t))) + (while (and uidmap (not (equal a (cdar uidmap)))) + (setq uidmap (cdr uidmap))) + (cdadr uidmap)) + (1+ uid))) + +(defun nnimap-uid-consecutive-p (gnusgroup a b) + "Test if UID B is for message just after uid A." + (equal b (nnimap-following-uid gnusgroup a))) + +(defun nnimap-compress-uid-list (gnusgroup uids) + (let* ((res (cons nil '())) + (tail res) + low high) + (while uids + (cond + ((and low (not (nnimap-uid-consecutive-p gnusgroup high (car uids)))) + (setcdr tail `(,(if (= low high) + low + (cons low high)))) + (setq tail (cdr tail) + low (car uids) + high low)) + (low + (setq high (car uids))) + (t + (setq low (car uids) + high low))) + (setq uids (cdr uids))) + (if low + (setcdr tail `(,(if (equal low high) + low + (cons low high))))) + (cdr res))) + +(defun nnimap-uid-simple-range-length (uidmap start end) + (if uidmap + (let ((count 0)) + (while uidmap + (if (not (minusp (nnimap-uid-cmp (cdr (pop uidmap)) start))) + ;; (>= (cdr (pop uidmap)) start) + (progn + (setq count (1+ count)) + (while uidmap + (if (not (plusp (nnimap-uid-cmp end (cdr (pop uidmap))))) + ;; (<= end (cdr (pop uidmap))) + (setq uidmap nil)) + (setq count (1+ count)))))) + count) + 0)) + + +(defun nnimap-uid-range-length (range group server) + (let ((gnusgroup (gnus-group-prefixed-name group + (gnus-server-to-method + (format "nnimap:%s" server))))) + (if (gnus-group-find-parameter gnusgroup 'msg-high) + (let ((uidmap (gnus-group-find-parameter + gnusgroup 'imap-uid-to-msg-map t)) + (res 0)) + (mapc + #'(lambda (i) + (setq res (+ res + (cond + ((consp i) + (nnimap-uid-simple-range-length uidmap (car i) (cdr i))) + (t i))))) + range) + res) + (gnus-range-length range)))) + +(defun nnimap-msgnum-to-uid (gnusgroup num) + (if (gnus-group-find-parameter gnusgroup 'msg-high) + (cdr (assq num (gnus-group-find-parameter + gnusgroup 'imap-uid-to-msg-map t))) + num)) + +(defun nnimap-msgnum-to-uid-0 (num group server) + (nnimap-msgnum-to-uid + (gnus-group-prefixed-name group + (gnus-server-to-method + (format "nnimap:%s" server))) + num)) + +(defun nnimap-articles-to-uids (group server articles) + (let* ((gnusgroup (gnus-group-prefixed-name group + (gnus-server-to-method + (format "nnimap:%s" server)))) + (res (cons nil '())) + (tail res) + msg) + (while (not (null articles)) + (setq msg (nnimap-msgnum-to-uid gnusgroup (car articles)) + articles (cdr articles)) + (when msg + (setcdr tail (cons msg nil)) + (setq tail (cdr tail)))) + (cdr res))) + +(defun nnimap-uid-to-msgnum (group server uid) + (let ((gnusgroup (gnus-group-prefixed-name group + (gnus-server-to-method + (format "nnimap:%s" server))))) + (if (gnus-group-find-parameter gnusgroup 'msg-high) + (car (rassoc uid (gnus-group-find-parameter + gnusgroup 'imap-uid-to-msg-map t))) + (string-to-number uid)))) + (defun nnimap-verify-uidvalidity (group server) "Verify stored uidvalidity match current one in GROUP on SERVER." (let* ((gnusgroup (gnus-group-prefixed-name @@ -485,12 +663,24 @@ (when (or (string= group (imap-current-mailbox)) (imap-mailbox-select group examine)) (let (minuid maxuid) + (let ((gnusgroup + (gnus-group-prefixed-name group + (gnus-server-to-method + (format "nnimap:%s" + nnimap-current-server))))) + (if (setq maxuid (gnus-group-find-parameter gnusgroup 'msg-high)) + ;; New style message numbers + (let ((map + (gnus-group-find-parameter gnusgroup 'imap-uid-to-msg-map t))) + (if (null map) + (setq minuid maxuid) + (setq minuid (caar map)))) (when (> (imap-mailbox-get 'exists) 0) (imap-fetch "1,*" "UID" nil 'nouidfetch) - (imap-message-map (lambda (uid Uid) + (imap-message-map (lambda (struid uid) (setq minuid (if minuid (min minuid uid) uid) maxuid (if maxuid (max maxuid uid) uid))) - 'UID)) + 'UIDINT)))) (list (imap-mailbox-get 'exists) minuid maxuid))))) (defun nnimap-possibly-change-group (group &optional server) @@ -508,7 +698,9 @@ (yes-or-no-p (format "nnimap: Group %s is not uidvalid. Continue? " group))) - imap-current-mailbox + (progn + (nnimap-update-uid-map group server) + imap-current-mailbox) (imap-mailbox-unselect) (error "nnimap: Group %s is not uid-valid" group)) (nnheader-report 'nnimap (imap-error-text))))))) @@ -550,12 +742,13 @@ (with-temp-buffer (buffer-disable-undo) (insert headers) - (let ((head (nnheader-parse-naked-head))) - (mail-header-set-number head uid) + (let ((head (nnheader-parse-naked-head)) + (msgnum (nnimap-uid-to-msgnum mbx nnimap-current-server uid))) + (mail-header-set-number head msgnum) (mail-header-set-chars head chars) (mail-header-set-lines head lines) (mail-header-set-xref - head (format "%s %s:%d" (system-name) mbx uid)) + head (format "%s %s:%d" (system-name) mbx msgnum)) head)))))) (defun nnimap-retrieve-which-headers (articles fetch-old) @@ -643,7 +836,7 @@ (defun nnimap-retrieve-headers-from-server (articles group server) (with-current-buffer nnimap-server-buffer (let ((imap-fetch-data-hook '(nnimap-retrieve-headers-progress)) - (nnimap-length (gnus-range-length articles)) + (nnimap-length (nnimap-uid-range-length articles group server)) (nnimap-counter 0)) (imap-fetch (imap-range-to-message-set articles) (concat "(UID RFC822.SIZE BODY " @@ -670,12 +863,20 @@ (nnimap-group-overview-filename group server))))) (deffoo nnimap-retrieve-headers (articles &optional group server fetch-old) + (setq articles (nnimap-articles-to-uids group server articles)) (when (nnimap-possibly-change-group group server) (with-current-buffer nntp-server-buffer (erase-buffer) (if (nnimap-dont-use-nov-p group server) (nnimap-retrieve-headers-from-server - (gnus-compress-sequence articles) group server) + (nnimap-compress-uid-list (gnus-group-prefixed-name + group + (gnus-server-to-method + (format "nnimap:%s" server))) + articles) + group + server) + ;;; XXX Il faut aussi modifier ce else ! (let (uids cached low high) (when (setq uids (nnimap-retrieve-which-headers articles fetch-old) low (car uids) @@ -829,42 +1030,45 @@ (nnheader-ms-strip-cr) (funcall gnus-callback t)))) -(defun nnimap-request-article-part (article part prop &optional +;;; XXX - nnimap-request-article-part expect a article number, *not* an uid ! + +(defun nnimap-request-article-part (num part prop &optional group server to-buffer detail) (when (nnimap-possibly-change-group group server) - (let ((article (if (stringp article) + (let ((article (if (stringp num) (car-safe (imap-search - (format "HEADER Message-Id \"%s\"" article) + (format "HEADER Message-Id \"%s\"" num) nnimap-server-buffer)) - article))) + (nnimap-msgnum-to-uid-0 num group server)))) (when article - (gnus-message 10 "nnimap: Fetching (part of) article %d from %s..." - article (or group imap-current-mailbox + (gnus-message 10 "nnimap: Fetching (part of) article %s from %s..." + num (or group imap-current-mailbox gnus-newsgroup-name)) (if (not nnheader-callback-function) (with-current-buffer (or to-buffer nntp-server-buffer) (erase-buffer) - (let ((data (imap-fetch article part prop nil - nnimap-server-buffer))) + ;; XXX - Hack: pass article as a list to receive the result + (let ((data (car (imap-fetch `(,article) part prop nil + nnimap-server-buffer)))) (insert (nnimap-demule (if detail (nth 2 (car data)) data)))) (nnheader-ms-strip-cr) (gnus-message 10 "nnimap: Fetching (part of) article %d from %s...done" - article (or group imap-current-mailbox gnus-newsgroup-name)) + num (or group imap-current-mailbox gnus-newsgroup-name)) (if (bobp) (nnheader-report 'nnimap "No such article %d in %s: %s" - article (or group imap-current-mailbox + num (or group imap-current-mailbox gnus-newsgroup-name) (imap-error-text nnimap-server-buffer)) - (cons group article))) + (cons group num))) (add-hook 'imap-fetch-data-hook (nnimap-make-callback article nnheader-callback-function nntp-server-buffer)) (imap-fetch-asynch article part nil nnimap-server-buffer) - (cons group article)))))) + (cons group num)))))) (deffoo nnimap-asynchronous-p () t)