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