elmo/elmo-imap4.el

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