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