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