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