New feature: toggle visibility of mime buttons.
[more-wl.git] / elmo / elmo-imap4.el
blobf9a111f464f70d70547231d295ec91ebae2d0bbc
1 ;;; elmo-imap4.el --- IMAP4 Interface for ELMO.
3 ;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
4 ;; Copyright (C) 1999,2000 Kenichi OKADA <okada@opaopa.org>
5 ;; Copyright (C) 2000 OKAZAKI Tetsurou <okazaki@be.to>
6 ;; Copyright (C) 2000 Daiki Ueno <ueno@unixuser.org>
8 ;; Author: Yuuichi Teranishi <teranisi@gohome.org>
9 ;; Kenichi OKADA <okada@opaopa.org>
10 ;; OKAZAKI Tetsurou <okazaki@be.to>
11 ;; Daiki Ueno <ueno@unixuser.org>
12 ;; Keywords: mail, net news
14 ;; This file is part of ELMO (Elisp Library for Message Orchestration).
16 ;; This program is free software; you can redistribute it and/or modify
17 ;; it under the terms of the GNU General Public License as published by
18 ;; the Free Software Foundation; either version 2, or (at your option)
19 ;; any later version.
21 ;; This program is distributed in the hope that it will be useful,
22 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
23 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
24 ;; GNU General Public License for more details.
26 ;; You should have received a copy of the GNU General Public License
27 ;; along with GNU Emacs; see the file COPYING. If not, write to the
28 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
29 ;; Boston, MA 02111-1307, USA.
32 ;;; Commentary:
34 ;; Origin of IMAP parser part is imap.el, included in Gnus.
36 ;; Copyright (C) 1998, 1999, 2000
37 ;; Free Software Foundation, Inc.
38 ;; Author: Simon Josefsson <jas@pdc.kth.se>
41 ;;; Code:
42 (require 'elmo-vars)
43 (require 'elmo-util)
44 (require 'elmo-date)
45 (require 'elmo-msgdb)
46 (require 'elmo-cache)
47 (require 'elmo)
48 (require 'elmo-net)
49 (require 'utf7)
50 (require 'elmo-mime)
51 (require 'time-stamp)
53 (eval-when-compile (require 'cl))
55 (defvar elmo-imap4-disuse-server-flag-mailbox-regexp "^#mh" ; UW imapd
56 "Regexp to match IMAP4 mailbox names whose message flags on server should be ignored (For STATUS command).")
58 (defvar elmo-imap4-overview-fetch-chop-length 200
59 "*Number of overviews to fetch in one request.")
61 ;; c.f. rfc2683 3.2.1.5 Long Command Lines
63 ;; "A client should limit the length of the command lines it generates
64 ;; to approximately 1000 octets (including all quoted strings but not
65 ;; including literals). If the client is unable to group things into
66 ;; ranges so that the command line is within that length, it should
67 ;; split the request into multiple commands. The client should use
68 ;; literals instead of long quoted strings, in order to keep the command
69 ;; length down.
70 ;; For its part, a server should allow for a command line of at least
71 ;; 8000 octets. This provides plenty of leeway for accepting reasonable
72 ;; length commands from clients. The server should send a BAD response
73 ;; to a command that does not end within the server's maximum accepted
74 ;; command length. "
76 ;; To limit command line length, chop number set.
77 (defvar elmo-imap4-number-set-chop-length 1000
78 "*Number of messages to specify as a number-set argument for one request.")
80 (defvar elmo-imap4-force-login nil
81 "*Non-nil forces to try 'login' if there is no 'auth' capability in imapd.")
83 (defvar elmo-imap4-use-select-to-update-status nil
84 "*Some imapd have to send select command to update status.
85 \(ex. UW imapd 4.5-BETA?\). For these imapd, you must set this variable t.")
87 (defvar elmo-imap4-use-modified-utf7 nil
88 "*Use mofidied UTF-7 (rfc2060) encoding for IMAP4 folder name.")
90 (defvar elmo-imap4-use-cache t
91 "Use cache in imap4 folder.")
93 (defvar elmo-imap4-extra-namespace-alist
94 '(("^\\({.*/nntp}\\).*$" . ".")) ; Default is for UW's remote nntp mailbox...
95 "Extra namespace alist.
96 A list of cons cell like: (REGEXP . DELIMITER).
97 REGEXP should have a grouping for namespace prefix.")
99 ;;; internal variables
101 (defvar elmo-imap4-seq-prefix "elmo-imap4")
102 (defvar elmo-imap4-seqno 0)
103 (defvar elmo-imap4-use-uid t
104 "Use UID as message number.")
106 (defvar elmo-imap4-current-response nil)
107 (defvar elmo-imap4-status nil)
108 (defvar elmo-imap4-reached-tag "elmo-imap40")
110 ;;; buffer local variables
111 (defvar elmo-imap4-default-hierarchy-delimiter "/")
113 (defvar elmo-imap4-server-capability nil)
114 (defvar elmo-imap4-server-namespace nil)
116 (defvar elmo-imap4-parsing nil) ; indicates parsing.
118 (defvar elmo-imap4-fetch-callback nil)
119 (defvar elmo-imap4-fetch-callback-data nil)
120 (defvar elmo-imap4-status-callback nil)
121 (defvar elmo-imap4-status-callback-data nil)
123 (defvar elmo-imap4-server-diff-async-callback nil)
124 (defvar elmo-imap4-server-diff-async-callback-data nil)
126 ;;; progress...(no use?)
127 (defvar elmo-imap4-count-progress nil)
128 (defvar elmo-imap4-count-progress-message nil)
129 (defvar elmo-imap4-progress-count nil)
131 ;;; XXX Temporal implementation
132 (defvar elmo-imap4-current-msgdb nil)
133 (defvar elmo-imap4-seen-messages nil)
135 (defvar elmo-imap4-local-variables
136 '(elmo-imap4-status
137 elmo-imap4-current-response
138 elmo-imap4-seqno
139 elmo-imap4-parsing
140 elmo-imap4-reached-tag
141 elmo-imap4-count-progress
142 elmo-imap4-count-progress-message
143 elmo-imap4-progress-count
144 elmo-imap4-fetch-callback
145 elmo-imap4-fetch-callback-data
146 elmo-imap4-status-callback
147 elmo-imap4-status-callback-data
148 elmo-imap4-current-msgdb
149 elmo-imap4-seen-messages))
151 ;;;;
153 (defconst elmo-imap4-quoted-specials-list '(?\\ ?\"))
155 (defconst elmo-imap4-non-atom-char-regex
156 (eval-when-compile
157 (concat "[^" "]!#$&'+,./0-9:;<=>?@A-Z[^_`a-z|}~-" "]")))
159 (defconst elmo-imap4-non-text-char-regex
160 (eval-when-compile
161 (concat "[^"
162 "]\x01-\x09\x0b\x0c\x0e-\x1f\x7f !\"#$%&'()*+,./0-9:;<=>?@A-Z[\\^_`a-z{|}~-"
163 "]")))
165 (defconst elmo-imap4-literal-threshold 1024
166 "Limitation of characters that can be used in a quoted string.")
168 (defconst elmo-imap4-flag-specs '((important "\\Flagged")
169 (read "\\Seen")
170 (unread "\\Seen" 'remove)
171 (answered "\\Answered")
172 ;; draft-melnikov-imap-keywords-03.txt
173 (forwarded "$Forwarded")
174 (work "$Work")
175 (personal "$Personal")
176 (shouldreply "$ShouldReply")))
178 (defconst elmo-imap4-folder-name-syntax
179 `(mailbox
180 (?: [user "^[A-Za-z]"] (?/ [auth ".+"]))
181 ,@elmo-net-folder-name-syntax))
183 ;; For debugging.
184 (defvar elmo-imap4-debug nil
185 "Non-nil forces IMAP4 folder as debug mode.
186 Debug information is inserted in the buffer \"*IMAP4 DEBUG*\"")
188 (defvar elmo-imap4-debug-inhibit-logging nil)
190 ;;; ELMO IMAP4 folder
191 (eval-and-compile
192 (luna-define-class elmo-imap4-folder (elmo-net-folder)
193 (mailbox))
194 (luna-define-internal-accessors 'elmo-imap4-folder))
196 ;;; Session
197 (eval-and-compile
198 (luna-define-class elmo-imap4-session (elmo-network-session)
199 (capability current-mailbox read-only flags))
200 (luna-define-internal-accessors 'elmo-imap4-session))
202 (defmacro elmo-imap4-session-capable-p (session capability)
203 `(memq ,capability (elmo-imap4-session-capability-internal ,session)))
205 ;;; MIME-ELMO-IMAP Location
206 (eval-and-compile
207 (luna-define-class mime-elmo-imap-location
208 (mime-imap-location)
209 (folder number rawbuf strategy))
210 (luna-define-internal-accessors 'mime-elmo-imap-location))
212 ;;; Debug
213 (defmacro elmo-imap4-debug (message &rest args)
214 `(if elmo-imap4-debug
215 (elmo-imap4-debug-1 ,message ,@args)))
217 (defun elmo-imap4-debug-1 (message &rest args)
218 (with-current-buffer (get-buffer-create "*IMAP4 DEBUG*")
219 (goto-char (point-max))
220 (if elmo-imap4-debug-inhibit-logging
221 (insert "NO LOGGING\n")
222 (insert (apply 'format message args) "\n"))))
224 (defsubst elmo-imap4-decode-folder-string (string)
225 (if elmo-imap4-use-modified-utf7
226 (utf7-decode string 'imap)
227 string))
229 (defsubst elmo-imap4-encode-folder-string (string)
230 (if elmo-imap4-use-modified-utf7
231 (utf7-encode string 'imap)
232 string))
234 ;;; Response
236 (defmacro elmo-imap4-response-continue-req-p (response)
237 "Returns non-nil if RESPONSE is '+' response."
238 `(assq 'continue-req ,response))
240 (defmacro elmo-imap4-response-ok-p (response)
241 "Returns non-nil if RESPONSE is an 'OK' response."
242 `(assq 'ok ,response))
244 (defmacro elmo-imap4-response-bye-p (response)
245 "Returns non-nil if RESPONSE is an 'BYE' response."
246 `(assq 'bye ,response))
248 (defmacro elmo-imap4-response-garbage-p (response)
249 "Returns non-nil if RESPONSE is an 'garbage' response."
250 `(assq 'garbage ,response))
252 (defmacro elmo-imap4-response-value (response symbol)
253 "Get value of the SYMBOL from RESPONSE."
254 `(nth 1 (assq ,symbol ,response)))
256 (defsubst elmo-imap4-response-value-all (response symbol)
257 "Get all value of the SYMBOL from RESPONSE."
258 (let (matched)
259 (while response
260 (if (eq (car (car response)) symbol)
261 (setq matched (nconc matched (nth 1 (car response)))))
262 (setq response (cdr response)))
263 matched))
265 (defmacro elmo-imap4-response-error-text (response)
266 "Returns text of NO, BAD, BYE response."
267 `(nth 1 (or (elmo-imap4-response-value ,response 'no)
268 (elmo-imap4-response-value ,response 'bad)
269 (elmo-imap4-response-value ,response 'bye))))
271 (defmacro elmo-imap4-response-bodydetail-text (response)
272 "Returns text of BODY[section]<partial>."
273 `(nth 3 (assq 'bodydetail ,response)))
275 ;;; Session commands.
277 ; (defun elmo-imap4-send-command-wait (session command)
278 ; "Send COMMAND to the SESSION and wait for response.
279 ; Returns RESPONSE (parsed lisp object) of IMAP session."
280 ; (elmo-imap4-read-response session
281 ; (elmo-imap4-send-command
282 ; session
283 ; command)))
285 (defun elmo-imap4-send-command-wait (session command)
286 "Send COMMAND to the SESSION.
287 Returns RESPONSE (parsed lisp object) of IMAP session.
288 If response is not `OK', causes error with IMAP response text."
289 (elmo-imap4-accept-ok session
290 (elmo-imap4-send-command
291 session
292 command)))
294 (defun elmo-imap4-send-command (session command)
295 "Send COMMAND to the SESSION.
296 Returns a TAG string which is assigned to the COMMAND."
297 (let* ((command-args (if (listp command)
298 command
299 (list command)))
300 (process (elmo-network-session-process-internal session))
301 cmdstr tag token kind)
302 (with-current-buffer (process-buffer process)
303 (setq tag (concat elmo-imap4-seq-prefix
304 (number-to-string
305 (setq elmo-imap4-seqno (+ 1 elmo-imap4-seqno)))))
306 (setq cmdstr (concat tag " "))
307 ;; (erase-buffer) No need.
308 (goto-char (point-min))
309 (when (elmo-imap4-response-bye-p elmo-imap4-current-response)
310 (elmo-imap4-process-bye session))
311 (setq elmo-imap4-current-response nil)
312 (when elmo-imap4-parsing
313 (message "Waiting for IMAP response...")
314 (accept-process-output (elmo-network-session-process-internal
315 session))
316 (message "Waiting for IMAP response...done"))
317 (setq elmo-imap4-parsing t)
318 (while (setq token (car command-args))
319 (cond ((stringp token) ; formatted
320 (setq cmdstr (concat cmdstr token)))
321 ((listp token) ; unformatted
322 (setq kind (car token))
323 (cond ((eq kind 'atom)
324 (setq cmdstr (concat cmdstr (nth 1 token))))
325 ((eq kind 'quoted)
326 (setq cmdstr (concat
327 cmdstr
328 (elmo-imap4-format-quoted (nth 1 token)))))
329 ((eq kind 'literal)
330 (if (elmo-imap4-session-capable-p session 'literal+)
331 ;; rfc2088
332 (progn
333 (setq cmdstr (concat cmdstr
334 (format "{%d+}" (nth 2 token))
335 "\r\n"))
336 (process-send-string process cmdstr)
337 (setq cmdstr nil))
338 (setq cmdstr (concat cmdstr
339 (format "{%d}" (nth 2 token))
340 "\r\n"))
341 (process-send-string process cmdstr)
342 (setq cmdstr nil)
343 (elmo-imap4-accept-continue-req session))
344 (cond ((stringp (nth 1 token))
345 (setq cmdstr (nth 1 token)))
346 ((bufferp (nth 1 token))
347 (with-current-buffer (nth 1 token)
348 (process-send-region
349 process
350 (point-min)
351 (+ (point-min) (nth 2 token)))))
353 (error "Wrong argument for literal"))))
355 (error "Unknown token kind %s" kind))))
357 (error "Invalid argument")))
358 (setq command-args (cdr command-args)))
359 (elmo-imap4-debug "[%s] <- %s" (time-stamp-hh:mm:ss) cmdstr)
360 (process-send-string process (concat cmdstr "\r\n"))
361 tag)))
363 (defun elmo-imap4-send-string (session string)
364 "Send STRING to the SESSION."
365 (with-current-buffer (process-buffer
366 (elmo-network-session-process-internal session))
367 (setq elmo-imap4-current-response nil)
368 (goto-char (point-min))
369 (elmo-imap4-debug "[%s] <-- %s" (time-stamp-hh:mm:ss) string)
370 (process-send-string (elmo-network-session-process-internal session)
371 string)
372 (process-send-string (elmo-network-session-process-internal session)
373 "\r\n")))
375 (defun elmo-imap4-read-response (session tag)
376 "Read parsed response from SESSION.
377 TAG is the tag of the command"
378 (with-current-buffer (process-buffer
379 (elmo-network-session-process-internal session))
380 (while (not (or (string= tag elmo-imap4-reached-tag)
381 (elmo-imap4-response-bye-p elmo-imap4-current-response)
382 (when (elmo-imap4-response-garbage-p
383 elmo-imap4-current-response)
384 (message "Garbage response: %s"
385 (elmo-imap4-response-value
386 elmo-imap4-current-response
387 'garbage))
388 t)))
389 (when (memq (process-status
390 (elmo-network-session-process-internal session))
391 '(open run))
392 (accept-process-output (elmo-network-session-process-internal session)
393 1)))
394 (elmo-imap4-debug "[%s] =>%s" (time-stamp-hh:mm:ss) (prin1-to-string elmo-imap4-current-response))
395 (setq elmo-imap4-parsing nil)
396 elmo-imap4-current-response))
398 (defsubst elmo-imap4-read-untagged (process)
399 (with-current-buffer (process-buffer process)
400 (while (not elmo-imap4-current-response)
401 (accept-process-output process 1))
402 (elmo-imap4-debug "[%s] =>%s" (time-stamp-hh:mm:ss) (prin1-to-string elmo-imap4-current-response))
403 elmo-imap4-current-response))
405 (defun elmo-imap4-read-continue-req (session)
406 "Returns a text following to continue-req in SESSION.
407 If response is not `+' response, returns nil."
408 (elmo-imap4-response-value
409 (elmo-imap4-read-untagged
410 (elmo-network-session-process-internal session))
411 'continue-req))
413 (defun elmo-imap4-process-bye (session)
414 (with-current-buffer (elmo-network-session-buffer session)
415 (let ((r elmo-imap4-current-response))
416 (setq elmo-imap4-current-response nil)
417 (elmo-network-close-session session)
418 (signal 'elmo-imap4-bye-error
419 (list (concat (elmo-imap4-response-error-text r))
420 "Try Again")))))
422 (defun elmo-imap4-accept-continue-req (session)
423 "Returns non-nil if `+' (continue-req) response is arrived in SESSION.
424 If response is not `+' response, cause an error."
425 (let (response)
426 (setq response
427 (elmo-imap4-read-untagged
428 (elmo-network-session-process-internal session)))
429 (or (elmo-imap4-response-continue-req-p response)
430 (error "IMAP error: %s"
431 (or (elmo-imap4-response-error-text response)
432 "No continut-req from server.")))))
434 (defun elmo-imap4-read-ok (session tag)
435 "Returns non-nil if `OK' response of the command with TAG is arrived
436 in SESSION. If response is not `OK' response, returns nil."
437 (elmo-imap4-response-ok-p
438 (elmo-imap4-read-response session tag)))
440 (defun elmo-imap4-accept-ok (session tag)
441 "Accept only `OK' response from SESSION.
442 If response is not `OK' response, causes error with IMAP response text."
443 (let ((response (elmo-imap4-read-response session tag)))
444 (if (elmo-imap4-response-ok-p response)
445 response
446 (if (elmo-imap4-response-bye-p response)
447 (elmo-imap4-process-bye session)
448 (error "IMAP error: %s"
449 (or (elmo-imap4-response-error-text response)
450 "No `OK' response from server."))))))
452 ;;; MIME-ELMO-IMAP Location
453 (luna-define-method mime-imap-location-section-body ((location
454 mime-elmo-imap-location)
455 section)
456 (if (and (stringp section)
457 (string= section "HEADER"))
458 ;; Even in the section mode, header fields should be saved to the
459 ;; raw buffer .
460 (with-current-buffer (mime-elmo-imap-location-rawbuf-internal location)
461 (erase-buffer)
462 (elmo-message-fetch
463 (mime-elmo-imap-location-folder-internal location)
464 (mime-elmo-imap-location-number-internal location)
465 (mime-elmo-imap-location-strategy-internal location)
466 'unseen
467 section)
468 (buffer-string))
469 (elmo-message-fetch-string
470 (mime-elmo-imap-location-folder-internal location)
471 (mime-elmo-imap-location-number-internal location)
472 (mime-elmo-imap-location-strategy-internal location)
473 'unseen
474 section)))
477 (luna-define-method mime-imap-location-bodystructure
478 ((location mime-elmo-imap-location))
479 (elmo-message-fetch-bodystructure
480 (mime-elmo-imap-location-folder-internal location)
481 (mime-elmo-imap-location-number-internal location)
482 (mime-elmo-imap-location-strategy-internal location)))
484 (luna-define-method mime-imap-location-fetch-entity-p
485 ((location mime-elmo-imap-location) entity)
486 (or (not elmo-message-displaying) ; Fetching entity to save or force display.
487 ;; cache exists
488 (file-exists-p
489 (expand-file-name
490 (mmimap-entity-section (mime-entity-node-id-internal entity))
491 (elmo-fetch-strategy-cache-path
492 (mime-elmo-imap-location-strategy-internal location))))
493 ;; not too large to fetch.
494 (> elmo-message-fetch-threshold
495 (or (mime-imap-entity-size-internal entity) 0))))
499 (defun elmo-imap4-session-check (session)
500 (with-current-buffer (elmo-network-session-buffer session)
501 (setq elmo-imap4-fetch-callback nil)
502 (setq elmo-imap4-fetch-callback-data nil))
503 (elmo-imap4-send-command session "check"))
505 (defun elmo-imap4-atom-p (string)
506 "Return t if STRING is an atom defined in rfc2060."
507 (if (string= string "")
509 (save-match-data
510 (not (string-match elmo-imap4-non-atom-char-regex string)))))
512 (defun elmo-imap4-quotable-p (string)
513 "Return t if STRING can be formatted as a quoted defined in rfc2060."
514 (save-match-data
515 (not (string-match elmo-imap4-non-text-char-regex string))))
517 (defun elmo-imap4-nil (string)
518 "Return a list represents the special atom \"NIL\" defined in rfc2060, \
519 if STRING is nil.
520 Otherwise return nil."
521 (if (eq string nil)
522 (list 'atom "NIL")))
524 (defun elmo-imap4-atom (string)
525 "Return a list represents STRING as an atom defined in rfc2060.
526 Return nil if STRING is not an atom. See `elmo-imap4-atom-p'."
527 (if (elmo-imap4-atom-p string)
528 (list 'atom string)))
530 (defun elmo-imap4-quoted (string)
531 "Return a list represents STRING as a quoted defined in rfc2060.
532 Return nil if STRING can not be formatted as a quoted. See `elmo-imap4-quotable-p'."
533 (if (elmo-imap4-quotable-p string)
534 (list 'quoted string)))
536 (defun elmo-imap4-literal-1 (string-or-buffer length)
537 "Internal function for `elmo-imap4-literal' and `elmo-imap4-buffer-literal'.
538 Return a list represents STRING-OR-BUFFER as a literal defined in rfc2060.
539 STRING-OR-BUFFER must be an encoded string or a single-byte string or a single-byte buffer.
540 LENGTH must be the number of octets for STRING-OR-BUFFER."
541 (list 'literal string-or-buffer length))
543 (defun elmo-imap4-literal (string)
544 "Return a list represents STRING as a literal defined in rfc2060.
545 STRING must be an encoded or a single-byte string."
546 (elmo-imap4-literal-1 string (length string)))
548 (defun elmo-imap4-buffer-literal (buffer)
549 "Return a list represents BUFFER as a literal defined in rfc2060.
550 BUFFER must be a single-byte buffer."
551 (elmo-imap4-literal-1 buffer (with-current-buffer buffer
552 (buffer-size))))
554 (defun elmo-imap4-string-1 (string length)
555 "Internal function for `elmo-imap4-string' and `elmo-imap4-buffer-string'.
556 Return a list represents STRING as a string defined in rfc2060.
557 STRING must be an encoded or a single-byte string.
558 LENGTH must be the number of octets for STRING."
559 (or (elmo-imap4-quoted string)
560 (elmo-imap4-literal-1 string length)))
562 (defun elmo-imap4-string (string)
563 "Return a list represents STRING as a string defined in rfc2060.
564 STRING must be an encoded or a single-byte string."
565 (let ((length (length string)))
566 (if (< elmo-imap4-literal-threshold length)
567 (elmo-imap4-literal-1 string length)
568 (elmo-imap4-string-1 string length))))
570 (defun elmo-imap4-buffer-string (buffer)
571 "Return a list represents BUFFER as a string defined in rfc2060.
572 BUFFER must be a single-byte buffer."
573 (let ((length (with-current-buffer buffer
574 (buffer-size))))
575 (if (< elmo-imap4-literal-threshold length)
576 (elmo-imap4-literal-1 buffer length)
577 (elmo-imap4-string-1 (with-current-buffer buffer
578 (buffer-string))
579 length))))
581 (defun elmo-imap4-astring-1 (string length)
582 "Internal function for `elmo-imap4-astring' and `elmo-imap4-buffer-astring'.
583 Return a list represents STRING as an astring defined in rfc2060.
584 STRING must be an encoded or a single-byte string.
585 LENGTH must be the number of octets for STRING."
586 (or (elmo-imap4-atom string)
587 (elmo-imap4-string-1 string length)))
589 (defun elmo-imap4-astring (string)
590 "Return a list represents STRING as an astring defined in rfc2060.
591 STRING must be an encoded or a single-byte string."
592 (let ((length (length string)))
593 (if (< elmo-imap4-literal-threshold length)
594 (elmo-imap4-literal-1 string length)
595 (elmo-imap4-astring-1 string length))))
597 (defun elmo-imap4-buffer-astring (buffer)
598 "Return a list represents BUFFER as an astring defined in rfc2060.
599 BUFFER must be a single-byte buffer."
600 (let ((length (with-current-buffer buffer
601 (buffer-size))))
602 (if (< elmo-imap4-literal-threshold length)
603 (elmo-imap4-literal-1 buffer length)
604 (elmo-imap4-astring-1 (with-current-buffer buffer
605 (buffer-string))
606 length))))
608 (defun elmo-imap4-nstring (string)
609 "Return a list represents STRING as a nstring defined in rfc2060.
610 STRING must be an encoded or a single-byte string."
611 (or (elmo-imap4-nil string)
612 (elmo-imap4-string string)))
614 (defun elmo-imap4-buffer-nstring (buffer)
615 "Return a list represents BUFFER as a nstring defined in rfc2060.
616 BUFFER must be a single-byte buffer."
617 (or (elmo-imap4-nil buffer)
618 (elmo-imap4-buffer-string buffer)))
620 (defalias 'elmo-imap4-mailbox 'elmo-imap4-astring)
621 (defalias 'elmo-imap4-field-body 'elmo-imap4-astring)
622 (defalias 'elmo-imap4-userid 'elmo-imap4-astring)
623 (defalias 'elmo-imap4-password 'elmo-imap4-astring)
625 (defun elmo-imap4-format-quoted (string)
626 "Return STRING in a form of the quoted-string defined in rfc2060."
627 (concat "\""
628 (std11-wrap-as-quoted-pairs string elmo-imap4-quoted-specials-list)
629 "\""))
631 (defsubst elmo-imap4-response-get-selectable-mailbox-list (response)
632 (delq nil
633 (mapcar
634 (lambda (entry)
635 (if (and (eq 'list (car entry))
636 (not (elmo-string-member-ignore-case "\\Noselect" (nth 1 (nth 1 entry)))))
637 (car (nth 1 entry))))
638 response)))
640 (luna-define-method elmo-message-fetch-bodystructure ((folder
641 elmo-imap4-folder)
642 number strategy)
643 (if (elmo-fetch-strategy-use-cache strategy)
644 (elmo-object-load
645 (elmo-file-cache-expand-path
646 (elmo-fetch-strategy-cache-path strategy)
647 "bodystructure"))
648 (let ((session (elmo-imap4-get-session folder))
649 bodystructure)
650 (elmo-imap4-session-select-mailbox
651 session
652 (elmo-imap4-folder-mailbox-internal folder))
653 (with-current-buffer (elmo-network-session-buffer session)
654 (setq elmo-imap4-fetch-callback nil)
655 (setq elmo-imap4-fetch-callback-data nil))
656 (prog1 (setq bodystructure
657 (elmo-imap4-response-value
658 (elmo-imap4-response-value
659 (elmo-imap4-send-command-wait
660 session
661 (format
662 (if elmo-imap4-use-uid
663 "uid fetch %s bodystructure"
664 "fetch %s bodystructure")
665 number))
666 'fetch)
667 'bodystructure))
668 (when (elmo-fetch-strategy-save-cache strategy)
669 (elmo-file-cache-delete
670 (elmo-fetch-strategy-cache-path strategy))
671 (elmo-object-save
672 (elmo-file-cache-expand-path
673 (elmo-fetch-strategy-cache-path strategy)
674 "bodystructure")
675 bodystructure))))))
677 ;;; Backend methods.
678 (luna-define-method elmo-create-folder-plugged ((folder elmo-imap4-folder))
679 (elmo-imap4-send-command-wait
680 (elmo-imap4-get-session folder)
681 (list "create " (elmo-imap4-mailbox
682 (elmo-imap4-folder-mailbox-internal folder)))))
684 (defun elmo-imap4-get-session (folder &optional if-exists)
685 (elmo-network-get-session 'elmo-imap4-session
686 (concat
687 (if (elmo-folder-biff-internal folder)
688 "BIFF-")
689 "IMAP")
690 folder if-exists))
692 (defun elmo-imap4-session-select-mailbox (session mailbox
693 &optional force no-error)
694 "Select MAILBOX in SESSION.
695 If optional argument FORCE is non-nil, select mailbox even if current mailbox
696 is same as MAILBOX.
697 If second optional argument NO-ERROR is non-nil, don't cause an error when
698 selecting folder was failed.
699 If NO-ERROR is 'notify-bye, only BYE response is reported as error.
700 Returns response value if selecting folder succeed. "
701 (when (or force
702 (not (string=
703 (elmo-imap4-session-current-mailbox-internal session)
704 mailbox)))
705 (let (response result)
706 (unwind-protect
707 (setq response
708 (elmo-imap4-read-response
709 session
710 (elmo-imap4-send-command
711 session
712 (list
713 "select "
714 (elmo-imap4-mailbox mailbox)))))
715 (if (setq result (elmo-imap4-response-ok-p response))
716 (progn
717 (elmo-imap4-session-set-current-mailbox-internal session mailbox)
718 (elmo-imap4-session-set-read-only-internal
719 session
720 (nth 1 (assq 'read-only (assq 'ok response))))
721 (elmo-imap4-session-set-flags-internal
722 session
723 (nth 1 (or (assq 'permanentflags response)
724 (assq 'flags response)))))
725 (elmo-imap4-session-set-current-mailbox-internal session nil)
726 (if (and (eq no-error 'notify-bye)
727 (elmo-imap4-response-bye-p response))
728 (elmo-imap4-process-bye session)
729 (unless no-error
730 (error "%s"
731 (or (elmo-imap4-response-error-text response)
732 (format "Select %s failed" mailbox)))))))
733 (and result response))))
735 (defun elmo-imap4-check-validity (spec validity-file)
736 ;;; Not used.
737 ;;;(elmo-imap4-send-command-wait
738 ;;;(elmo-imap4-get-session spec)
739 ;;;(list "status "
740 ;;; (elmo-imap4-mailbox
741 ;;; (elmo-imap4-spec-mailbox spec))
742 ;;; " (uidvalidity)")))
745 (defun elmo-imap4-sync-validity (spec validity-file)
746 ;; Not used.
749 (defun elmo-imap4-elist (folder query tags)
750 (let ((session (elmo-imap4-get-session folder)))
751 (elmo-imap4-session-select-mailbox
752 session
753 (elmo-imap4-folder-mailbox-internal folder))
754 (let ((answer (elmo-imap4-response-value
755 (elmo-imap4-send-command-wait
756 session query) 'esearch))
757 tag result)
758 (while answer
759 (setq tag (intern (downcase (car answer))))
760 (cond ((eq tag 'uid)
761 nil)
762 ((memq tag tags)
763 (setq result
764 (append result
765 (if (eq tag 'all)
766 (sort
767 (elmo-number-set-to-number-list
768 (mapcar #'(lambda (x)
769 (let ((y (split-string x ":")))
770 (if (null (cdr y))
771 (string-to-number (car y))
772 (cons (string-to-number (car y))
773 (string-to-number (cadr y))))))
774 (split-string (cadr answer) "\,"))) '<)
775 (string-to-number (cadr answer))))))
776 (t nil))
777 (setq answer (cdr answer)))
778 result)))
780 (defun elmo-imap4-list (folder flag)
781 (let ((session (elmo-imap4-get-session folder)))
782 (elmo-imap4-session-select-mailbox
783 session
784 (elmo-imap4-folder-mailbox-internal folder))
785 (if (elmo-imap4-session-capable-p session 'esearch)
786 (elmo-imap4-elist folder
787 (concat (if elmo-imap4-use-uid "uid " "")
788 "search return (all) " flag) '(all))
789 (elmo-imap4-response-value
790 (elmo-imap4-send-command-wait
791 session
792 (format (if elmo-imap4-use-uid "uid search %s"
793 "search %s") flag))
794 'search))))
796 (defun elmo-imap4-session-flag-available-p (session flag)
797 (case flag
798 ((read unread) (elmo-string-member-ignore-case
799 "\\seen" (elmo-imap4-session-flags-internal session)))
800 (important
801 (elmo-string-member-ignore-case
802 "\\flagged" (elmo-imap4-session-flags-internal session)))
803 (digest
804 (or (elmo-string-member-ignore-case
805 "\\seen" (elmo-imap4-session-flags-internal session))
806 (elmo-string-member-ignore-case
807 "\\flagged" (elmo-imap4-session-flags-internal session))))
808 (answered
809 (elmo-string-member-ignore-case
810 (concat "\\" (symbol-name flag))
811 (elmo-imap4-session-flags-internal session)))
813 (member "\\*" (elmo-imap4-session-flags-internal session)))))
815 (defun elmo-imap4-flag-to-imap-search-key (flag)
816 (case flag
817 (read "seen")
818 (unread "unseen")
819 (important "flagged")
820 (answered "answered")
821 (new "new")
822 (t (concat
823 "keyword "
824 (or (car (cdr (assq flag elmo-imap4-flag-specs)))
825 (symbol-name flag))))))
827 (defun elmo-imap4-flag-to-imap-criteria (flag)
828 (case flag
829 ((any digest)
830 (let ((criteria "flagged")
831 (global-flags (delq 'important (elmo-get-global-flags t t))))
832 (dolist (flag (delete 'new
833 (delete 'cached
834 (copy-sequence
835 (case flag
836 (any
837 elmo-preserved-flags)
838 (digest
839 elmo-digest-flags))))))
840 (setq criteria (concat "or "
841 (elmo-imap4-flag-to-imap-search-key flag)
843 criteria)))
844 (while global-flags
845 (setq criteria (concat "or keyword "
846 (symbol-name (car global-flags))
848 criteria))
849 (setq global-flags (cdr global-flags)))
850 criteria))
852 (elmo-imap4-flag-to-imap-search-key flag))))
854 (defun elmo-imap4-folder-list-flagged (folder flag)
855 "List flagged message numbers in the FOLDER.
856 FLAG is one of the `unread', `read', `important', `answered', `any'."
857 (let ((session (elmo-imap4-get-session folder))
858 (criteria (elmo-imap4-flag-to-imap-criteria flag)))
859 (if (elmo-imap4-session-flag-available-p session flag)
860 (elmo-imap4-list folder criteria)
861 ;; List flagged messages in the msgdb.
862 (elmo-msgdb-list-flagged (elmo-folder-msgdb folder) flag))))
864 (defvar elmo-imap4-rfc822-size "RFC822\.SIZE")
865 (defvar elmo-imap4-rfc822-text "RFC822\.TEXT")
866 (defvar elmo-imap4-rfc822-header "RFC822\.HEADER")
867 (defvar elmo-imap4-header-fields "HEADER\.FIELDS")
869 (defun elmo-imap4-make-number-set-list (msg-list &optional chop-length)
870 "Make RFC2060's message set specifier from MSG-LIST.
871 Returns a list of (NUMBER . SET-STRING).
872 SET-STRING is the message set specifier described in RFC2060.
873 NUMBER is contained message number in SET-STRING.
874 Every SET-STRING does not contain number of messages longer than CHOP-LENGTH.
875 If CHOP-LENGTH is not specified, message set is not chopped."
876 (let (count cont-list set-list)
877 (setq msg-list (sort (copy-sequence msg-list) '<))
878 (while msg-list
879 (setq cont-list nil)
880 (setq count 0)
881 (unless chop-length
882 (setq chop-length (length msg-list)))
883 (while (and (not (null msg-list))
884 (< count chop-length))
885 (setq cont-list
886 (elmo-number-set-append
887 cont-list (car msg-list)))
888 (incf count)
889 (setq msg-list (cdr msg-list)))
890 (setq set-list
891 (cons
892 (cons
893 count
894 (mapconcat
895 (lambda (x)
896 (cond ((consp x)
897 (format "%s:%s" (car x) (cdr x)))
898 ((integerp x)
899 (int-to-string x))))
900 cont-list
901 ","))
902 set-list)))
903 (nreverse set-list)))
906 ;; app-data:
907 ;; cons of flag-table and folder structure
908 (defsubst elmo-imap4-fetch-callback-1-subr (entity flags app-data)
909 "A msgdb entity callback function."
910 (let ((use-flag (elmo-folder-use-flag-p (cdr app-data)))
911 (flag-table (car app-data))
912 (msg-id (elmo-message-entity-field entity 'message-id))
913 saved-flags flag-list)
914 ;; (when (elmo-string-member-ignore-case "\\Flagged" flags)
915 ;; (elmo-msgdb-global-mark-set msg-id elmo-msgdb-important-mark))
916 (setq saved-flags (elmo-flag-table-get flag-table msg-id)
917 flag-list
918 (if use-flag
919 (append
920 (and (memq 'new saved-flags)
921 (not (elmo-string-member-ignore-case "\\Seen" flags))
922 '(new))
923 (and (elmo-string-member-ignore-case "\\Flagged" flags)
924 '(important))
925 (and (not (elmo-string-member-ignore-case "\\Seen" flags))
926 '(unread))
927 (and (elmo-string-member-ignore-case "\\Answered" flags)
928 '(answered))
929 (and (elmo-file-cache-exists-p msg-id)
930 '(cached)))
931 saved-flags))
932 (when (and (or (memq 'important flag-list)
933 (memq 'answered flag-list))
934 (memq 'unread flag-list))
935 (setq elmo-imap4-seen-messages
936 (cons (elmo-message-entity-number entity)
937 elmo-imap4-seen-messages)))
938 (elmo-msgdb-append-entity elmo-imap4-current-msgdb
939 entity
940 flag-list)))
942 ;; Current buffer is process buffer.
943 (defun elmo-imap4-fetch-callback-1 (element app-data)
944 (let ((handler (elmo-msgdb-message-entity-handler elmo-imap4-current-msgdb)))
945 (elmo-imap4-fetch-callback-1-subr
946 (with-temp-buffer
947 (insert (or (elmo-imap4-response-bodydetail-text element)
948 ""))
949 ;; Replace all CRLF with LF.
950 (elmo-delete-cr-buffer)
951 (elmo-msgdb-create-message-entity-from-buffer
952 handler
953 (elmo-imap4-response-value element 'uid)
954 :size (elmo-imap4-response-value element 'rfc822size)))
955 (elmo-imap4-response-value element 'flags)
956 app-data)
957 (elmo-progress-notify 'elmo-folder-msgdb-create)))
959 (defun elmo-imap4-parse-capability (string)
960 (if (string-match "^\\*\\(.*\\)$" string)
961 (read
962 (concat "(" (downcase (elmo-match-string 1 string)) ")"))))
964 (defun elmo-imap4-clear-login (session)
965 (when (elmo-imap4-session-capable-p session 'logindisabled)
966 (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))
967 (let ((elmo-imap4-debug-inhibit-logging t))
968 (prog1
970 (elmo-imap4-read-ok
971 session
972 (elmo-imap4-send-command
973 session
974 (list "login "
975 (elmo-imap4-userid (elmo-network-session-user-internal session))
977 (elmo-imap4-password
978 (elmo-get-passwd (elmo-network-session-password-key session))))))
979 (signal 'elmo-authenticate-error '(elmo-imap4-clear-login)))
980 ;; Fix for Zimbra
981 ;; Some servers return reduced capabilities when client asks for them before login
982 (elmo-imap4-session-set-capability-internal
983 session
984 (elmo-imap4-response-value
985 (elmo-imap4-send-command-wait session "capability")
986 'capability)))))
988 (defun elmo-imap4-auth-login (session)
989 (let ((tag (elmo-imap4-send-command session "authenticate login"))
990 (elmo-imap4-debug-inhibit-logging t))
991 (or (elmo-imap4-read-continue-req session)
992 (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
993 (elmo-imap4-send-string session
994 (elmo-base64-encode-string
995 (elmo-network-session-user-internal session)))
996 (or (elmo-imap4-read-continue-req session)
997 (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
998 (elmo-imap4-send-string session
999 (elmo-base64-encode-string
1000 (elmo-get-passwd
1001 (elmo-network-session-password-key session))))
1002 (or (elmo-imap4-read-ok session tag)
1003 (signal 'elmo-authenticate-error '(elmo-imap4-auth-login)))
1004 (setq elmo-imap4-status 'auth)))
1006 (luna-define-method
1007 elmo-network-initialize-session-buffer :after ((session
1008 elmo-imap4-session) buffer)
1009 (with-current-buffer buffer
1010 (mapcar 'make-variable-buffer-local elmo-imap4-local-variables)
1011 (setq elmo-imap4-seqno 0)
1012 (setq elmo-imap4-status 'initial)))
1014 (luna-define-method elmo-network-initialize-session ((session
1015 elmo-imap4-session))
1016 (let ((process (elmo-network-session-process-internal session)))
1017 (with-current-buffer (process-buffer process)
1018 ;; Skip garbage output from process before greeting.
1019 (while (and (memq (process-status process) '(open run))
1020 (goto-char (point-max))
1021 (or (/= (forward-line -1) 0)
1022 (not (elmo-imap4-parse-greeting))))
1023 (accept-process-output process 1))
1024 (erase-buffer)
1025 (set-process-filter process 'elmo-imap4-arrival-filter)
1026 (set-process-sentinel process 'elmo-imap4-sentinel)
1027 ;;; (while (and (memq (process-status process) '(open run))
1028 ;;; (eq elmo-imap4-status 'initial))
1029 ;;; (message "Waiting for server response...")
1030 ;;; (accept-process-output process 1))
1031 ;;; (message "")
1032 (unless (memq elmo-imap4-status '(nonauth auth))
1033 (signal 'elmo-open-error
1034 (list 'elmo-network-initialize-session)))
1035 (elmo-imap4-session-set-capability-internal
1036 session
1037 (elmo-imap4-response-value
1038 (elmo-imap4-send-command-wait session "capability")
1039 'capability))
1040 (when (eq (elmo-network-stream-type-symbol
1041 (elmo-network-session-stream-type-internal session))
1042 'starttls)
1043 (or (elmo-imap4-session-capable-p session 'starttls)
1044 (signal 'elmo-open-error
1045 '(elmo-imap4-starttls-error)))
1046 (elmo-imap4-send-command-wait session "starttls")
1047 (starttls-negotiate process)
1048 (elmo-imap4-session-set-capability-internal
1049 session
1050 (elmo-imap4-response-value
1051 (elmo-imap4-send-command-wait session "capability")
1052 'capability))))))
1054 (luna-define-method elmo-network-authenticate-session ((session
1055 elmo-imap4-session))
1056 (with-current-buffer (process-buffer
1057 (elmo-network-session-process-internal session))
1058 (let* ((auth (elmo-network-session-auth-internal session))
1059 (auth (if (listp auth) auth (list auth))))
1060 (unless (or (eq elmo-imap4-status 'auth)
1061 (null auth))
1062 (cond
1063 ((eq 'clear (car auth))
1064 (elmo-imap4-clear-login session))
1065 ((eq 'login (car auth))
1066 (elmo-imap4-auth-login session))
1068 (let* ((elmo-imap4-debug-inhibit-logging t)
1069 (sasl-mechanisms
1070 (delq nil
1071 (mapcar
1072 '(lambda (cap)
1073 (if (string-match "^auth=\\(.*\\)$"
1074 (symbol-name cap))
1075 (match-string 1 (upcase (symbol-name cap)))))
1076 (elmo-imap4-session-capability-internal session))))
1077 (mechanism
1078 (sasl-find-mechanism
1079 (delq nil
1080 (mapcar '(lambda (cap) (upcase (symbol-name cap)))
1081 (if (listp auth)
1082 auth
1083 (list auth)))))) ;)
1084 client name step response tag
1085 sasl-read-passphrase)
1086 (unless mechanism
1087 (if (or elmo-imap4-force-login
1088 (y-or-n-p
1089 (format
1090 "There's no %s capability in server. continue?"
1091 (elmo-list-to-string
1092 (elmo-network-session-auth-internal session)))))
1093 (setq mechanism (sasl-find-mechanism
1094 sasl-mechanisms))
1095 (signal 'elmo-authenticate-error
1096 '(elmo-imap4-auth-no-mechanisms))))
1097 (setq client
1098 (sasl-make-client
1099 mechanism
1100 (elmo-network-session-user-internal session)
1101 "imap"
1102 (elmo-network-session-server-internal session)))
1103 ;;; (if elmo-imap4-auth-user-realm
1104 ;;; (sasl-client-set-property client 'realm elmo-imap4-auth-user-realm))
1105 (setq name (sasl-mechanism-name mechanism)
1106 step (sasl-next-step client nil))
1107 (elmo-network-session-set-auth-internal
1108 session
1109 (intern (downcase name)))
1110 (setq sasl-read-passphrase
1111 (function
1112 (lambda (prompt)
1113 (elmo-get-passwd
1114 (elmo-network-session-password-key session)))))
1115 (setq tag
1116 (elmo-imap4-send-command
1117 session
1118 (concat "AUTHENTICATE " name
1119 (and (sasl-step-data step)
1120 (concat
1122 (elmo-base64-encode-string
1123 (sasl-step-data step)
1124 'no-lin-break))))))
1125 (catch 'done
1126 (while t
1127 (setq response
1128 (elmo-imap4-read-untagged
1129 (elmo-network-session-process-internal session)))
1130 (if (elmo-imap4-response-ok-p response)
1131 (if (sasl-next-step client step)
1132 ;; Bogus server?
1133 (signal 'elmo-authenticate-error
1134 (list (intern
1135 (concat "elmo-imap4-auth-"
1136 (downcase name)))))
1137 ;; The authentication process is finished.
1138 (throw 'done nil)))
1139 (unless (elmo-imap4-response-continue-req-p response)
1140 ;; response is NO or BAD.
1141 (signal 'elmo-authenticate-error
1142 (list (intern
1143 (concat "elmo-imap4-auth-"
1144 (downcase name))))))
1145 (sasl-step-set-data
1146 step
1147 (elmo-base64-decode-string
1148 (elmo-imap4-response-value response 'continue-req)))
1149 (setq step (sasl-next-step client step))
1150 (setq tag
1151 (elmo-imap4-send-string
1152 session
1153 (if (sasl-step-data step)
1154 (elmo-base64-encode-string (sasl-step-data step)
1155 'no-line-break)
1156 ""))))))))))))
1158 (luna-define-method elmo-network-setup-session ((session
1159 elmo-imap4-session))
1160 (with-current-buffer (elmo-network-session-buffer session)
1161 (when (elmo-imap4-session-capable-p session 'namespace)
1162 (setq elmo-imap4-server-namespace
1163 (elmo-imap4-response-value
1164 (elmo-imap4-send-command-wait session "namespace")
1165 'namespace)))))
1167 (defun elmo-imap4-setup-send-buffer (&optional string)
1168 (let ((send-buf (get-buffer-create " *elmo-imap4-setup-send-buffer*"))
1169 (source-buf (unless string (current-buffer))))
1170 (save-excursion
1171 (save-match-data
1172 (set-buffer send-buf)
1173 (erase-buffer)
1174 (set-buffer-multibyte nil)
1175 (if string
1176 (insert string)
1177 (with-current-buffer source-buf
1178 (copy-to-buffer send-buf (point-min) (point-max))))
1179 (goto-char (point-min))
1180 (if (eq (re-search-forward "^$" nil t)
1181 (point-max))
1182 (insert "\n"))
1183 (goto-char (point-min))
1184 (while (search-forward "\n" nil t)
1185 (replace-match "\r\n"))))
1186 send-buf))
1188 (defun elmo-imap4-setup-send-buffer-from-file (file)
1189 (let ((tmp-buf (get-buffer-create
1190 " *elmo-imap4-setup-send-buffer-from-file*")))
1191 (save-excursion
1192 (save-match-data
1193 (set-buffer tmp-buf)
1194 (erase-buffer)
1195 (as-binary-input-file
1196 (insert-file-contents file))
1197 (goto-char (point-min))
1198 (if (eq (re-search-forward "^$" nil t)
1199 (point-max))
1200 (insert "\n"))
1201 (goto-char (point-min))
1202 (while (search-forward "\n" nil t)
1203 (replace-match "\r\n"))))
1204 tmp-buf))
1206 (luna-define-method elmo-delete-message-safe ((folder elmo-imap4-folder)
1207 number msgid)
1208 (let ((session (elmo-imap4-get-session folder))
1209 candidates)
1210 (elmo-imap4-session-select-mailbox
1211 session
1212 (elmo-imap4-folder-mailbox-internal folder))
1213 (setq candidates
1214 (elmo-imap4-response-value
1215 (elmo-imap4-send-command-wait session
1216 (list
1217 (if elmo-imap4-use-uid
1218 "uid search header message-id "
1219 "search header message-id ")
1220 (elmo-imap4-field-body msgid)))
1221 'search))
1222 (if (memq number candidates)
1223 (elmo-folder-delete-messages folder (list number)))))
1225 (defun elmo-imap4-server-diff-async-callback-1 (status data)
1226 (funcall elmo-imap4-server-diff-async-callback
1227 (list (elmo-imap4-response-value status 'recent)
1228 (elmo-imap4-response-value status 'unseen)
1229 (elmo-imap4-response-value status 'messages))
1230 data))
1232 (defun elmo-imap4-server-diff-async (folder)
1233 (let ((session (elmo-imap4-get-session folder)))
1234 ;; We should `check' folder to obtain newest information here.
1235 ;; But since there's no asynchronous check mechanism in elmo yet,
1236 ;; checking is not done here.
1237 (with-current-buffer (elmo-network-session-buffer session)
1238 (setq elmo-imap4-status-callback
1239 'elmo-imap4-server-diff-async-callback-1)
1240 (setq elmo-imap4-status-callback-data
1241 elmo-imap4-server-diff-async-callback-data))
1242 (elmo-imap4-send-command session
1243 (list
1244 "status "
1245 (elmo-imap4-mailbox
1246 (elmo-imap4-folder-mailbox-internal folder))
1247 " (recent unseen messages)"))))
1249 (luna-define-method elmo-server-diff-async ((folder elmo-imap4-folder))
1250 (let ((session (elmo-imap4-get-session folder)))
1251 ;; commit.
1252 ;; (elmo-imap4-commit spec)
1253 (with-current-buffer (elmo-network-session-buffer session)
1254 (setq elmo-imap4-status-callback
1255 'elmo-imap4-server-diff-async-callback-1)
1256 (setq elmo-imap4-status-callback-data
1257 elmo-imap4-server-diff-async-callback-data))
1258 (elmo-imap4-send-command session
1259 (list
1260 "status "
1261 (elmo-imap4-mailbox
1262 (elmo-imap4-folder-mailbox-internal folder))
1263 " (recent unseen messages)"))))
1265 ;;; IMAP parser.
1267 (defvar elmo-imap4-server-eol "\r\n"
1268 "The EOL string sent from the server.")
1270 (defvar elmo-imap4-client-eol "\r\n"
1271 "The EOL string we send to the server.")
1273 (defvar elmo-imap4-literal-progress-reporter nil)
1275 (defun elmo-imap4-find-next-line ()
1276 "Return point at end of current line, taking into account literals.
1277 Return nil if no complete line has arrived."
1278 (when (re-search-forward (concat elmo-imap4-server-eol "\\|{\\([0-9]+\\)}"
1279 elmo-imap4-server-eol)
1280 nil t)
1281 (if (match-string 1)
1282 (if (< (point-max) (+ (point) (string-to-number (match-string 1))))
1283 (progn
1284 (when elmo-imap4-literal-progress-reporter
1285 (elmo-progress-notify
1286 'elmo-retrieve-message
1287 :set (- (point-max) (point))
1288 :total (string-to-number (match-string 1))))
1289 nil)
1290 (goto-char (+ (point) (string-to-number (match-string 1))))
1291 (elmo-imap4-find-next-line))
1292 (point))))
1294 (defun elmo-imap4-sentinel (process string)
1295 (delete-process process))
1297 (defun elmo-imap4-arrival-filter (proc string)
1298 "IMAP process filter."
1299 (when (buffer-live-p (process-buffer proc))
1300 (with-current-buffer (process-buffer proc)
1301 (goto-char (point-max))
1302 (insert string)
1303 (let (end)
1304 (goto-char (point-min))
1305 (while (setq end (elmo-imap4-find-next-line))
1306 (save-restriction
1307 (narrow-to-region (point-min) end)
1308 (delete-backward-char (length elmo-imap4-server-eol))
1309 (goto-char (point-min))
1310 (unwind-protect
1311 (case elmo-imap4-status
1312 (initial
1313 (setq elmo-imap4-current-response
1314 (list
1315 (list 'greeting (elmo-imap4-parse-greeting)))))
1316 ((auth nonauth selected examine)
1317 (setq elmo-imap4-current-response
1318 (cons (elmo-imap4-parse-response)
1319 elmo-imap4-current-response)))
1321 (message "Unknown state %s in arrival filter"
1322 elmo-imap4-status)))
1323 (delete-region (point-min) (point-max)))))))))
1325 ;; IMAP parser.
1327 (defsubst elmo-imap4-forward ()
1328 (or (eobp) (forward-char 1)))
1330 (defsubst elmo-imap4-parse-number ()
1331 (when (looking-at "[0-9]+")
1332 (prog1
1333 (string-to-number (match-string 0))
1334 (goto-char (match-end 0)))))
1336 (defsubst elmo-imap4-parse-literal ()
1337 (when (looking-at "{\\([0-9]+\\)}\r\n")
1338 (let ((pos (match-end 0))
1339 (len (string-to-number (match-string 1))))
1340 (if (< (point-max) (+ pos len))
1342 (goto-char (+ pos len))
1343 (buffer-substring pos (+ pos len))))))
1344 ;;; (list ' pos (+ pos len))))))
1346 (defsubst elmo-imap4-parse-string ()
1347 (cond ((eq (char-after (point)) ?\")
1348 (forward-char 1)
1349 (let ((p (point)) (name ""))
1350 (skip-chars-forward "^\"\\\\")
1351 (setq name (buffer-substring p (point)))
1352 (while (eq (char-after (point)) ?\\)
1353 (setq p (1+ (point)))
1354 (forward-char 2)
1355 (skip-chars-forward "^\"\\\\")
1356 (setq name (concat name (buffer-substring p (point)))))
1357 (forward-char 1)
1358 name))
1359 ((eq (char-after (point)) ?{)
1360 (elmo-imap4-parse-literal))))
1362 (defsubst elmo-imap4-parse-nil ()
1363 (if (looking-at "NIL")
1364 (goto-char (match-end 0))))
1366 (defsubst elmo-imap4-parse-nstring ()
1367 (or (elmo-imap4-parse-string)
1368 (and (elmo-imap4-parse-nil)
1369 nil)))
1371 (defsubst elmo-imap4-parse-astring ()
1372 (or (elmo-imap4-parse-string)
1373 (buffer-substring (point)
1374 (if (re-search-forward "[(){ \r\n%*\"\\]" nil t)
1375 (goto-char (1- (match-end 0)))
1376 (end-of-line)
1377 (point)))))
1379 (defsubst elmo-imap4-parse-address ()
1380 (let (address)
1381 (when (eq (char-after (point)) ?\()
1382 (elmo-imap4-forward)
1383 (setq address (vector (prog1 (elmo-imap4-parse-nstring)
1384 (elmo-imap4-forward))
1385 (prog1 (elmo-imap4-parse-nstring)
1386 (elmo-imap4-forward))
1387 (prog1 (elmo-imap4-parse-nstring)
1388 (elmo-imap4-forward))
1389 (elmo-imap4-parse-nstring)))
1390 (when (eq (char-after (point)) ?\))
1391 (elmo-imap4-forward)
1392 address))))
1394 (defsubst elmo-imap4-parse-address-list ()
1395 (if (eq (char-after (point)) ?\()
1396 (let (address addresses)
1397 (elmo-imap4-forward)
1398 (while (and (not (eq (char-after (point)) ?\)))
1399 ;; next line for MS Exchange bug
1400 (progn (and (eq (char-after (point)) ? ) (elmo-imap4-forward)) t)
1401 (setq address (elmo-imap4-parse-address)))
1402 (setq addresses (cons address addresses)))
1403 (when (eq (char-after (point)) ?\))
1404 (elmo-imap4-forward)
1405 (nreverse addresses)))
1406 (assert (elmo-imap4-parse-nil))))
1408 (defsubst elmo-imap4-parse-mailbox ()
1409 (let ((mailbox (elmo-imap4-parse-astring)))
1410 (if (string-equal "INBOX" (upcase mailbox))
1411 "INBOX"
1412 mailbox)))
1414 (defun elmo-imap4-parse-greeting ()
1415 "Parse a IMAP greeting."
1416 (cond ((looking-at "\\* OK ")
1417 (setq elmo-imap4-status 'nonauth))
1418 ((looking-at "\\* PREAUTH ")
1419 (setq elmo-imap4-status 'auth))
1420 ((looking-at "\\* BYE ")
1421 (setq elmo-imap4-status 'closed))))
1423 (defun elmo-imap4-parse-response ()
1424 "Parse a IMAP command response."
1425 (elmo-imap4-debug "[%s] -> %s" (time-stamp-hh:mm:ss) (buffer-substring (point) (point-max)))
1426 (let (token)
1427 (case (setq token (read (current-buffer)))
1428 (+ (progn
1429 (skip-chars-forward " ")
1430 (list 'continue-req (buffer-substring (point) (point-max)))))
1431 (* (case (prog1 (setq token (read (current-buffer)))
1432 (elmo-imap4-forward))
1433 (OK (elmo-imap4-parse-resp-text-code))
1434 (NO (elmo-imap4-parse-resp-text-code))
1435 (BAD (elmo-imap4-parse-resp-text-code))
1436 (BYE (elmo-imap4-parse-bye))
1437 (FLAGS (list 'flags
1438 (elmo-imap4-parse-flag-list)))
1439 (LIST (list 'list (elmo-imap4-parse-data-list)))
1440 (LSUB (list 'lsub (elmo-imap4-parse-data-list)))
1441 (SEARCH (list
1442 'search
1443 (read (concat "("
1444 (buffer-substring (point) (point-max))
1445 ")"))))
1446 (ESEARCH (list
1447 'esearch
1448 (cddr (split-string (buffer-substring (point) (point-max)) " " "\,"))))
1449 (STATUS (elmo-imap4-parse-status))
1450 ;; Added
1451 (NAMESPACE (elmo-imap4-parse-namespace))
1452 (CAPABILITY (list 'capability
1453 (read
1454 (concat "(" (downcase (buffer-substring
1455 (point) (point-max)))
1456 ")"))))
1457 (ACL (elmo-imap4-parse-acl))
1458 (t (case (prog1 (read (current-buffer))
1459 (elmo-imap4-forward))
1460 (EXISTS (list 'exists token))
1461 (RECENT (list 'recent token))
1462 (EXPUNGE (list 'expunge token))
1463 (FETCH (elmo-imap4-parse-fetch token))
1464 (t (list 'garbage (buffer-string)))))))
1465 (t (if (not (string-match elmo-imap4-seq-prefix (symbol-name token)))
1466 (list 'garbage (buffer-string))
1467 (case (prog1 (read (current-buffer))
1468 (elmo-imap4-forward))
1469 (OK (progn
1470 (setq elmo-imap4-parsing nil)
1471 (setq token (symbol-name token))
1472 (elmo-unintern token)
1473 (elmo-imap4-debug "*%s* OK arrived" token)
1474 (setq elmo-imap4-reached-tag token)
1475 (list 'ok (elmo-imap4-parse-resp-text-code))))
1476 (NO (progn
1477 (setq elmo-imap4-parsing nil)
1478 (setq token (symbol-name token))
1479 (elmo-unintern token)
1480 (elmo-imap4-debug "*%s* NO arrived" token)
1481 (setq elmo-imap4-reached-tag token)
1482 (let (code text)
1483 (when (eq (char-after (point)) ?\[)
1484 (setq code (buffer-substring (point)
1485 (search-forward "]")))
1486 (elmo-imap4-forward))
1487 (setq text (buffer-substring (point) (point-max)))
1488 (list 'no (list code text)))))
1489 (BAD (progn
1490 (setq elmo-imap4-parsing nil)
1491 (elmo-imap4-debug "*%s* BAD arrived" token)
1492 (setq token (symbol-name token))
1493 (elmo-unintern token)
1494 (setq elmo-imap4-reached-tag token)
1495 (let (code text)
1496 (when (eq (char-after (point)) ?\[)
1497 (setq code (buffer-substring (point)
1498 (search-forward "]")))
1499 (elmo-imap4-forward))
1500 (setq text (buffer-substring (point) (point-max)))
1501 (list 'bad (list code text)))))
1502 (t (list 'garbage (buffer-string)))))))))
1504 (defun elmo-imap4-parse-bye ()
1505 (let (code text)
1506 (when (eq (char-after (point)) ?\[)
1507 (setq code (buffer-substring (point)
1508 (search-forward "]")))
1509 (elmo-imap4-forward))
1510 (setq text (buffer-substring (point) (point-max)))
1511 (list 'bye (list code text))))
1513 (defun elmo-imap4-parse-text ()
1514 (goto-char (point-min))
1515 (when (search-forward "[" nil t)
1516 (search-forward "]")
1517 (elmo-imap4-forward))
1518 (list 'text (buffer-substring (point) (point-max))))
1520 (defun elmo-imap4-parse-resp-text-code ()
1521 (when (eq (char-after (point)) ?\[)
1522 (elmo-imap4-forward)
1523 (cond ((search-forward "PERMANENTFLAGS " nil t)
1524 (list 'permanentflags (elmo-imap4-parse-flag-list)))
1525 ((search-forward "UIDNEXT " nil t)
1526 (list 'uidnext (read (current-buffer))))
1527 ((search-forward "UNSEEN " nil t)
1528 (list 'unseen (read (current-buffer))))
1529 ((looking-at "UIDVALIDITY \\([0-9]+\\)")
1530 (list 'uidvalidity (match-string 1)))
1531 ((search-forward "READ-ONLY" nil t)
1532 (list 'read-only t))
1533 ((search-forward "READ-WRITE" nil t)
1534 (list 'read-write t))
1535 ((search-forward "NEWNAME " nil t)
1536 (let (oldname newname)
1537 (setq oldname (elmo-imap4-parse-string))
1538 (elmo-imap4-forward)
1539 (setq newname (elmo-imap4-parse-string))
1540 (list 'newname newname oldname)))
1541 ((search-forward "TRYCREATE" nil t)
1542 (list 'trycreate t))
1543 ((looking-at "APPENDUID \\([0-9]+\\) \\([0-9]+\\)")
1544 (list 'appenduid
1545 (list (match-string 1)
1546 (string-to-number (match-string 2)))))
1547 ((looking-at "COPYUID \\([0-9]+\\) \\([0-9,:]+\\) \\([0-9,:]+\\)")
1548 (list 'copyuid (list (match-string 1)
1549 (match-string 2)
1550 (match-string 3))))
1551 ((search-forward "ALERT] " nil t)
1552 (message "IMAP server information: %s"
1553 (buffer-substring (point) (point-max))))
1554 (t (list 'unknown)))))
1556 (defun elmo-imap4-parse-data-list ()
1557 (let (flags delimiter mailbox)
1558 (setq flags (elmo-imap4-parse-flag-list))
1559 (when (looking-at " NIL\\| \"\\\\?\\(.\\)\"")
1560 (setq delimiter (match-string 1))
1561 (goto-char (1+ (match-end 0)))
1562 (when (setq mailbox (elmo-imap4-parse-mailbox))
1563 (list mailbox flags delimiter)))))
1565 (defsubst elmo-imap4-parse-header-list ()
1566 (when (eq (char-after (point)) ?\()
1567 (let (strlist)
1568 (while (not (eq (char-after (point)) ?\)))
1569 (elmo-imap4-forward)
1570 (push (elmo-imap4-parse-astring) strlist))
1571 (elmo-imap4-forward)
1572 (nreverse strlist))))
1574 (defsubst elmo-imap4-parse-fetch-body-section ()
1575 (let ((section
1576 (buffer-substring (point)
1578 (progn (re-search-forward "[] ]" nil t)
1579 (point))))))
1580 (if (eq (char-before) ? )
1581 (prog1
1582 (mapconcat 'identity
1583 (cons section (elmo-imap4-parse-header-list)) " ")
1584 (search-forward "]" nil t))
1585 section)))
1587 (defun elmo-imap4-parse-fetch (response)
1588 (when (eq (char-after (point)) ?\()
1589 (let (element list)
1590 (while (not (eq (char-after (point)) ?\)))
1591 (elmo-imap4-forward)
1592 (let ((token (read (current-buffer))))
1593 (elmo-imap4-forward)
1594 (setq element
1595 (cond ((eq token 'UID)
1596 (list 'uid (condition-case nil
1597 (read (current-buffer))
1598 (error nil))))
1599 ((eq token 'FLAGS)
1600 (list 'flags (elmo-imap4-parse-flag-list)))
1601 ((eq token 'ENVELOPE)
1602 (list 'envelope (elmo-imap4-parse-envelope)))
1603 ((eq token 'INTERNALDATE)
1604 (list 'internaldate (elmo-imap4-parse-string)))
1605 ((eq token 'RFC822)
1606 (list 'rfc822 (elmo-imap4-parse-nstring)))
1607 ((eq token (intern elmo-imap4-rfc822-header))
1608 (list 'rfc822header (elmo-imap4-parse-nstring)))
1609 ((eq token (intern elmo-imap4-rfc822-text))
1610 (list 'rfc822text (elmo-imap4-parse-nstring)))
1611 ((eq token (intern elmo-imap4-rfc822-size))
1612 (list 'rfc822size (read (current-buffer))))
1613 ((eq token 'BODY)
1614 (if (eq (char-before) ?\[)
1615 (list
1616 'bodydetail
1617 (upcase (elmo-imap4-parse-fetch-body-section))
1618 (and
1619 (eq (char-after (point)) ?<)
1620 (buffer-substring (1+ (point))
1621 (progn
1622 (search-forward ">" nil t)
1623 (point))))
1624 (progn (elmo-imap4-forward)
1625 (elmo-imap4-parse-nstring)))
1626 (list 'body (elmo-imap4-parse-body))))
1627 ((eq token 'BODYSTRUCTURE)
1628 (list 'bodystructure (elmo-imap4-parse-body)))))
1629 (setq list (cons element list))))
1630 (and elmo-imap4-fetch-callback
1631 (funcall elmo-imap4-fetch-callback
1632 list elmo-imap4-fetch-callback-data))
1633 (list 'fetch list))))
1635 (defun elmo-imap4-parse-status ()
1636 (let ((mailbox (elmo-imap4-parse-mailbox))
1637 status)
1638 (when (and mailbox (search-forward "(" nil t))
1639 (while (not (eq (char-after (point)) ?\)))
1640 (setq status
1641 (cons
1642 (let ((token (read (current-buffer))))
1643 (case (intern (upcase (symbol-name token)))
1644 (MESSAGES
1645 (list 'messages (read (current-buffer))))
1646 (RECENT
1647 (list 'recent (read (current-buffer))))
1648 (UIDNEXT
1649 (list 'uidnext (read (current-buffer))))
1650 (UIDVALIDITY
1651 (and (looking-at " \\([0-9]+\\)")
1652 (prog1 (list 'uidvalidity (match-string 1))
1653 (goto-char (match-end 1)))))
1654 (UNSEEN
1655 (list 'unseen (read (current-buffer))))
1657 (message
1658 "Unknown status data %s in mailbox %s ignored"
1659 token mailbox))))
1660 status))
1661 (skip-chars-forward " ")))
1662 (and elmo-imap4-status-callback
1663 (funcall elmo-imap4-status-callback
1664 status
1665 elmo-imap4-status-callback-data))
1666 (list 'status status)))
1669 (defmacro elmo-imap4-value (value)
1670 `(if (eq ,value 'NIL)
1672 ,value))
1674 (defmacro elmo-imap4-nth (pos list)
1675 `(let ((value (nth ,pos ,list)))
1676 (elmo-imap4-value value)))
1678 (defun elmo-imap4-parse-namespace ()
1679 (list 'namespace
1680 (nconc
1681 (copy-sequence elmo-imap4-extra-namespace-alist)
1682 (elmo-imap4-parse-namespace-subr
1683 (read (concat "(" (buffer-substring
1684 (point) (point-max))
1685 ")"))))))
1687 (defun elmo-imap4-parse-namespace-subr (ns)
1688 (let (prefix delim namespace-alist default-delim)
1689 ;; 0: personal, 1: other, 2: shared
1690 (dotimes (i 3)
1691 (setq namespace-alist
1692 (nconc namespace-alist
1693 (delq nil
1694 (mapcar
1695 (lambda (namespace)
1696 (setq prefix (elmo-imap4-nth 0 namespace)
1697 delim (elmo-imap4-nth 1 namespace))
1698 (if (and prefix delim
1699 (string-match
1700 (concat (regexp-quote delim) "\\'")
1701 prefix))
1702 (setq prefix (substring prefix 0
1703 (match-beginning 0))))
1704 (if (eq (length prefix) 0)
1705 (progn (setq default-delim delim) nil)
1706 (cons
1707 (concat "^\\("
1708 (if (string= (downcase prefix) "inbox")
1709 "[Ii][Nn][Bb][Oo][Xx]"
1710 (regexp-quote prefix))
1711 "\\).*$")
1712 delim)))
1713 (elmo-imap4-nth i ns))))))
1714 (if default-delim
1715 (setq namespace-alist
1716 (nconc namespace-alist
1717 (list (cons "^.*$" default-delim)))))
1718 namespace-alist))
1720 (defun elmo-imap4-parse-acl ()
1721 (let ((mailbox (elmo-imap4-parse-mailbox))
1722 identifier rights acl)
1723 (while (eq (char-after (point)) ?\ )
1724 (elmo-imap4-forward)
1725 (setq identifier (elmo-imap4-parse-astring))
1726 (elmo-imap4-forward)
1727 (setq rights (elmo-imap4-parse-astring))
1728 (setq acl (append acl (list (cons identifier rights)))))
1729 (list 'acl acl mailbox)))
1731 (defun elmo-imap4-parse-flag-list ()
1732 (let ((str (buffer-substring (+ (point) 1)
1733 (progn (search-forward ")" nil t)
1734 (- (point) 1)))))
1735 (unless (eq (length str) 0)
1736 (split-string str))))
1738 (defun elmo-imap4-parse-envelope ()
1739 (when (eq (char-after (point)) ?\()
1740 (elmo-imap4-forward)
1741 (vector (prog1 (elmo-imap4-parse-nstring);; date
1742 (elmo-imap4-forward))
1743 (prog1 (elmo-imap4-parse-nstring);; subject
1744 (elmo-imap4-forward))
1745 (prog1 (elmo-imap4-parse-address-list);; from
1746 (elmo-imap4-forward))
1747 (prog1 (elmo-imap4-parse-address-list);; sender
1748 (elmo-imap4-forward))
1749 (prog1 (elmo-imap4-parse-address-list);; reply-to
1750 (elmo-imap4-forward))
1751 (prog1 (elmo-imap4-parse-address-list);; to
1752 (elmo-imap4-forward))
1753 (prog1 (elmo-imap4-parse-address-list);; cc
1754 (elmo-imap4-forward))
1755 (prog1 (elmo-imap4-parse-address-list);; bcc
1756 (elmo-imap4-forward))
1757 (prog1 (elmo-imap4-parse-nstring);; in-reply-to
1758 (elmo-imap4-forward))
1759 (prog1 (elmo-imap4-parse-nstring);; message-id
1760 (elmo-imap4-forward)))))
1762 (defsubst elmo-imap4-parse-string-list ()
1763 (cond ((eq (char-after (point)) ?\();; body-fld-param
1764 (let (strlist str)
1765 (elmo-imap4-forward)
1766 (while (setq str (elmo-imap4-parse-string))
1767 (push str strlist)
1768 (elmo-imap4-forward))
1769 (nreverse strlist)))
1770 ((elmo-imap4-parse-nil)
1771 nil)))
1773 (defun elmo-imap4-parse-body-extension ()
1774 (if (eq (char-after (point)) ?\()
1775 (let (b-e)
1776 (elmo-imap4-forward)
1777 (push (elmo-imap4-parse-body-extension) b-e)
1778 (while (eq (char-after (point)) ?\ )
1779 (elmo-imap4-forward)
1780 (push (elmo-imap4-parse-body-extension) b-e))
1781 (assert (eq (char-after (point)) ?\)))
1782 (elmo-imap4-forward)
1783 (nreverse b-e))
1784 (or (elmo-imap4-parse-number)
1785 (elmo-imap4-parse-nstring))))
1787 (defsubst elmo-imap4-parse-body-ext ()
1788 (let (ext)
1789 (when (eq (char-after (point)) ?\ );; body-fld-dsp
1790 (elmo-imap4-forward)
1791 (let (dsp)
1792 (if (eq (char-after (point)) ?\()
1793 (progn
1794 (elmo-imap4-forward)
1795 (push (elmo-imap4-parse-string) dsp)
1796 (elmo-imap4-forward)
1797 (push (elmo-imap4-parse-string-list) dsp)
1798 (elmo-imap4-forward))
1799 (assert (elmo-imap4-parse-nil)))
1800 (push (nreverse dsp) ext))
1801 (when (eq (char-after (point)) ?\ );; body-fld-lang
1802 (elmo-imap4-forward)
1803 (if (eq (char-after (point)) ?\()
1804 (push (elmo-imap4-parse-string-list) ext)
1805 (push (elmo-imap4-parse-nstring) ext))
1806 (while (eq (char-after (point)) ?\ );; body-extension
1807 (elmo-imap4-forward)
1808 (setq ext (append (elmo-imap4-parse-body-extension) ext)))))
1809 ext))
1811 (defun elmo-imap4-parse-body ()
1812 (let (body)
1813 (when (eq (char-after (point)) ?\()
1814 (elmo-imap4-forward)
1815 (if (eq (char-after (point)) ?\()
1816 (let (subbody)
1817 (while (and (eq (char-after (point)) ?\()
1818 (setq subbody (elmo-imap4-parse-body)))
1819 (push subbody body))
1820 (elmo-imap4-forward)
1821 (push (elmo-imap4-parse-string) body);; media-subtype
1822 (when (eq (char-after (point)) ?\ );; body-ext-mpart:
1823 (elmo-imap4-forward)
1824 (if (eq (char-after (point)) ?\();; body-fld-param
1825 (push (elmo-imap4-parse-string-list) body)
1826 (push (and (elmo-imap4-parse-nil) nil) body))
1827 (setq body
1828 (append (elmo-imap4-parse-body-ext) body)));; body-ext-...
1829 (assert (eq (char-after (point)) ?\)))
1830 (elmo-imap4-forward)
1831 (nreverse body))
1833 (push (elmo-imap4-parse-string) body);; media-type
1834 (elmo-imap4-forward)
1835 (push (elmo-imap4-parse-string) body);; media-subtype
1836 (elmo-imap4-forward)
1837 ;; next line for Sun SIMS bug
1838 (and (eq (char-after (point)) ? ) (elmo-imap4-forward))
1839 (if (eq (char-after (point)) ?\();; body-fld-param
1840 (push (elmo-imap4-parse-string-list) body)
1841 (push (and (elmo-imap4-parse-nil) nil) body))
1842 (elmo-imap4-forward)
1843 (push (elmo-imap4-parse-nstring) body);; body-fld-id
1844 (elmo-imap4-forward)
1845 (push (elmo-imap4-parse-nstring) body);; body-fld-desc
1846 (elmo-imap4-forward)
1847 (push (elmo-imap4-parse-string) body);; body-fld-enc
1848 (elmo-imap4-forward)
1849 (push (elmo-imap4-parse-number) body);; body-fld-octets
1851 ;; ok, we're done parsing the required parts, what comes now is one
1852 ;; of three things:
1854 ;; envelope (then we're parsing body-type-msg)
1855 ;; body-fld-lines (then we're parsing body-type-text)
1856 ;; body-ext-1part (then we're parsing body-type-basic)
1858 ;; the problem is that the two first are in turn optionally followed
1859 ;; by the third. So we parse the first two here (if there are any)...
1861 (when (eq (char-after (point)) ?\ )
1862 (elmo-imap4-forward)
1863 (let (lines)
1864 (cond ((eq (char-after (point)) ?\();; body-type-msg:
1865 (push (elmo-imap4-parse-envelope) body);; envelope
1866 (elmo-imap4-forward)
1867 (push (elmo-imap4-parse-body) body);; body
1868 (elmo-imap4-forward)
1869 (push (elmo-imap4-parse-number) body));; body-fld-lines
1870 ((setq lines (elmo-imap4-parse-number));; body-type-text:
1871 (push lines body));; body-fld-lines
1873 (backward-char)))));; no match...
1875 ;; ...and then parse the third one here...
1877 (when (eq (char-after (point)) ?\ );; body-ext-1part:
1878 (elmo-imap4-forward)
1879 (push (elmo-imap4-parse-nstring) body);; body-fld-md5
1880 (setq body
1881 (append (elmo-imap4-parse-body-ext) body)));; body-ext-1part..
1883 (assert (eq (char-after (point)) ?\)))
1884 (elmo-imap4-forward)
1885 (nreverse body)))))
1887 (luna-define-method elmo-folder-initialize ((folder elmo-imap4-folder) name)
1888 (let ((default-user elmo-imap4-default-user)
1889 (default-server elmo-imap4-default-server)
1890 (default-port elmo-imap4-default-port)
1891 (elmo-network-stream-type-alist
1892 (if elmo-imap4-stream-type-alist
1893 (append elmo-imap4-stream-type-alist
1894 elmo-network-stream-type-alist)
1895 elmo-network-stream-type-alist))
1896 tokens)
1897 (when (string-match "\\(.*\\)@\\(.*\\)" default-server)
1898 ;; case: imap4-default-server is specified like
1899 ;; "hoge%imap.server@gateway".
1900 (setq default-user (elmo-match-string 1 default-server))
1901 (setq default-server (elmo-match-string 2 default-server)))
1902 (setq tokens (car (elmo-parse-separated-tokens
1903 name
1904 elmo-imap4-folder-name-syntax)))
1905 ;; mailbox
1906 (elmo-imap4-folder-set-mailbox-internal folder
1907 (elmo-imap4-encode-folder-string
1908 (cdr (assq 'mailbox tokens))))
1909 ;; user
1910 (elmo-net-folder-set-user-internal
1911 folder
1912 (let ((user (cdr (assq 'user tokens))))
1913 (if user
1914 (if (string-match "*" user)
1915 (replace-match "@" nil nil user)
1916 user)
1917 default-user)))
1919 ;; auth
1920 (elmo-net-folder-set-auth-internal
1921 folder
1922 (let ((auth (cdr (assq 'auth tokens))))
1923 (or (and auth (intern auth))
1924 elmo-imap4-default-authenticate-type
1925 'clear)))
1926 ;; network
1927 (elmo-net-folder-set-parameters
1928 folder
1929 tokens
1930 (list :server default-server
1931 :port default-port
1932 :stream-type
1933 (elmo-get-network-stream-type elmo-imap4-default-stream-type)))
1934 folder))
1936 ;;; ELMO IMAP4 folder
1937 (luna-define-method elmo-folder-expand-msgdb-path ((folder
1938 elmo-imap4-folder))
1939 (convert-standard-filename
1940 (let ((mailbox (elmo-imap4-folder-mailbox-internal folder)))
1941 (if (string= "inbox" (downcase mailbox))
1942 (setq mailbox "inbox"))
1943 (if (eq (string-to-char mailbox) ?/)
1944 (setq mailbox (substring mailbox 1 (length mailbox))))
1945 ;; don't use expand-file-name (e.g. %~/something)
1946 (concat
1947 (expand-file-name
1948 (or (elmo-net-folder-user-internal folder) "nobody")
1949 (expand-file-name (or (elmo-net-folder-server-internal folder)
1950 "nowhere")
1951 (expand-file-name
1952 "imap"
1953 elmo-msgdb-directory)))
1954 "/" mailbox))))
1956 (luna-define-method elmo-folder-status-plugged ((folder
1957 elmo-imap4-folder))
1958 (elmo-imap4-folder-status-plugged folder))
1960 (defun elmo-imap4-folder-status-plugged (folder)
1961 (let ((session (elmo-imap4-get-session folder))
1962 (killed (elmo-msgdb-killed-list-load
1963 (elmo-folder-msgdb-path folder)))
1964 status)
1965 (with-current-buffer (elmo-network-session-buffer session)
1966 (setq elmo-imap4-status-callback nil)
1967 (setq elmo-imap4-status-callback-data nil))
1968 (setq status (elmo-imap4-response-value
1969 (elmo-imap4-send-command-wait
1970 session
1971 (list "status "
1972 (elmo-imap4-mailbox
1973 (elmo-imap4-folder-mailbox-internal folder))
1974 " (uidnext messages)"))
1975 'status))
1976 (cons
1977 (- (elmo-imap4-response-value status 'uidnext) 1)
1978 (if killed
1980 (elmo-imap4-response-value status 'messages)
1981 (elmo-msgdb-killed-list-length killed))
1982 (elmo-imap4-response-value status 'messages)))))
1984 (defun elmo-imap4-folder-list-range (folder min max)
1985 (elmo-imap4-list
1986 folder
1987 (concat
1988 (let ((killed
1989 (elmo-folder-killed-list-internal
1990 folder)))
1991 (if (and killed
1992 (eq (length killed) 1)
1993 (consp (car killed))
1994 (eq (car (car killed)) 1))
1995 ;; What about elmo-imap4-use-uid?
1996 (format "uid %d:%s" (cdr (car killed)) max)
1997 (format "uid %s:%s" min max)))
1998 " undeleted")))
2000 (luna-define-method elmo-folder-list-messages-plugged ((folder
2001 elmo-imap4-folder)
2002 &optional
2003 enable-killed)
2005 (let* ((old (elmo-msgdb-list-messages (elmo-folder-msgdb folder)))
2006 (new (elmo-imap4-folder-list-range folder
2007 (1+ (or (elmo-folder-get-info-max folder) 0)) "*"))
2008 (united-old-new (elmo-union old new)))
2009 (if (= (length united-old-new) (or (elmo-folder-get-info-length folder) 0))
2010 united-old-new
2011 (elmo-union new
2012 (elmo-imap4-folder-list-range
2013 folder
2014 1 (1+ (or (elmo-folder-get-info-max folder) 0)))))))
2016 (luna-define-method elmo-folder-list-flagged-plugged
2017 ((folder elmo-imap4-folder) flag)
2018 (elmo-imap4-folder-list-flagged folder flag))
2020 (luna-define-method elmo-folder-use-flag-p ((folder elmo-imap4-folder))
2021 (not (string-match elmo-imap4-disuse-server-flag-mailbox-regexp
2022 (elmo-imap4-folder-mailbox-internal folder))))
2024 (luna-define-method elmo-folder-list-subfolders ((folder elmo-imap4-folder)
2025 &optional one-level)
2026 (let* ((root (elmo-imap4-folder-mailbox-internal folder))
2027 (session (elmo-imap4-get-session folder))
2028 (prefix (elmo-folder-prefix-internal folder))
2029 (namespace-assoc
2030 (elmo-string-matched-assoc
2031 root
2032 (with-current-buffer (elmo-network-session-buffer session)
2033 elmo-imap4-server-namespace)))
2034 (delim (or (cdr namespace-assoc)
2035 elmo-imap4-default-hierarchy-delimiter))
2036 ;; Append delimiter when root with namespace.
2037 (root-nodelim root)
2038 (root (if (and namespace-assoc
2039 (match-end 1)
2040 (string= (substring root (match-end 1))
2041 ""))
2042 (concat root delim)
2043 root))
2044 result append-serv type)
2045 (setq result (elmo-imap4-response-get-selectable-mailbox-list
2046 (elmo-imap4-send-command-wait
2047 session
2048 (list "list " (elmo-imap4-mailbox root) " *"))))
2049 ;; The response of Courier-imap doesn't contain a specified folder itself.
2050 (unless (member root result)
2051 (setq result
2052 (append result
2053 (elmo-imap4-response-get-selectable-mailbox-list
2054 (elmo-imap4-send-command-wait
2055 session
2056 (list "list \"\" " (elmo-imap4-mailbox
2057 root-nodelim)))))))
2058 (when (or (not (string= (elmo-net-folder-user-internal folder)
2059 elmo-imap4-default-user))
2060 (not (eq (elmo-net-folder-auth-internal folder)
2061 (or elmo-imap4-default-authenticate-type 'clear))))
2062 (setq append-serv (concat ":"
2063 (elmo-quote-syntactical-element
2064 (elmo-net-folder-user-internal folder)
2065 'user elmo-imap4-folder-name-syntax))))
2066 (unless (eq (elmo-net-folder-auth-internal folder)
2067 (or elmo-imap4-default-authenticate-type 'clear))
2068 (setq append-serv
2069 (concat append-serv "/"
2070 (symbol-name (elmo-net-folder-auth-internal folder)))))
2071 (unless (string= (elmo-net-folder-server-internal folder)
2072 elmo-imap4-default-server)
2073 (setq append-serv (concat append-serv "@"
2074 (elmo-net-folder-server-internal folder))))
2075 (unless (eq (elmo-net-folder-port-internal folder) elmo-imap4-default-port)
2076 (setq append-serv (concat append-serv ":"
2077 (int-to-string
2078 (elmo-net-folder-port-internal folder)))))
2079 (setq type (elmo-net-folder-stream-type-internal folder))
2080 (unless (eq (elmo-network-stream-type-symbol type)
2081 elmo-imap4-default-stream-type)
2082 (if type
2083 (setq append-serv (concat append-serv
2084 (elmo-network-stream-type-spec-string
2085 type)))))
2086 (if one-level
2087 (let ((re-delim (regexp-quote delim))
2088 (case-fold-search nil)
2089 folder ret has-child-p)
2090 ;; Append delimiter
2091 (when (and root
2092 (not (string= root ""))
2093 (not (string-match
2094 (concat "\\(.*\\)" re-delim "\\'")
2095 root)))
2096 (setq root (concat root delim)))
2097 (while (setq folder (car result))
2098 (setq has-child-p
2099 (when (string-match
2100 (concat "^\\(" (regexp-quote root) "[^" re-delim "]" "+\\)"
2101 re-delim)
2102 folder)
2103 (setq folder (match-string 1 folder))))
2104 (setq result (delq
2106 (mapcar (lambda (fld)
2107 (if (string-match
2108 (concat "^" (regexp-quote folder)
2109 "\\(" re-delim "\\|\\'\\)")
2110 fld)
2111 (progn (setq has-child-p t) nil)
2112 fld))
2113 (cdr result)))
2114 folder (concat prefix
2115 (elmo-quote-syntactical-element
2116 (elmo-imap4-decode-folder-string folder)
2117 'mailbox elmo-imap4-folder-name-syntax)
2118 (and append-serv
2119 (eval append-serv)))
2120 ret (append ret (if has-child-p
2121 (list (list folder))
2122 (list folder)))))
2123 ret)
2124 (mapcar (lambda (fld)
2125 (concat prefix
2126 (elmo-quote-syntactical-element
2127 (elmo-imap4-decode-folder-string fld)
2128 'mailbox elmo-imap4-folder-name-syntax)
2129 (and append-serv
2130 (eval append-serv))))
2131 result))))
2133 (luna-define-method elmo-folder-exists-p-plugged ((folder elmo-imap4-folder))
2134 (let ((session (elmo-imap4-get-session folder)))
2135 (if (string=
2136 (elmo-imap4-session-current-mailbox-internal session)
2137 (elmo-imap4-folder-mailbox-internal folder))
2139 (elmo-imap4-session-select-mailbox
2140 session
2141 (elmo-imap4-folder-mailbox-internal folder)
2142 'force 'notify-bye))))
2144 (luna-define-method elmo-folder-creatable-p ((folder elmo-imap4-folder))
2147 (luna-define-method elmo-folder-writable-p ((folder elmo-imap4-folder))
2150 (luna-define-method elmo-folder-delete ((folder elmo-imap4-folder))
2151 (let* ((exists (elmo-folder-exists-p folder))
2152 (msgs (and exists
2153 (elmo-folder-list-messages folder))))
2154 (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
2155 (if (> (length msgs) 0)
2156 (format "%d msg(s) exists. " (length msgs))
2158 (elmo-folder-name-internal folder)))
2159 (let ((session (elmo-imap4-get-session folder)))
2160 (when (elmo-imap4-folder-mailbox-internal folder)
2161 (when msgs (elmo-folder-delete-messages-internal folder msgs))
2162 ;; close selected mailbox except one with \Noselect attribute
2163 (when exists
2164 (elmo-imap4-send-command-wait session "close"))
2165 (elmo-imap4-send-command-wait
2166 session
2167 (list "delete "
2168 (elmo-imap4-mailbox
2169 (elmo-imap4-folder-mailbox-internal folder)))))
2170 (elmo-imap4-session-set-current-mailbox-internal session nil))
2171 (elmo-msgdb-delete-path folder)
2172 t)))
2174 (luna-define-method elmo-folder-rename-internal ((folder elmo-imap4-folder)
2175 new-folder)
2176 (let ((session (elmo-imap4-get-session folder)))
2177 ;; make sure the folder is selected.
2178 (elmo-imap4-session-select-mailbox session
2179 (elmo-imap4-folder-mailbox-internal
2180 folder))
2181 (elmo-imap4-send-command-wait session "close")
2182 (elmo-imap4-send-command-wait
2183 session
2184 (list "rename "
2185 (elmo-imap4-mailbox
2186 (elmo-imap4-folder-mailbox-internal folder))
2188 (elmo-imap4-mailbox
2189 (elmo-imap4-folder-mailbox-internal new-folder))))
2190 (elmo-imap4-session-set-current-mailbox-internal
2191 session (elmo-imap4-folder-mailbox-internal new-folder))))
2193 (defun elmo-imap4-copy-messages (src-folder dst-folder numbers)
2194 (let ((session (elmo-imap4-get-session src-folder))
2195 (set-list (elmo-imap4-make-number-set-list
2196 numbers
2197 elmo-imap4-number-set-chop-length))
2198 succeeds)
2199 (elmo-imap4-session-select-mailbox session
2200 (elmo-imap4-folder-mailbox-internal
2201 src-folder))
2202 (while set-list
2203 (if (elmo-imap4-send-command-wait session
2204 (list
2205 (format
2206 (if elmo-imap4-use-uid
2207 "uid copy %s "
2208 "copy %s ")
2209 (cdr (car set-list)))
2210 (elmo-imap4-mailbox
2211 (elmo-imap4-folder-mailbox-internal
2212 dst-folder))))
2213 (setq succeeds (append succeeds numbers)))
2214 (setq set-list (cdr set-list)))
2215 succeeds))
2217 (defun elmo-imap4-set-flag (folder numbers flag &optional remove)
2218 "Set flag on messages.
2219 FOLDER is the ELMO folder structure.
2220 NUMBERS is the message numbers to be flagged.
2221 FLAG is the flag name.
2222 If optional argument REMOVE is non-nil, remove FLAG."
2223 (let ((session (elmo-imap4-get-session folder))
2224 response set-list)
2225 (elmo-imap4-session-select-mailbox session
2226 (elmo-imap4-folder-mailbox-internal
2227 folder))
2228 (when (or (elmo-string-member-ignore-case
2229 flag
2230 (elmo-imap4-session-flags-internal session))
2231 (member "\\*" (elmo-imap4-session-flags-internal session))
2232 (string= flag "\\Deleted")) ; XXX Humm..
2233 (setq set-list (elmo-imap4-make-number-set-list
2234 numbers
2235 elmo-imap4-number-set-chop-length))
2236 (while set-list
2237 (with-current-buffer (elmo-network-session-buffer session)
2238 (setq elmo-imap4-fetch-callback nil)
2239 (setq elmo-imap4-fetch-callback-data nil))
2240 (unless (elmo-imap4-response-ok-p
2241 (elmo-imap4-send-command-wait
2242 session
2243 (format
2244 (if elmo-imap4-use-uid
2245 "uid store %s %sflags.silent (%s)"
2246 "store %s %sflags.silent (%s)")
2247 (cdr (car set-list))
2248 (if remove "-" "+")
2249 flag)))
2250 (setq response 'fail))
2251 (setq set-list (cdr set-list)))
2252 (not (eq response 'fail)))))
2254 (luna-define-method elmo-folder-delete-messages-plugged
2255 ((folder elmo-imap4-folder) numbers)
2256 (let ((session (elmo-imap4-get-session folder))
2257 (expunge
2258 (or (null (elmo-imap4-list folder "deleted"))
2259 (y-or-n-p
2260 "There's hidden deleted messages, expunge anyway?"))))
2261 (elmo-imap4-session-select-mailbox
2262 session
2263 (elmo-imap4-folder-mailbox-internal folder))
2264 (unless (elmo-imap4-set-flag folder numbers "\\Deleted")
2265 (error "Failed to set deleted flag"))
2266 (when expunge
2267 (elmo-imap4-send-command session "expunge"))
2270 (defmacro elmo-imap4-detect-search-charset (string)
2271 `(with-temp-buffer
2272 (insert ,string)
2273 (detect-mime-charset-region (point-min) (point-max))))
2275 (defun elmo-imap4-search-internal-primitive (folder session filter from-msgs)
2276 (let ((search-key (elmo-filter-key filter))
2277 (imap-search-keys '("bcc" "body" "cc" "from" "subject" "to"
2278 "larger" "smaller" "flag"))
2279 (total 0)
2280 (length (length from-msgs))
2281 charset set-list end results)
2282 (cond
2283 ((string= "last" search-key)
2284 (let ((numbers (or from-msgs (elmo-folder-list-messages folder))))
2285 (nthcdr (max (- (length numbers)
2286 (string-to-number (elmo-filter-value filter)))
2288 numbers)))
2289 ((string= "first" search-key)
2290 (let* ((numbers (or from-msgs (elmo-folder-list-messages folder)))
2291 (rest (nthcdr (string-to-number (elmo-filter-value filter) )
2292 numbers)))
2293 (mapcar '(lambda (x) (delete x numbers)) rest)
2294 numbers))
2295 ((string= "flag" search-key)
2296 (elmo-imap4-folder-list-flagged
2297 folder (intern (elmo-filter-value filter))))
2298 ((or (string= "since" search-key)
2299 (string= "before" search-key))
2300 (setq search-key (concat "sent" search-key)
2301 set-list (elmo-imap4-make-number-set-list
2302 from-msgs
2303 elmo-imap4-number-set-chop-length)
2304 end nil)
2305 (while (not end)
2306 (setq results
2307 (append
2308 results
2309 (elmo-imap4-response-value
2310 (elmo-imap4-send-command-wait
2311 session
2312 (format
2313 (if elmo-imap4-use-uid
2314 "uid search %s%s%s %s"
2315 "search %s%s%s %s")
2316 (if from-msgs
2317 (concat
2318 (if elmo-imap4-use-uid "uid ")
2319 (cdr (car set-list))
2320 " ")
2322 (if (eq (elmo-filter-type filter)
2323 'unmatch)
2324 "not " "")
2325 search-key
2326 (elmo-date-get-description
2327 (elmo-date-get-datevec
2328 (elmo-filter-value filter)))))
2329 'search)))
2330 (setq set-list (cdr set-list)
2331 end (null set-list)))
2332 results)
2334 (setq charset
2335 (if (eq (length (elmo-filter-value filter)) 0)
2336 (setq charset 'us-ascii)
2337 (elmo-imap4-detect-search-charset
2338 (elmo-filter-value filter)))
2339 set-list (elmo-imap4-make-number-set-list
2340 from-msgs
2341 elmo-imap4-number-set-chop-length)
2342 end nil)
2343 (while (not end)
2344 (setq results
2345 (append
2346 results
2347 (elmo-imap4-response-value
2348 (elmo-imap4-send-command-wait
2349 session
2350 (list
2351 (if elmo-imap4-use-uid "uid ")
2352 "search "
2353 "CHARSET "
2354 (elmo-imap4-astring
2355 (symbol-name charset))
2357 (if from-msgs
2358 (concat
2359 (if elmo-imap4-use-uid "uid ")
2360 (cdr (car set-list))
2361 " ")
2363 (if (eq (elmo-filter-type filter)
2364 'unmatch)
2365 "not " "")
2366 (format "%s%s "
2367 (if (member
2368 (elmo-filter-key filter)
2369 imap-search-keys)
2371 "header ")
2372 (elmo-filter-key filter))
2373 (elmo-imap4-astring
2374 (encode-mime-charset-string
2375 (elmo-filter-value filter) charset))))
2376 'search)))
2377 (setq set-list (cdr set-list)
2378 end (null set-list)))
2379 results))))
2381 (defun elmo-imap4-search-internal (folder session condition from-msgs)
2382 (let (result)
2383 (cond
2384 ((vectorp condition)
2385 (setq result (elmo-imap4-search-internal-primitive
2386 folder session condition from-msgs)))
2387 ((eq (car condition) 'and)
2388 (setq result (elmo-imap4-search-internal folder session (nth 1 condition)
2389 from-msgs)
2390 result (elmo-list-filter result
2391 (elmo-imap4-search-internal
2392 folder session (nth 2 condition)
2393 from-msgs))))
2394 ((eq (car condition) 'or)
2395 (setq result (elmo-imap4-search-internal
2396 folder session (nth 1 condition) from-msgs)
2397 result (elmo-uniq-list
2398 (nconc result
2399 (elmo-imap4-search-internal
2400 folder session (nth 2 condition) from-msgs)))
2401 result (sort result '<))))))
2403 (luna-define-method elmo-folder-search :around ((folder elmo-imap4-folder)
2404 condition &optional numbers)
2405 (if (elmo-folder-plugged-p folder)
2406 (save-excursion
2407 (let ((session (elmo-imap4-get-session folder))
2408 ret)
2409 (message "Searching...")
2410 (elmo-imap4-session-select-mailbox
2411 session
2412 (elmo-imap4-folder-mailbox-internal folder))
2413 (setq ret (elmo-imap4-search-internal folder session condition numbers))
2414 (message "Searching...done")
2415 ret))
2416 (luna-call-next-method)))
2418 (luna-define-method elmo-folder-msgdb-create-plugged
2419 ((folder elmo-imap4-folder) numbers flag-table)
2420 (when numbers
2421 (let ((session (elmo-imap4-get-session folder))
2422 (headers
2423 (elmo-uniq-list
2424 (append
2425 '("Subject" "From" "To" "Cc" "Date"
2426 "Message-Id" "References" "In-Reply-To")
2427 (mapcar #'capitalize (elmo-msgdb-extra-fields 'non-virtual)))))
2428 (total 0)
2429 print-length print-depth
2430 rfc2060 set-list)
2431 (setq rfc2060 (elmo-imap4-session-capable-p session 'imap4rev1))
2432 (elmo-with-progress-display (elmo-folder-msgdb-create (length numbers))
2433 "Creating msgdb"
2434 (elmo-imap4-session-select-mailbox
2435 session (elmo-imap4-folder-mailbox-internal folder))
2436 (setq set-list (elmo-imap4-make-number-set-list
2437 numbers
2438 elmo-imap4-overview-fetch-chop-length))
2439 ;; Setup callback.
2440 (with-current-buffer (elmo-network-session-buffer session)
2441 (setq elmo-imap4-current-msgdb (elmo-make-msgdb)
2442 elmo-imap4-seen-messages nil
2443 elmo-imap4-fetch-callback 'elmo-imap4-fetch-callback-1
2444 elmo-imap4-fetch-callback-data (cons flag-table folder))
2445 (while set-list
2446 (elmo-imap4-send-command-wait
2447 session
2448 ;; get overview entity from IMAP4
2449 (format "%sfetch %s (%s rfc822.size flags)"
2450 (if elmo-imap4-use-uid "uid " "")
2451 (cdr (car set-list))
2452 (if rfc2060
2453 (format "body.peek[header.fields %s]" headers)
2454 (format "%s" headers))))
2455 (setq set-list (cdr set-list)))
2456 (when elmo-imap4-seen-messages
2457 (elmo-imap4-set-flag folder elmo-imap4-seen-messages "\\Seen"))
2458 ;; cannot setup the global flag while retrieval.
2459 (dolist (number (elmo-msgdb-list-messages elmo-imap4-current-msgdb))
2460 (elmo-global-flags-set (elmo-msgdb-flags elmo-imap4-current-msgdb
2461 number)
2462 folder number
2463 (elmo-message-entity-field
2464 (elmo-msgdb-message-entity
2465 elmo-imap4-current-msgdb number)
2466 'message-id)))
2467 elmo-imap4-current-msgdb)))))
2469 (luna-define-method elmo-folder-set-flag-plugged ((folder elmo-imap4-folder)
2470 numbers flag)
2471 (let ((spec (cdr (assq flag elmo-imap4-flag-specs))))
2472 (elmo-imap4-set-flag folder numbers (or (car spec)
2473 (capitalize (symbol-name flag)))
2474 (nth 1 spec))))
2476 (luna-define-method elmo-folder-unset-flag-plugged ((folder elmo-imap4-folder)
2477 numbers flag)
2478 (let ((spec (cdr (assq flag elmo-imap4-flag-specs))))
2479 (elmo-imap4-set-flag folder numbers (or (car spec)
2480 (capitalize (symbol-name flag)))
2481 (not (nth 1 spec)))))
2483 (luna-define-method elmo-message-use-cache-p ((folder elmo-imap4-folder)
2484 number)
2485 elmo-imap4-use-cache)
2487 (luna-define-method elmo-folder-message-appendable-p ((folder elmo-imap4-folder))
2488 (if (elmo-folder-plugged-p folder)
2489 (not (elmo-imap4-session-read-only-internal
2490 (elmo-imap4-get-session folder)))
2491 elmo-enable-disconnected-operation)) ; offline refile.
2493 (luna-define-method elmo-folder-check-plugged ((folder elmo-imap4-folder))
2494 (let ((session (elmo-imap4-get-session folder 'if-exists)))
2495 (when session
2496 (if (string=
2497 (elmo-imap4-session-current-mailbox-internal session)
2498 (elmo-imap4-folder-mailbox-internal folder))
2499 (if elmo-imap4-use-select-to-update-status
2500 (elmo-imap4-session-select-mailbox
2501 session
2502 (elmo-imap4-folder-mailbox-internal folder)
2503 'force)
2504 (elmo-imap4-session-check session))))))
2506 (defsubst elmo-imap4-folder-diff-plugged (folder)
2507 (let ((session (elmo-imap4-get-session folder))
2508 messages new unread response killed uidnext)
2509 ;;; (elmo-imap4-commit spec)
2510 (with-current-buffer (elmo-network-session-buffer session)
2511 (setq elmo-imap4-status-callback nil)
2512 (setq elmo-imap4-status-callback-data nil))
2513 (if elmo-imap4-use-select-to-update-status
2514 (elmo-imap4-session-select-mailbox
2515 session
2516 (elmo-imap4-folder-mailbox-internal folder)))
2517 (setq response
2518 (elmo-imap4-send-command-wait session
2519 (list
2520 "status "
2521 (elmo-imap4-mailbox
2522 (elmo-imap4-folder-mailbox-internal
2523 folder))
2524 " (recent unseen messages uidnext)")))
2525 (setq response (elmo-imap4-response-value response 'status))
2526 (setq messages (elmo-imap4-response-value response 'messages))
2527 (setq uidnext (elmo-imap4-response-value response 'uidnext))
2528 (setq killed (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2530 (when killed
2531 (when (and (consp (car killed))
2532 (eq (car (car killed)) 1))
2533 (setq messages (- uidnext (cdr (car killed)) 1)))
2534 (setq messages (- messages
2535 (elmo-msgdb-killed-list-length (cdr killed)))))
2536 (setq new (elmo-imap4-response-value response 'recent)
2537 unread (elmo-imap4-response-value response 'unseen))
2538 (if (< unread new) (setq new unread))
2539 (list new unread messages)))
2541 (luna-define-method elmo-folder-diff-plugged ((folder elmo-imap4-folder))
2542 (elmo-imap4-folder-diff-plugged folder))
2544 (luna-define-method elmo-folder-diff-async ((folder elmo-imap4-folder))
2545 (setq elmo-imap4-server-diff-async-callback
2546 elmo-folder-diff-async-callback)
2547 (setq elmo-imap4-server-diff-async-callback-data
2548 elmo-folder-diff-async-callback-data)
2549 (elmo-imap4-server-diff-async folder))
2551 (luna-define-method elmo-folder-open :around ((folder elmo-imap4-folder)
2552 &optional load-msgdb)
2553 (if (elmo-folder-plugged-p folder)
2554 (let (session mailbox msgdb result response tag)
2555 (condition-case err
2556 (progn
2557 (setq session (elmo-imap4-get-session folder)
2558 mailbox (elmo-imap4-folder-mailbox-internal folder)
2559 tag (elmo-imap4-send-command session
2560 (list "select "
2561 (elmo-imap4-mailbox
2562 mailbox))))
2563 (message "Selecting %s..."
2564 (elmo-folder-name-internal folder))
2565 (if load-msgdb
2566 (setq msgdb (elmo-folder-msgdb-load folder 'silent)))
2567 (elmo-folder-set-killed-list-internal
2568 folder
2569 (elmo-msgdb-killed-list-load (elmo-folder-msgdb-path folder)))
2570 (if (setq result (elmo-imap4-response-ok-p
2571 (setq response
2572 (elmo-imap4-read-response session tag))))
2573 (progn
2574 (let ((exists (assq 'exists response))) ; update message count,
2575 (when exists ; so merge update can go
2576 (elmo-folder-set-info-hashtb folder nil (cadr exists))))
2577 (elmo-imap4-session-set-current-mailbox-internal
2578 session mailbox)
2579 (elmo-imap4-session-set-read-only-internal
2580 session
2581 (nth 1 (assq 'read-only (assq 'ok response))))
2582 (elmo-imap4-session-set-flags-internal
2583 session
2584 (nth 1 (or (assq 'permanentflags response)
2585 (assq 'flags response)))))
2586 (elmo-imap4-session-set-current-mailbox-internal session nil)
2587 (if (elmo-imap4-response-bye-p response)
2588 (elmo-imap4-process-bye session)
2589 (error "%s"
2590 (or (elmo-imap4-response-error-text response)
2591 (format "Select %s failed" mailbox)))))
2592 (message "Selecting %s...done"
2593 (elmo-folder-name-internal folder))
2594 (elmo-folder-set-msgdb-internal
2595 folder msgdb))
2596 (quit
2597 (if (elmo-imap4-response-ok-p response)
2598 (elmo-imap4-session-set-current-mailbox-internal
2599 session mailbox)
2600 (and session
2601 (elmo-imap4-session-set-current-mailbox-internal
2602 session nil))))
2603 (error
2604 (if (elmo-imap4-response-ok-p response)
2605 (elmo-imap4-session-set-current-mailbox-internal
2606 session mailbox)
2607 (and session
2608 (elmo-imap4-session-set-current-mailbox-internal
2609 session nil))))))
2610 (luna-call-next-method)))
2612 ;; elmo-folder-open-internal: do nothing.
2614 (luna-define-method elmo-find-fetch-strategy ((folder elmo-imap4-folder) number
2615 &optional
2616 ignore-cache
2617 require-entireness)
2618 (let ((entity (elmo-message-entity folder number)))
2619 (if (null entity)
2620 (elmo-make-fetch-strategy 'entire)
2621 (let* ((size (elmo-message-entity-field entity 'size))
2622 (message-id (elmo-message-entity-field entity 'message-id))
2623 (cache-file (elmo-file-cache-get message-id))
2624 (use-cache (and (not ignore-cache)
2625 (elmo-message-use-cache-p folder number)
2626 (if require-entireness
2627 (eq (elmo-file-cache-status cache-file)
2628 'entire)
2629 (elmo-file-cache-status cache-file)))))
2630 (elmo-make-fetch-strategy
2631 (if use-cache
2632 (elmo-file-cache-status cache-file)
2633 (if (and (not require-entireness)
2634 elmo-message-fetch-threshold
2635 (integerp size)
2636 (>= size elmo-message-fetch-threshold)
2637 (or (not elmo-message-fetch-confirm)
2638 (not (prog1
2639 (y-or-n-p
2640 (format
2641 "Fetch entire message at once? (%dbytes)"
2642 size))
2643 (message "")))))
2644 'section
2645 'entire))
2646 use-cache
2647 (elmo-message-use-cache-p folder number)
2648 (elmo-file-cache-path cache-file))))))
2650 (luna-define-method elmo-folder-create-plugged ((folder elmo-imap4-folder))
2651 (elmo-imap4-send-command-wait
2652 (elmo-imap4-get-session folder)
2653 (list "create "
2654 (elmo-imap4-mailbox
2655 (elmo-imap4-folder-mailbox-internal folder)))))
2657 (defun elmo-imap4-flags-to-imap (flags)
2658 "Convert FLAGS to the IMAP flag string."
2659 (let ((imap-flag (if (not (memq 'unread flags)) "\\Seen")))
2660 (dolist (flag flags)
2661 (unless (memq flag '(new read unread cached))
2662 (setq imap-flag
2663 (concat imap-flag
2664 (if imap-flag " ")
2665 (or (car (cdr (assq flag elmo-imap4-flag-specs)))
2666 (capitalize (symbol-name flag)))))))
2667 imap-flag))
2669 (luna-define-method elmo-folder-append-buffer
2670 ((folder elmo-imap4-folder) &optional flags number)
2671 (if (elmo-folder-plugged-p folder)
2672 (let ((session (elmo-imap4-get-session folder))
2673 send-buffer result)
2674 (elmo-imap4-session-select-mailbox session
2675 (elmo-imap4-folder-mailbox-internal
2676 folder))
2677 (setq send-buffer (elmo-imap4-setup-send-buffer))
2678 (unwind-protect
2679 (setq result
2680 (elmo-imap4-send-command-wait
2681 session
2682 (list
2683 "append "
2684 (elmo-imap4-mailbox (elmo-imap4-folder-mailbox-internal
2685 folder))
2686 (if (and flags (elmo-folder-use-flag-p folder))
2687 (concat " (" (elmo-imap4-flags-to-imap flags) ") ")
2688 " () ")
2689 (elmo-imap4-buffer-literal send-buffer))))
2690 (kill-buffer send-buffer))
2691 (when result
2692 (elmo-folder-preserve-flags
2693 folder (elmo-msgdb-get-message-id-from-buffer) flags))
2694 result)
2695 ;; Unplugged
2696 (if elmo-enable-disconnected-operation
2697 (elmo-folder-append-buffer-dop folder flags number)
2698 (error "Unplugged"))))
2700 (eval-when-compile
2701 (defmacro elmo-imap4-identical-system-p (folder1 folder2)
2702 "Return t if FOLDER1 and FOLDER2 are in the same IMAP4 system."
2703 `(and (string= (elmo-net-folder-server-internal ,folder1)
2704 (elmo-net-folder-server-internal ,folder2))
2705 (eq (elmo-net-folder-port-internal ,folder1)
2706 (elmo-net-folder-port-internal ,folder2))
2707 (string= (elmo-net-folder-user-internal ,folder1)
2708 (elmo-net-folder-user-internal ,folder2)))))
2710 (luna-define-method elmo-folder-next-message-number-plugged
2711 ((folder elmo-imap4-folder))
2712 (let ((session (elmo-imap4-get-session folder))
2713 messages new unread response killed uidnext)
2714 (with-current-buffer (elmo-network-session-buffer session)
2715 (setq elmo-imap4-status-callback nil)
2716 (setq elmo-imap4-status-callback-data nil))
2717 (if elmo-imap4-use-select-to-update-status
2718 (elmo-imap4-session-select-mailbox
2719 session
2720 (elmo-imap4-folder-mailbox-internal folder)))
2721 (setq response
2722 (elmo-imap4-send-command-wait session
2723 (list
2724 "status "
2725 (elmo-imap4-mailbox
2726 (elmo-imap4-folder-mailbox-internal
2727 folder))
2728 " (uidnext)"))
2729 response (elmo-imap4-response-value response 'status))
2730 (elmo-imap4-response-value response 'uidnext)))
2732 (defun elmo-folder-append-messages-imap4-imap4 (dst-folder
2733 src-folder
2734 numbers
2735 same-number)
2736 (if (and (elmo-imap4-identical-system-p dst-folder src-folder)
2737 (elmo-folder-plugged-p dst-folder))
2738 ;; Plugged
2739 (prog1
2740 (elmo-imap4-copy-messages src-folder dst-folder numbers)
2741 (elmo-progress-notify 'elmo-folder-move-messages (length numbers)))
2742 (elmo-folder-append-messages dst-folder src-folder numbers same-number
2743 'elmo-folder-append-messages-imap4-imap4)))
2745 (luna-define-method elmo-message-deletable-p ((folder elmo-imap4-folder)
2746 number)
2747 (if (elmo-folder-plugged-p folder)
2748 (not (elmo-imap4-session-read-only-internal
2749 (elmo-imap4-get-session folder)))
2750 elmo-enable-disconnected-operation)) ; offline refile.
2752 ;(luna-define-method elmo-message-fetch-unplugged
2753 ; ((folder elmo-imap4-folder)
2754 ; number strategy &optional section outbuf unseen)
2755 ; (error "%d%s is not cached." number (if section
2756 ; (format "(%s)" section)
2757 ; "")))
2759 (defsubst elmo-imap4-message-fetch (folder number strategy
2760 section outbuf unseen)
2761 (let ((session (elmo-imap4-get-session folder))
2762 response)
2763 (elmo-imap4-session-select-mailbox session
2764 (elmo-imap4-folder-mailbox-internal
2765 folder))
2766 (with-current-buffer (elmo-network-session-buffer session)
2767 (setq elmo-imap4-fetch-callback nil)
2768 (setq elmo-imap4-fetch-callback-data nil))
2769 (elmo-with-progress-display (elmo-retrieve-message
2770 (elmo-message-field folder number :size)
2771 elmo-imap4-literal-progress-reporter)
2772 "Retrieving"
2773 (setq response
2774 (elmo-imap4-send-command-wait session
2775 (format
2776 (if elmo-imap4-use-uid
2777 "uid fetch %s body%s[%s]"
2778 "fetch %s body%s[%s]")
2779 number
2780 (if unseen ".peek" "")
2781 (or section "")))))
2782 (if (setq response (elmo-imap4-response-bodydetail-text
2783 (elmo-imap4-response-value-all
2784 response 'fetch)))
2785 (with-current-buffer outbuf
2786 (erase-buffer)
2787 (insert response)
2788 (elmo-delete-cr-buffer)
2789 t))))
2791 (luna-define-method elmo-message-fetch-plugged ((folder elmo-imap4-folder)
2792 number strategy
2793 &optional section
2794 outbuf unseen)
2795 (elmo-imap4-set-flag folder (list number) "\\Seen")
2796 (elmo-imap4-message-fetch folder number strategy section outbuf unseen))
2798 (luna-define-method elmo-message-fetch-field ((folder elmo-imap4-folder)
2799 number field)
2800 (let ((session (elmo-imap4-get-session folder)))
2801 (elmo-imap4-session-select-mailbox session
2802 (elmo-imap4-folder-mailbox-internal
2803 folder))
2804 (with-current-buffer (elmo-network-session-buffer session)
2805 (setq elmo-imap4-fetch-callback nil)
2806 (setq elmo-imap4-fetch-callback-data nil))
2807 (with-temp-buffer
2808 (insert
2809 (elmo-imap4-response-bodydetail-text
2810 (elmo-imap4-response-value
2811 (elmo-imap4-send-command-wait session
2812 (concat
2813 (if elmo-imap4-use-uid
2814 "uid ")
2815 (format
2816 "fetch %s (body.peek[header.fields (%s)])"
2817 number field)))
2818 'fetch)))
2819 (elmo-delete-cr-buffer)
2820 (goto-char (point-min))
2821 (std11-field-body (symbol-name field)))))
2823 (luna-define-method elmo-folder-search-requires-msgdb-p ((folder
2824 elmo-imap4-folder)
2825 condition)
2826 nil)
2828 (autoload 'elmo-global-flags-set "elmo-flag")
2829 (autoload 'elmo-get-global-flags "elmo-flag")
2831 (require 'product)
2832 (product-provide (provide 'elmo-imap4) (require 'elmo-version))
2834 ;;; elmo-imap4.el ends here