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