| 1 | ;;; very unpleasant hacking; may it not last long |
| 2 | |
| 3 | (require 'imap) |
| 4 | (require 'nnimap) |
| 5 | (require 'cl) |
| 6 | |
| 7 | (defsubst imap-parse-number () |
| 8 | (when (looking-at "-?[0-9]+") |
| 9 | (prog1 |
| 10 | (string-to-number (match-string 0)) |
| 11 | (goto-char (match-end 0))))) |
| 12 | |
| 13 | (defun imap-parse-body () |
| 14 | (let (body) |
| 15 | (when (eq (char-after) ?\() |
| 16 | (imap-forward) |
| 17 | (if (eq (char-after) ?\() |
| 18 | (let (subbody) |
| 19 | (while (and (eq (char-after) ?\() |
| 20 | (setq subbody |
| 21 | (imap-parse-body))) |
| 22 | ;; buggy stalker communigate pro |
| 23 | ;; 3.0 insert a SPC between |
| 24 | ;; parts in multiparts |
| 25 | (when (and (eq (char-after) ?\ |
| 26 | ) |
| 27 | (eq (char-after (1+ |
| 28 | (point))) ?\()) |
| 29 | (imap-forward)) |
| 30 | (push subbody body)) |
| 31 | (imap-forward) |
| 32 | (push (imap-parse-string) body) |
| 33 | ;; media-subtype |
| 34 | (when (eq (char-after) ?\ ) ;; body-ext-mpart: |
| 35 | (imap-forward) |
| 36 | (if (eq |
| 37 | (char-after) |
| 38 | ?\() ;; body-fld-param |
| 39 | (push |
| 40 | (imap-parse-string-list) body) |
| 41 | (push (and |
| 42 | (imap-parse-nil) nil) body)) |
| 43 | (setq body |
| 44 | (append |
| 45 | (imap-parse-body-ext) body))) ;; body-ext-... |
| 46 | (assert (eq (char-after) |
| 47 | ?\)) nil "In imap-parse-body") |
| 48 | (imap-forward) |
| 49 | (nreverse body)) |
| 50 | |
| 51 | (push (imap-parse-string) body) ;; media-type |
| 52 | (imap-forward) |
| 53 | (push (imap-parse-string) body) ;; media-subtype |
| 54 | (imap-forward) |
| 55 | ;; next line for Sun SIMS bug |
| 56 | (and (eq (char-after) ? ) (imap-forward)) |
| 57 | (if (eq (char-after) ?\() ;; body-fld-param |
| 58 | (push (imap-parse-string-list) body) |
| 59 | (push (and (imap-parse-nil) nil) body)) |
| 60 | (imap-forward) |
| 61 | (push (imap-parse-nstring) body) ;; body-fld-id |
| 62 | (imap-forward) |
| 63 | (push (imap-parse-nstring) body) ;; body-fld-desc |
| 64 | (imap-forward) |
| 65 | ;; next `or' for Sun SIMS bug, it regard |
| 66 | ;; body-fld-enc as a |
| 67 | ;; nstring and return nil instead of defaulting |
| 68 | ;; back to 7BIT |
| 69 | ;; as the standard says. |
| 70 | (push (or (imap-parse-nstring) "7BIT") body) ;; body-fld-enc |
| 71 | (imap-forward) |
| 72 | (push (imap-parse-number) body) ;; body-fld-octets |
| 73 | |
| 74 | ;; ok, we're done parsing the required parts, |
| 75 | ;; what comes now is one |
| 76 | ;; of three things: |
| 77 | ;; |
| 78 | ;; envelope (then we're parsing |
| 79 | ;; body-type-msg) |
| 80 | ;; body-fld-lines (then we're parsing |
| 81 | ;; body-type-text) |
| 82 | ;; body-ext-1part (then we're parsing |
| 83 | ;; body-type-basic) |
| 84 | ;; |
| 85 | ;; the problem is that the two first are in |
| 86 | ;; turn optionally followed |
| 87 | ;; by the third. So we parse the first two here |
| 88 | ;; (if there are any)... |
| 89 | |
| 90 | (when (eq (char-after) ?\ ) |
| 91 | (imap-forward) |
| 92 | (let (lines) |
| 93 | (cond ((eq (char-after) ?\() ;; body-type-msg: |
| 94 | (push (imap-parse-envelope) |
| 95 | body) ;; envelope |
| 96 | (imap-forward) |
| 97 | (push |
| 98 | (imap-parse-body) body) ;; body |
| 99 | ;; buggy stalker |
| 100 | ;; communigate pro |
| 101 | ;; 3.0 doesn't |
| 102 | ;; print |
| 103 | ;; number of lines |
| 104 | ;; in |
| 105 | ;; message/rfc822 |
| 106 | ;; attachment |
| 107 | (if (eq |
| 108 | (char-after) ?\)) |
| 109 | (push 0 |
| 110 | body) |
| 111 | (imap-forward) |
| 112 | (push |
| 113 | (imap-parse-number) body))) ;; body-fld-lines |
| 114 | ((setq lines |
| 115 | (imap-parse-number)) ;; body-type-text: |
| 116 | (push lines body)) ;; body-fld-lines |
| 117 | (t |
| 118 | (backward-char))))) ;; no match... |
| 119 | |
| 120 | ;; ...and then parse the third one here... |
| 121 | |
| 122 | (when (eq (char-after) ?\ ) ;; body-ext-1part: |
| 123 | (imap-forward) |
| 124 | (push (imap-parse-nstring) body) ;; body-fld-md5 |
| 125 | (setq body (append (imap-parse-body-ext) |
| 126 | body))) ;; body-ext-1part.. |
| 127 | |
| 128 | (assert (eq (char-after) ?\)) nil "In |
| 129 | imap-parse-body 2") |
| 130 | (imap-forward) |
| 131 | (nreverse body))))) |
| 132 | |
| 133 | (defvar imap-enable-exchange-bug-workaround nil |
| 134 | "Send FETCH UID commands as *:* instead of *. |
| 135 | Enabling this appears to be required for some servers (e.g., |
| 136 | Microsoft Exchange) which otherwise would trigger a response 'BAD |
| 137 | The specified message set is invalid.'. |
| 138 | |
| 139 | BACKPORT from No Gnus!") |
| 140 | |
| 141 | (defun nnimap-find-minmax-uid (group &optional examine) |
| 142 | "Find lowest and highest active article number in GROUP. |
| 143 | If EXAMINE is non-nil the group is selected read-only." |
| 144 | (with-current-buffer nnimap-server-buffer |
| 145 | (when (or (string= group (imap-current-mailbox)) |
| 146 | (imap-mailbox-select group examine)) |
| 147 | (let (minuid maxuid) |
| 148 | (when (> (imap-mailbox-get 'exists) 0) |
| 149 | (imap-fetch (if imap-enable-exchange-bug-workaround "1,*:*" "1,*") |
| 150 | "UID" nil 'nouidfetch) |
| 151 | (imap-message-map (lambda (uid Uid) |
| 152 | (setq minuid (if minuid (min minuid uid) uid) |
| 153 | maxuid (if maxuid (max maxuid uid) uid))) |
| 154 | 'UID)) |
| 155 | (list (imap-mailbox-get 'exists) minuid maxuid))))) |
| 156 | |
| 157 | (defun imap-message-copyuid-1 (mailbox) |
| 158 | (if (imap-capability 'UIDPLUS) |
| 159 | (list (nth 0 (imap-mailbox-get-1 'copyuid mailbox)) |
| 160 | (string-to-number (nth 2 (imap-mailbox-get-1 'copyuid mailbox)))) |
| 161 | (let ((old-mailbox imap-current-mailbox) |
| 162 | (state imap-state) |
| 163 | (imap-message-data (make-vector 2 0))) |
| 164 | (when (imap-mailbox-examine-1 mailbox) |
| 165 | (prog1 |
| 166 | (and (imap-fetch |
| 167 | (if imap-enable-exchange-bug-workaround "*:*" "*") "UID") |
| 168 | (list (imap-mailbox-get-1 'uidvalidity mailbox) |
| 169 | (apply 'max (imap-message-map |
| 170 | (lambda (uid prop) uid) 'UID)))) |
| 171 | (if old-mailbox |
| 172 | (imap-mailbox-select old-mailbox (eq state 'examine)) |
| 173 | (imap-mailbox-unselect))))))) |
| 174 | |
| 175 | (defun imap-message-appenduid-1 (mailbox) |
| 176 | (if (imap-capability 'UIDPLUS) |
| 177 | (imap-mailbox-get-1 'appenduid mailbox) |
| 178 | (let ((old-mailbox imap-current-mailbox) |
| 179 | (state imap-state) |
| 180 | (imap-message-data (make-vector 2 0))) |
| 181 | (when (imap-mailbox-examine-1 mailbox) |
| 182 | (prog1 |
| 183 | (and (imap-fetch |
| 184 | (if imap-enable-exchange-bug-workaround "*:*" "*") "UID") |
| 185 | (list (imap-mailbox-get-1 'uidvalidity mailbox) |
| 186 | (apply 'max (imap-message-map |
| 187 | (lambda (uid prop) uid) 'UID)))) |
| 188 | (if old-mailbox |
| 189 | (imap-mailbox-select old-mailbox (eq state 'examine)) |
| 190 | (imap-mailbox-unselect))))))) |
| 191 | |
| 192 | ;;(setq imap-log t) |
| 193 | (provide 'mdw-gnus-patch) |