elmo/elmo-imap4.el

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