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