Commit | Line | Data |
---|---|---|
a3bdb4d9 MW |
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 | ||
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) |