--- /dev/null
+;;; very unpleasant hacking; may it not last long
+
+(require 'imap)
+(require 'nnimap)
+(require 'cl)
+
+(defsubst imap-parse-number ()
+ (when (looking-at "-?[0-9]+")
+ (prog1
+ (string-to-number (match-string 0))
+ (goto-char (match-end 0)))))
+
+(defun imap-parse-body ()
+ (let (body)
+ (when (eq (char-after) ?\()
+ (imap-forward)
+ (if (eq (char-after) ?\()
+ (let (subbody)
+ (while (and (eq (char-after) ?\()
+ (setq subbody
+ (imap-parse-body)))
+ ;; buggy stalker communigate pro
+ ;; 3.0 insert a SPC between
+ ;; parts in multiparts
+ (when (and (eq (char-after) ?\
+ )
+ (eq (char-after (1+
+ (point))) ?\())
+ (imap-forward))
+ (push subbody body))
+ (imap-forward)
+ (push (imap-parse-string) body)
+ ;; media-subtype
+ (when (eq (char-after) ?\ ) ;; body-ext-mpart:
+ (imap-forward)
+ (if (eq
+ (char-after)
+ ?\() ;; body-fld-param
+ (push
+ (imap-parse-string-list) body)
+ (push (and
+ (imap-parse-nil) nil) body))
+ (setq body
+ (append
+ (imap-parse-body-ext) body))) ;; body-ext-...
+ (assert (eq (char-after)
+ ?\)) nil "In imap-parse-body")
+ (imap-forward)
+ (nreverse body))
+
+ (push (imap-parse-string) body) ;; media-type
+ (imap-forward)
+ (push (imap-parse-string) body) ;; media-subtype
+ (imap-forward)
+ ;; next line for Sun SIMS bug
+ (and (eq (char-after) ? ) (imap-forward))
+ (if (eq (char-after) ?\() ;; body-fld-param
+ (push (imap-parse-string-list) body)
+ (push (and (imap-parse-nil) nil) body))
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-id
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-desc
+ (imap-forward)
+ ;; next `or' for Sun SIMS bug, it regard
+ ;; body-fld-enc as a
+ ;; nstring and return nil instead of defaulting
+ ;; back to 7BIT
+ ;; as the standard says.
+ (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc
+ (imap-forward)
+ (push (imap-parse-number) body) ;; body-fld-octets
+
+ ;; ok, we're done parsing the required parts,
+ ;; what comes now is one
+ ;; of three things:
+ ;;
+ ;; envelope (then we're parsing
+ ;; body-type-msg)
+ ;; body-fld-lines (then we're parsing
+ ;; body-type-text)
+ ;; body-ext-1part (then we're parsing
+ ;; body-type-basic)
+ ;;
+ ;; the problem is that the two first are in
+ ;; turn optionally followed
+ ;; by the third. So we parse the first two here
+ ;; (if there are any)...
+
+ (when (eq (char-after) ?\ )
+ (imap-forward)
+ (let (lines)
+ (cond ((eq (char-after) ?\() ;; body-type-msg:
+ (push (imap-parse-envelope)
+ body) ;; envelope
+ (imap-forward)
+ (push
+ (imap-parse-body) body) ;; body
+ ;; buggy stalker
+ ;; communigate pro
+ ;; 3.0 doesn't
+ ;; print
+ ;; number of lines
+ ;; in
+ ;; message/rfc822
+ ;; attachment
+ (if (eq
+ (char-after) ?\))
+ (push 0
+ body)
+ (imap-forward)
+ (push
+ (imap-parse-number) body))) ;; body-fld-lines
+ ((setq lines
+ (imap-parse-number)) ;; body-type-text:
+ (push lines body)) ;; body-fld-lines
+ (t
+ (backward-char))))) ;; no match...
+
+ ;; ...and then parse the third one here...
+
+ (when (eq (char-after) ?\ ) ;; body-ext-1part:
+ (imap-forward)
+ (push (imap-parse-nstring) body) ;; body-fld-md5
+ (setq body (append (imap-parse-body-ext)
+ body))) ;; body-ext-1part..
+
+ (assert (eq (char-after) ?\)) nil "In
+ imap-parse-body 2")
+ (imap-forward)
+ (nreverse body)))))
+
+(defvar imap-enable-exchange-bug-workaround nil
+ "Send FETCH UID commands as *:* instead of *.
+Enabling this appears to be required for some servers (e.g.,
+Microsoft Exchange) which otherwise would trigger a response 'BAD
+The specified message set is invalid.'.
+
+BACKPORT from No Gnus!")
+
+(defun nnimap-find-minmax-uid (group &optional examine)
+ "Find lowest and highest active article number in GROUP.
+If EXAMINE is non-nil the group is selected read-only."
+ (with-current-buffer nnimap-server-buffer
+ (when (or (string= group (imap-current-mailbox))
+ (imap-mailbox-select group examine))
+ (let (minuid maxuid)
+ (when (> (imap-mailbox-get 'exists) 0)
+ (imap-fetch (if imap-enable-exchange-bug-workaround "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))
+ (list (imap-mailbox-get 'exists) minuid maxuid)))))
+
+(defun imap-message-copyuid-1 (mailbox)
+ (if (imap-capability 'UIDPLUS)
+ (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox))
+ (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox))))
+ (let ((old-mailbox imap-current-mailbox)
+ (state imap-state)
+ (imap-message-data (make-vector 2 0)))
+ (when (imap-mailbox-examine-1 mailbox)
+ (prog1
+ (and (imap-fetch
+ (if imap-enable-exchange-bug-workaround "*:*" "*") "UID")
+ (list (imap-mailbox-get-1 'uidvalidity mailbox)
+ (apply 'max (imap-message-map
+ (lambda (uid prop) uid) 'UID))))
+ (if old-mailbox
+ (imap-mailbox-select old-mailbox (eq state 'examine))
+ (imap-mailbox-unselect)))))))
+
+(defun imap-message-appenduid-1 (mailbox)
+ (if (imap-capability 'UIDPLUS)
+ (imap-mailbox-get-1 'appenduid mailbox)
+ (let ((old-mailbox imap-current-mailbox)
+ (state imap-state)
+ (imap-message-data (make-vector 2 0)))
+ (when (imap-mailbox-examine-1 mailbox)
+ (prog1
+ (and (imap-fetch
+ (if imap-enable-exchange-bug-workaround "*:*" "*") "UID")
+ (list (imap-mailbox-get-1 'uidvalidity mailbox)
+ (apply 'max (imap-message-map
+ (lambda (uid prop) uid) 'UID))))
+ (if old-mailbox
+ (imap-mailbox-select old-mailbox (eq state 'examine))
+ (imap-mailbox-unselect)))))))
+
+;;(setq imap-log t)
+(provide 'mdw-gnus-patch)
~mdw / profile / blobdiff