code.delx.au - gnu-emacs/blob - lisp/net/tramp-imap.el

   1 ;;; tramp-imap.el --- Tramp interface to IMAP through imap.el
   2
   3 ;; Copyright (C) 2009-2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Teodor Zlatanov <tzz@lifelogs.com>
   6 ;; Keywords: mail, comm
   7 ;; Package: tramp
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; Package to provide Tramp over IMAP
  27
  28 ;;; Setup:
  29
  30 ;; just load and open files, e.g.
  31 ;; /imaps:user@yourhosthere.com:/INBOX.test/1
  32 ;; or
  33 ;; /imap:user@yourhosthere.com:/INBOX.test/1
  34
  35 ;; where `imap' goes over IMAP, while `imaps' goes over IMAP+SSL
  36
  37 ;; This module will use imap-hash.el to access the IMAP mailbox.
  38
  39 ;; This module will use auth-source.el to authenticate against the
  40 ;; IMAP server, PLUS it will use auth-source.el to get your passphrase
  41 ;; for the symmetrically encrypted messages.  For the former, use the
  42 ;; usual IMAP ports.  For the latter, use the port "tramp-imap".
  43
  44 ;; example .authinfo / .netrc file:
  45
  46 ;; machine yourhosthere.com port tramp-imap login USER password SYMMETRIC-PASSPHRASE
  47
  48 ;; note above is the symmetric encryption passphrase for GPG
  49 ;; below is the regular password for IMAP itself and other things on that host
  50
  51 ;; machine yourhosthere.com login USER password NORMAL-PASSWORD
  52
  53
  54 ;;; Code:
  55
  56 (require 'assoc)
  57 (require 'tramp)
  58
  59 (autoload 'auth-source-user-or-password "auth-source")
  60 (autoload 'epg-context-operation "epg")
  61 (autoload 'epg-context-set-armor "epg")
  62 (autoload 'epg-context-set-passphrase-callback "epg")
  63 (autoload 'epg-context-set-progress-callback "epg")
  64 (autoload 'epg-decrypt-string "epg")
  65 (autoload 'epg-encrypt-string "epg")
  66 (autoload 'epg-make-context "epg")
  67 (autoload 'imap-hash-get "imap-hash")
  68 (autoload 'imap-hash-make "imap-hash")
  69 (autoload 'imap-hash-map "imap-hash")
  70 (autoload 'imap-hash-put "imap-hash")
  71 (autoload 'imap-hash-rem "imap-hash")
  72
  73 ;; We use the additional header "X-Size" for encoding the size of a file.
  74 (eval-after-load "imap-hash"
  75   '(add-to-list 'imap-hash-headers 'X-Size 'append))
  76
  77 ;; Define Tramp IMAP method ...
  78 ;;;###tramp-autoload
  79 (defconst tramp-imap-method "imap"
  80   "*Method to connect via IMAP protocol.")
  81
  82 ;;;###tramp-autoload
  83 (when (and (locate-library "epa") (locate-library "imap-hash"))
  84   (add-to-list 'tramp-methods
  85                (list tramp-imap-method '(tramp-default-port 143))))
  86
  87 ;; Define Tramp IMAPS method ...
  88 ;;;###tramp-autoload
  89 (defconst tramp-imaps-method "imaps"
  90   "*Method to connect via secure IMAP protocol.")
  91
  92 ;; ... and add it to the method list.
  93 ;;;###tramp-autoload
  94 (when (and (locate-library "epa") (locate-library "imap-hash"))
  95   (add-to-list 'tramp-methods
  96                (list tramp-imaps-method '(tramp-default-port 993))))
  97
  98 ;; Add a default for `tramp-default-user-alist'.  Default is the local user.
  99 ;;;###tramp-autoload
 100 (add-to-list
 101  'tramp-default-user-alist
 102  (list (concat "\\`"
 103                (regexp-opt (list tramp-imap-method tramp-imaps-method))
 104                "\\'")
 105        nil (user-login-name)))
 106
 107 ;; Add completion function for IMAP method.
 108 ;; (tramp-set-completion-function
 109 ;;  tramp-imap-method tramp-completion-function-alist-ssh) ; TODO: test this
 110 ;;  tramp-imaps-method tramp-completion-function-alist-ssh) ; TODO: test this
 111
 112 ;; New handlers should be added here.
 113 (defconst tramp-imap-file-name-handler-alist
 114   '(
 115     ;; `access-file' performed by default handler
 116     (add-name-to-file . ignore)
 117     ;; `byte-compiler-base-file-name' performed by default handler
 118     ;; `copy-directory' performed by default handler
 119     (copy-file . tramp-imap-handle-copy-file)
 120     (delete-directory . ignore) ;; tramp-imap-handle-delete-directory)
 121     (delete-file . tramp-imap-handle-delete-file)
 122     ;; `diff-latest-backup-file' performed by default handler
 123     (directory-file-name . tramp-handle-directory-file-name)
 124     (directory-files . tramp-handle-directory-files)
 125     (directory-files-and-attributes
 126      . tramp-handle-directory-files-and-attributes)
 127     (dired-call-process . ignore)
 128     ;; `dired-compress-file' performed by default handler
 129     ;; `dired-uncache' performed by default handler
 130     (expand-file-name . tramp-imap-handle-expand-file-name)
 131     ;; `file-accessible-directory-p' performed by default handler
 132     (file-attributes . tramp-imap-handle-file-attributes)
 133     (file-directory-p .  tramp-imap-handle-file-directory-p)
 134     (file-executable-p . ignore)
 135     (file-exists-p . tramp-handle-file-exists-p)
 136     (file-local-copy . tramp-imap-handle-file-local-copy)
 137     (file-modes . tramp-handle-file-modes)
 138     (file-name-all-completions . tramp-imap-handle-file-name-all-completions)
 139     (file-name-as-directory . tramp-handle-file-name-as-directory)
 140     (file-name-completion . tramp-handle-file-name-completion)
 141     (file-name-directory . tramp-handle-file-name-directory)
 142     (file-name-nondirectory . tramp-handle-file-name-nondirectory)
 143     ;; `file-name-sans-versions' performed by default handler
 144     (file-newer-than-file-p . tramp-handle-file-newer-than-file-p)
 145     (file-ownership-preserved-p . ignore)
 146     (file-readable-p . tramp-handle-file-exists-p)
 147     (file-regular-p . tramp-handle-file-regular-p)
 148     (file-remote-p . tramp-handle-file-remote-p)
 149     ;; `file-selinux-context' performed by default handler.
 150     (file-symlink-p . tramp-handle-file-symlink-p)
 151     ;; `file-truename' performed by default handler
 152     (file-writable-p . tramp-imap-handle-file-writable-p)
 153     (find-backup-file-name . tramp-handle-find-backup-file-name)
 154     ;; `find-file-noselect' performed by default handler
 155     ;; `get-file-buffer' performed by default handler
 156     (insert-directory . tramp-imap-handle-insert-directory)
 157     (insert-file-contents . tramp-imap-handle-insert-file-contents)
 158     (load . tramp-handle-load)
 159     (make-directory . ignore) ;; tramp-imap-handle-make-directory)
 160     (make-directory-internal . ignore) ;; tramp-imap-handle-make-directory-internal)
 161     (make-symbolic-link . ignore)
 162     (rename-file . tramp-imap-handle-rename-file)
 163     (set-file-modes . ignore)
 164     ;; `set-file-selinux-context' performed by default handler.
 165     (set-file-times . ignore) ;; tramp-imap-handle-set-file-times)
 166     (set-visited-file-modtime . ignore)
 167     (shell-command . ignore)
 168     (substitute-in-file-name . tramp-handle-substitute-in-file-name)
 169     (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
 170     (vc-registered . ignore)
 171     (verify-visited-file-modtime . ignore)
 172     (write-region . tramp-imap-handle-write-region)
 173     (executable-find . ignore)
 174     (start-file-process . ignore)
 175     (process-file . ignore)
 176 )
 177   "Alist of handler functions for Tramp IMAP method.
 178 Operations not mentioned here will be handled by the default Emacs primitives.")
 179
 180 (defgroup tramp-imap nil
 181   "Tramp over IMAP configuration."
 182   :version "23.2"
 183   :group 'tramp)
 184
 185 (defcustom tramp-imap-subject-marker "tramp-imap-subject-marker"
 186   "The subject marker that Tramp-IMAP will use."
 187   :type 'string
 188   :version "23.2"
 189   :group 'tramp-imap)
 190
 191 ;; TODO: these will be defcustoms later.
 192 (defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never
 193 (defvar tramp-imap-passphrase nil)
 194
 195 ;;;###tramp-autoload
 196 (defsubst tramp-imap-file-name-p (filename)
 197   "Check if it's a filename for IMAP protocol."
 198   (let ((v (tramp-dissect-file-name filename)))
 199     (or
 200      (string= (tramp-file-name-method v) tramp-imap-method)
 201      (string= (tramp-file-name-method v) tramp-imaps-method))))
 202
 203 ;;;###tramp-autoload
 204 (defun tramp-imap-file-name-handler (operation &rest args)
 205   "Invoke the IMAP related OPERATION.
 206 First arg specifies the OPERATION, second arg is a list of arguments to
 207 pass to the OPERATION."
 208   (let ((fn (assoc operation tramp-imap-file-name-handler-alist)))
 209     (if fn
 210         (save-match-data (apply (cdr fn) args))
 211       (tramp-run-real-handler operation args))))
 212
 213 ;;;###tramp-autoload
 214 (when (and (locate-library "epa") (locate-library "imap-hash"))
 215   (add-to-list 'tramp-foreign-file-name-handler-alist
 216                (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler)))
 217
 218 (defun tramp-imap-handle-copy-file
 219   (filename newname &optional ok-if-already-exists keep-date
 220             preserve-uid-gid preserve-selinux-context)
 221   "Like `copy-file' for Tramp files."
 222   (tramp-imap-do-copy-or-rename-file
 223    'copy filename newname ok-if-already-exists keep-date preserve-uid-gid))
 224
 225 (defun tramp-imap-handle-rename-file
 226   (filename newname &optional ok-if-already-exists)
 227   "Like `rename-file' for Tramp files."
 228   (tramp-imap-do-copy-or-rename-file
 229    'rename filename newname ok-if-already-exists t t))
 230
 231 (defun tramp-imap-do-copy-or-rename-file
 232   (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
 233   "Copy or rename a remote file.
 234 OP must be `copy' or `rename' and indicates the operation to perform.
 235 FILENAME specifies the file to copy or rename, NEWNAME is the name of
 236 the new file (for copy) or the new name of the file (for rename).
 237 OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already.
 238 KEEP-DATE means to make sure that NEWNAME has the same timestamp
 239 as FILENAME.  PRESERVE-UID-GID, when non-nil, instructs to keep
 240 the uid and gid if both files are on the same host.
 241
 242 This function is invoked by `tramp-imap-handle-copy-file' and
 243 `tramp-imap-handle-rename-file'.  It is an error if OP is neither
 244 of `copy' and `rename'."
 245   (unless (memq op '(copy rename))
 246     (error "Unknown operation `%s', must be `copy' or `rename'" op))
 247   (setq filename (expand-file-name filename))
 248   (setq newname (expand-file-name newname))
 249   (when (file-directory-p newname)
 250     (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
 251
 252   (let ((t1 (and (tramp-tramp-file-p filename)
 253                  (tramp-imap-file-name-p filename)))
 254         (t2 (and (tramp-tramp-file-p newname)
 255                  (tramp-imap-file-name-p newname))))
 256
 257     (with-parsed-tramp-file-name (if t1 filename newname) nil
 258       (when (and (not ok-if-already-exists) (file-exists-p newname))
 259         (tramp-error
 260          v 'file-already-exists "File %s already exists" newname))
 261
 262       (with-progress-reporter
 263           v 0 (format "%s %s to %s"
 264                       (if (eq op 'copy) "Copying" "Renaming")
 265                       filename newname)
 266
 267         ;; We just make a local copy of FILENAME, and write it then to
 268         ;; NEWNAME.  This must be optimized, when both files are
 269         ;; located on the same IMAP server.
 270         (with-temp-buffer
 271           (if (and t1 t2)
 272               ;; We don't encrypt.
 273               (with-parsed-tramp-file-name newname v1
 274                 (insert (tramp-imap-get-file filename nil))
 275                 (tramp-imap-put-file
 276                  v1 (current-buffer)
 277                  (tramp-imap-file-name-name v1)
 278                  nil nil (nth 7 (file-attributes filename))))
 279             ;; One of them is not located on a IMAP mailbox.
 280             (insert-file-contents filename)
 281             (write-region (point-min) (point-max) newname)))))
 282
 283     (when (eq op 'rename) (delete-file filename))))
 284
 285 ;; TODO: revise this much
 286 (defun tramp-imap-handle-expand-file-name (name &optional dir)
 287   "Like `expand-file-name' for Tramp files."
 288   ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
 289   (setq dir (or dir default-directory "/"))
 290   ;; Unless NAME is absolute, concat DIR and NAME.
 291   (unless (file-name-absolute-p name)
 292     (setq name (concat (file-name-as-directory dir) name)))
 293   ;; If NAME is not a Tramp file, run the real handler.
 294   (if (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name)))
 295       (tramp-drop-volume-letter
 296        (tramp-run-real-handler 'expand-file-name (list name nil)))
 297     ;; Dissect NAME.
 298     (with-parsed-tramp-file-name name nil
 299       (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
 300         (setq localname (concat "/" localname)))
 301       ;; There might be a double slash, for example when "~/"
 302       ;; expands to "/".  Remove this.
 303       (while (string-match "//" localname)
 304         (setq localname (replace-match "/" t t localname)))
 305       ;; Do normal `expand-file-name' (this does "/./" and "/../").
 306       ;; We bind `directory-sep-char' here for XEmacs on Windows,
 307       ;; which would otherwise use backslash.  `default-directory' is
 308       ;; bound, because on Windows there would be problems with UNC
 309       ;; shares or Cygwin mounts.
 310       (let ((default-directory (tramp-compat-temporary-file-directory)))
 311         (tramp-make-tramp-file-name
 312          method user host
 313          (tramp-drop-volume-letter
 314           (tramp-run-real-handler
 315            'expand-file-name (list localname))))))))
 316
 317 ;; This function should return "foo/" for directories and "bar" for
 318 ;; files.
 319 (defun tramp-imap-handle-file-name-all-completions (filename directory)
 320   "Like `file-name-all-completions' for Tramp files."
 321   (all-completions
 322    filename
 323    (with-parsed-tramp-file-name (expand-file-name directory) nil
 324      (save-match-data
 325        (let ((entries
 326               (tramp-imap-get-file-entries v localname)))
 327          (mapcar
 328           (lambda (x)
 329             (list
 330              (if (string-match "d" (nth 9 x))
 331                  (file-name-as-directory (nth 0 x))
 332                (nth 0 x))))
 333           entries))))))
 334
 335 (defun tramp-imap-get-file-entries (vec localname &optional exact)
 336   "Read entries returned by IMAP server. EXACT limits to exact matches.
 337 Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME
 338 SIZE MODE WEIRD INODE DEVICE)."
 339   (tramp-message vec 5 "working on %s" localname)
 340   (let* ((name (tramp-imap-file-name-name vec))
 341          (search-name (or name ""))
 342          (search-name (if exact (concat search-name "$") search-name))
 343          (iht (tramp-imap-make-iht vec search-name)))
 344 ;; TODO: catch errors
 345     ;; (tramp-error vec 'none "bad name %s or mailbox %s" name mbox))
 346     (imap-hash-map (lambda (uid headers body)
 347                      (let ((subject (substring
 348                                      (aget headers 'Subject "")
 349                                      (length tramp-imap-subject-marker)))
 350                            (from (aget headers 'From ""))
 351                            (date (date-to-time (aget headers 'Date "")))
 352                            (size (string-to-number
 353                                   (or (aget headers 'X-Size "0") "0"))))
 354                        (setq from
 355                              (if (string-match "<\\([^@]+\\)@" from)
 356                                  (match-string 1 from)
 357                                "nobody"))
 358                        (list
 359                         subject
 360                         nil
 361                         -1
 362                         from
 363                         "nogroup"
 364                         date
 365                         date
 366                         date
 367                         size
 368                         "-rw-rw-rw-"
 369                         nil
 370                         uid
 371                         (tramp-get-device vec))))
 372                    iht t)))
 373
 374 (defun tramp-imap-handle-write-region (start end filename &optional append visit lockname confirm)
 375   "Like `write-region' for Tramp files."
 376   (setq filename (expand-file-name filename))
 377   (with-parsed-tramp-file-name filename nil
 378     ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
 379     (when (and (not (featurep 'xemacs))
 380                confirm (file-exists-p filename))
 381       (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
 382                                 filename))
 383         (tramp-error v 'file-error "File not overwritten")))
 384     (tramp-flush-file-property v localname)
 385     (let* ((old-buffer (current-buffer))
 386            (inode (tramp-imap-get-file-inode filename))
 387            (min 1)
 388            (max (point-max))
 389            ;; Make sure we have good start and end values.
 390            (start (or start min))
 391            (end (or end max))
 392            temp-buffer)
 393       (with-temp-buffer
 394         (setq temp-buffer (if (and (eq start min) (eq end max))
 395                               old-buffer
 396                             ;; If this is a region write, insert the substring.
 397                             (insert
 398                              (with-current-buffer old-buffer
 399                                (buffer-substring-no-properties start end)))
 400                             (current-buffer)))
 401         (tramp-imap-put-file v
 402                              temp-buffer
 403                              (tramp-imap-file-name-name v)
 404                              inode
 405                              t)))
 406     (when (eq visit t)
 407       (set-visited-file-modtime))))
 408
 409 (defun tramp-imap-handle-insert-directory
 410   (filename switches &optional wildcard full-directory-p)
 411   "Like `insert-directory' for Tramp files."
 412   (setq filename (expand-file-name filename))
 413   (if full-directory-p
 414       ;; Called from `dired-add-entry'.
 415       (setq filename (file-name-as-directory filename))
 416     (setq filename (directory-file-name filename)))
 417   (with-parsed-tramp-file-name filename nil
 418     (save-match-data
 419       (let ((base (file-name-nondirectory localname))
 420             (entries (copy-sequence
 421                       (tramp-imap-get-file-entries
 422                        v (file-name-directory localname)))))
 423
 424         (when wildcard
 425           (when (string-match "\\." base)
 426             (setq base (replace-match "\\\\." nil nil base)))
 427           (when (string-match "\\*" base)
 428             (setq base (replace-match ".*" nil nil base)))
 429           (when (string-match "\\?" base)
 430             (setq base (replace-match ".?" nil nil base))))
 431
 432         ;; Filter entries.
 433         (setq entries
 434               (delq
 435                nil
 436                (if (or wildcard (zerop (length base)))
 437                    ;; Check for matching entries.
 438                    (mapcar
 439                     (lambda (x)
 440                       (when (string-match
 441                              (format "^%s" base) (nth 0 x))
 442                         x))
 443                     entries)
 444                  ;; We just need the only and only entry FILENAME.
 445                  (list (assoc base entries)))))
 446
 447         ;; Sort entries.
 448         (setq entries
 449               (sort
 450                entries
 451                (lambda (x y)
 452                  (if (string-match "t" switches)
 453                      ;; Sort by date.
 454                      (tramp-time-less-p (nth 6 y) (nth 6 x))
 455                    ;; Sort by name.
 456                    (string-lessp (nth 0 x) (nth 0 y))))))
 457
 458         ;; Handle "-F" switch.
 459         (when (string-match "F" switches)
 460           (mapc
 461            (lambda (x)
 462              (when (not (zerop (length (car x))))
 463                (cond
 464                 ((char-equal ?d (string-to-char (nth 9 x)))
 465                  (setcar x (concat (car x) "/")))
 466                 ((char-equal ?x (string-to-char (nth 9 x)))
 467                  (setcar x (concat (car x) "*"))))))
 468            entries))
 469
 470         ;; Print entries.
 471         (mapcar
 472          (lambda (x)
 473            (when (not (zerop (length (nth 0 x))))
 474              (insert
 475               (format
 476                "%10s %3d %-8s %-8s %8s %s "
 477                (nth 9 x) ; mode
 478                (nth 11 x) ; inode
 479                (nth 3 x) ; uid
 480                (nth 4 x) ; gid
 481                (nth 8 x) ; size
 482                (format-time-string
 483                 (if (tramp-time-less-p
 484                      (tramp-time-subtract (current-time) (nth 6 x))
 485                      tramp-half-a-year)
 486                     "%b %e %R"
 487                   "%b %e  %Y")
 488                 (nth 6 x)))) ; date
 489              ;; For the file name, we set the `dired-filename'
 490              ;; property.  This allows to handle file names with
 491              ;; leading or trailing spaces as well.  The inserted name
 492              ;; could be from somewhere else, so we use the relative
 493              ;; file name of `default-directory'.
 494              (let ((pos (point)))
 495                (insert
 496                 (format
 497                  "%s\n"
 498                  (file-relative-name
 499                   (expand-file-name (nth 0 x) (file-name-directory filename)))))
 500                (put-text-property pos (1- (point)) 'dired-filename t))
 501              (forward-line)
 502              (beginning-of-line)))
 503          entries)))))
 504
 505 (defun tramp-imap-handle-insert-file-contents
 506   (filename &optional visit beg end replace)
 507   "Like `insert-file-contents' for Tramp files."
 508   (barf-if-buffer-read-only)
 509   (when visit
 510     (setq buffer-file-name (expand-file-name filename))
 511     (set-visited-file-modtime)
 512     (set-buffer-modified-p nil))
 513   (with-parsed-tramp-file-name filename nil
 514     (if (not (file-exists-p filename))
 515         (tramp-error
 516          v 'file-error "File `%s' not found on remote host" filename)
 517       (let ((point (point))
 518             size data)
 519         (with-progress-reporter v 3 (format "Fetching file %s" filename)
 520           (insert (tramp-imap-get-file filename t))
 521           (setq size (- (point) point))
 522 ;;; TODO: handle ranges.
 523 ;;;            (let ((beg (or beg (point-min)))
 524 ;;;                (end (min (or end (point-max)) (point-max))))
 525 ;;;              (setq size (- end beg))
 526 ;;;            (buffer-substring beg end))
 527           (goto-char point)
 528           (list (expand-file-name filename) size))))))
 529
 530 (defun tramp-imap-handle-file-directory-p (filename)
 531   "Like `file-directory-p' for Tramp-IMAP files."
 532   ;; We allow only mailboxes to be a directory.
 533   (with-parsed-tramp-file-name (expand-file-name filename default-directory) nil
 534     (and (string-match "^/[^/]*$" (directory-file-name localname)) t)))
 535
 536 (defun tramp-imap-handle-file-attributes (filename &optional id-format)
 537   "Like `file-attributes' for Tramp-IMAP FILENAME."
 538   (with-parsed-tramp-file-name (expand-file-name filename) nil
 539     (let ((res (cdr-safe (nth 0 (tramp-imap-get-file-entries v localname)))))
 540       (unless (or (null res) (eq id-format 'string))
 541         (setcar (nthcdr 2 res) 1)
 542         (setcar (nthcdr 3 res) 1))
 543       res)))
 544
 545 (defun tramp-imap-get-file-inode (filename &optional id-format)
 546   "Get inode equivalent \(actually the UID) for Tramp-IMAP FILENAME."
 547   (nth 10 (tramp-compat-file-attributes filename id-format)))
 548
 549 (defun tramp-imap-handle-file-writable-p (filename)
 550   "Like `file-writable-p' for Tramp files.  True for IMAP."
 551   ;; `file-exists-p' does not work yet for directories.
 552   ;; (file-exists-p (file-name-directory filename)))
 553   (file-directory-p (file-name-directory filename)))
 554
 555 (defun tramp-imap-handle-delete-file (filename &optional trash)
 556   "Like `delete-file' for Tramp files."
 557   (cond
 558    ((not (file-exists-p filename)) nil)
 559    (t (with-parsed-tramp-file-name (expand-file-name filename) nil
 560         (let ((iht (tramp-imap-make-iht v)))
 561           (imap-hash-rem (tramp-imap-get-file-inode filename) iht))))))
 562
 563 (defun tramp-imap-handle-file-local-copy (filename)
 564   "Like `file-local-copy' for Tramp files."
 565   (with-parsed-tramp-file-name (expand-file-name filename) nil
 566     (unless (file-exists-p filename)
 567       (tramp-error
 568        v 'file-error
 569        "Cannot make local copy of non-existing file `%s'" filename))
 570     (let ((tmpfile (tramp-compat-make-temp-file filename)))
 571       (with-progress-reporter
 572           v 3 (format "Fetching %s to tmp file %s" filename tmpfile)
 573         (with-temp-buffer
 574           (insert-file-contents filename)
 575           (write-region (point-min) (point-max) tmpfile)
 576           tmpfile)))))
 577
 578 (defun tramp-imap-put-file
 579   (vec filename-or-buffer &optional subject inode encode size)
 580   "Write contents of FILENAME-OR-BUFFER to Tramp-IMAP file VEC with name SUBJECT.
 581 When INODE is given, delete that old remote file after writing the new one
 582 \(normally this is the old file with the same name).  A non-nil ENCODE
 583 forces the encoding of the buffer or file.  SIZE, when available, indicates
 584 the file size; this is needed, if the file or buffer is already encoded."
 585   ;; `tramp-current-host' is used in `tramp-imap-passphrase-callback-function'.
 586   (let ((tramp-current-host (tramp-file-name-real-host vec))
 587         (iht (tramp-imap-make-iht vec)))
 588     (imap-hash-put (list
 589                     (list (cons
 590                            'Subject
 591                            (format
 592                             "%s%s"
 593                             tramp-imap-subject-marker
 594                             (or subject "no subject")))
 595                           (cons
 596                            'X-Size
 597                            (number-to-string
 598                             (cond
 599                              ((numberp size) size)
 600                              ((bufferp filename-or-buffer)
 601                               (buffer-size filename-or-buffer))
 602                              ((stringp filename-or-buffer)
 603                               (nth 7 (file-attributes filename-or-buffer)))
 604                              ;; We don't know the size.
 605                              (t -1)))))
 606                     (cond ((bufferp filename-or-buffer)
 607                            (with-current-buffer filename-or-buffer
 608                              (if encode
 609                                  (tramp-imap-encode-buffer)
 610                                (buffer-string))))
 611                           ;; TODO: allow file names.
 612                           (t "No body available")))
 613                    iht
 614                    inode)))
 615
 616 (defun tramp-imap-get-file (filename &optional decode)
 617   ;; (debug (tramp-imap-get-file-inode filename))
 618   (with-parsed-tramp-file-name (expand-file-name filename) nil
 619     (condition-case ()
 620         ;; `tramp-current-host' is used in
 621         ;; `tramp-imap-passphrase-callback-function'.
 622         (let* ((tramp-current-host (tramp-file-name-real-host v))
 623                (iht (tramp-imap-make-iht v))
 624                (inode (tramp-imap-get-file-inode filename))
 625                (data (imap-hash-get inode iht t)))
 626           (if decode
 627               (with-temp-buffer
 628                 (insert (nth 1 data))
 629                 ;;(debug inode (buffer-string))
 630                 (tramp-imap-decode-buffer))
 631             (nth 1 data)))
 632       (error (tramp-error
 633               v 'file-error "File `%s' could not be read" filename)))))
 634
 635 (defun tramp-imap-passphrase-callback-function (context key-id handback)
 636   "Called by EPG to get a passphrase for Tramp-IMAP.
 637 CONTEXT is the encryption/decryption EPG context.
 638 HANDBACK is just carried through.
 639 KEY-ID can be 'SYM or 'PIN among others."
 640   (let* ((server tramp-current-host)
 641          (port "tramp-imap")            ; this is NOT the server password!
 642          (auth-passwd
 643           (auth-source-user-or-password "password" server port)))
 644     (or
 645      (copy-sequence auth-passwd)
 646      ;; If we cache the passphrase and we have one.
 647      (if (and (eq tramp-imap-passphrase-cache t)
 648               tramp-imap-passphrase)
 649          ;; Do we reuse it?
 650          (if (y-or-n-p "Reuse the passphrase? ")
 651              (copy-sequence tramp-imap-passphrase)
 652            ;; Don't reuse: revert caching behavior to nil, erase passphrase,
 653            ;; call ourselves again.
 654            (setq tramp-imap-passphrase-cache nil)
 655            (setq tramp-imap-passphrase nil)
 656            (tramp-imap-passphrase-callback-function context key-id handback))
 657        (let ((p (if (eq key-id 'SYM)
 658                     (read-passwd
 659                      "Tramp-IMAP passphrase for symmetric encryption: "
 660                      (eq (epg-context-operation context) 'encrypt)
 661                      tramp-imap-passphrase)
 662                   (read-passwd
 663                    (if (eq key-id 'PIN)
 664                        "Tramp-IMAP passphrase for PIN: "
 665                      (let ((entry (assoc key-id
 666                                          (symbol-value 'epg-user-id-alist))))
 667                        (if entry
 668                            (format "Tramp-IMAP passphrase for %s %s: "
 669                                    key-id (cdr entry))
 670                          (format "Tramp-IMAP passphrase for %s: " key-id))))
 671                    nil
 672                    tramp-imap-passphrase))))
 673
 674          ;; If we have an answer, the passphrase has changed,
 675          ;; the user hasn't declined keeping the passphrase,
 676          ;; and they answer yes to keep it now...
 677          (when (and
 678                 p
 679                 (not (equal tramp-imap-passphrase p))
 680                 (not (eq tramp-imap-passphrase-cache 'never))
 681                 (y-or-n-p "Keep the passphrase? "))
 682            (setq tramp-imap-passphrase (copy-sequence p))
 683            (setq tramp-imap-passphrase-cache t))
 684
 685          ;; If we still don't have a passphrase, the user didn't want
 686          ;; to keep it.
 687          (when (and
 688                 p
 689                 (not tramp-imap-passphrase))
 690            (setq tramp-imap-passphrase-cache 'never))
 691
 692          p)))))
 693
 694 (defun tramp-imap-encode-buffer ()
 695   (let ((context (epg-make-context 'OpenPGP))
 696         cipher)
 697     (epg-context-set-armor context t)
 698     (epg-context-set-passphrase-callback context
 699                                          #'tramp-imap-passphrase-callback-function)
 700     (epg-context-set-progress-callback context
 701                                        (cons #'epa-progress-callback-function
 702                                              "Encrypting..."))
 703     (message "Encrypting...")
 704     (setq cipher (epg-encrypt-string
 705                   context
 706                   (encode-coding-string (buffer-string) 'utf-8)
 707                   nil))
 708     (message "Encrypting...done")
 709     cipher))
 710
 711 (defun tramp-imap-decode-buffer ()
 712   (let ((context (epg-make-context 'OpenPGP))
 713         plain)
 714     (epg-context-set-passphrase-callback context
 715                                          #'tramp-imap-passphrase-callback-function)
 716     (epg-context-set-progress-callback context
 717                                        (cons #'epa-progress-callback-function
 718                                              "Decrypting..."))
 719     (message "Decrypting...")
 720     (setq plain (decode-coding-string
 721                  (epg-decrypt-string context (buffer-string))
 722                  'utf-8))
 723     (message "Decrypting...done")
 724     plain))
 725
 726 (defun tramp-imap-file-name-mailbox (vec)
 727   (nth 0 (tramp-imap-file-name-parse vec)))
 728
 729 (defun tramp-imap-file-name-name (vec)
 730   (nth 1 (tramp-imap-file-name-parse vec)))
 731
 732 (defun tramp-imap-file-name-localname (vec)
 733   (nth 1 (tramp-imap-file-name-parse vec)))
 734
 735 (defun tramp-imap-file-name-parse (vec)
 736   (let ((name (substring-no-properties (tramp-file-name-localname vec))))
 737     (if (string-match "^/\\([^/]+\\)/?\\(.*\\)$" name)
 738         (list (match-string 1 name)
 739               (match-string 2 name))
 740       nil)))
 741
 742 (defun tramp-imap-make-iht (vec &optional needed-subject)
 743   "Translate the Tramp vector VEC to the imap-hash structure.
 744 With NEEDED-SUBJECT, alters the imap-hash test accordingly."
 745   (let* ((mbox (tramp-imap-file-name-mailbox vec))
 746          (server (tramp-file-name-real-host vec))
 747          (method (tramp-file-name-method vec))
 748          (user (tramp-file-name-user vec))
 749          (ssl (string-equal method tramp-imaps-method))
 750          (port (tramp-file-name-port vec))
 751          (result (imap-hash-make server port mbox user nil ssl)))
 752     ;; Return the IHT with a test override to look for the subject
 753     ;; marker.
 754     (plist-put
 755      result
 756      :test (format "^%s%s"
 757                    tramp-imap-subject-marker
 758                    (if needed-subject needed-subject "")))))
 759
 760 (add-hook 'tramp-unload-hook
 761           (lambda ()
 762               (unload-feature 'tramp-imap 'force)))
 763
 764 ;;; TODO:
 765
 766 ;; * Implement `tramp-imap-handle-delete-directory',
 767 ;;   `tramp-imap-handle-make-directory',
 768 ;;   `tramp-imap-handle-make-directory-internal',
 769 ;;   `tramp-imap-handle-set-file-times'.
 770
 771 ;; * Encode the subject.  If the filename has trailing spaces (like
 772 ;;   "test   "), those characters get lost, for example in dired listings.
 773
 774 ;; * When opening a dired buffer, like "/imap::INBOX.test", there are
 775 ;;   several error messages:
 776 ;;   "Buffer has a running process; kill it? (yes or no) "
 777 ;;   "error in process filter: Internal error, tag 6 status BAD code nil text No mailbox selected."
 778 ;;   Afterwards, everything seems to be fine.
 779
 780 ;; * imaps works for local IMAP servers.  Accessing
 781 ;;   "/imaps:imap.gmail.com:/INBOX.test/" results in error
 782 ;;   "error in process filter: Internal error, tag 5 status BAD code nil text UNSELECT not allowed now."
 783
 784 ;; * Improve `tramp-imap-handle-file-attributes' for directories.
 785
 786 ;; * Saving a file creates a second one, instead of overwriting.
 787
 788 ;; * Backup files: just *one* is kept.
 789
 790 ;; * Password requests shall have a descriptive prompt.
 791
 792 ;; * Exiting Emacs, there are running IMAP processes.  Make them quiet
 793 ;;   by `set-process-query-on-exit-flag'.
 794
 795 (provide 'tramp-imap)
 796 ;;; tramp-imap.el ends here
 797
 798 ;; Ignore, for testing only.
 799
 800 ;;; (setq tramp-imap-subject-marker "T")
 801 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") t)
 802 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/") t)
 803 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4") t)
 804 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/") t)
 805 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t)
 806 ;;; (tramp-imap-get-file-entries (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen") t t)
 807 ;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome")
 808 ;;; (dired-copy-file "/etc/fstab" "/imap:yourhosthere.com:/test/welcome" t)
 809 ;;; (write-region 1 100 "/imap:yourhosthere.com:/test/welcome")
 810 ;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t)
 811 ;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome"))
 812 ;;(with-temp-buffer (insert "hello") (write-file "/imap:yourhosthere.com:/test/welcome2"))
 813 ;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2")
 814 ;;(file-name-directory "/imap:yourhosthere.com:/test/welcome2")
 815 ;;(with-temp-buffer (insert "hello") (delete-file "/tmp/hellotest") (write-file "/tmp/hellotest") (write-file "/imap:yourhosthere.com:/test/welcome2"))
 816 ;;;(file-exists-p "/imap:yourhosthere.com:/INBOX.test/4")
 817 ;;;(file-attributes "/imap:yourhosthere.com:/INBOX.test/4")
 818 ;;;(setq vec (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4"))
 819 ;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/INBOX.test/4")
 820 ;;; (tramp-imap-handle-insert-file-contents "/imap:user@yourhosthere.com:/INBOX.test/4" nil nil nil nil)
 821 ;;;(insert-file-contents "/imap:yourhosthere.com:/INBOX.test/4")
 822 ;;;(file-attributes "/imap:yourhosthere.com:/test/welcommen")
 823 ;;;(insert-file-contents "/imap:yourhosthere.com:/test/welcome")
 824 ;;;(file-exists-p "/imap:yourhosthere.com:/test/welcome2")
 825 ;;;(tramp-imap-handle-file-attributes "/imap:yourhosthere.com:/test/welcome")
 826 ;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcommen")
 827 ;;;(tramp-imap-get-file-inode "/imap:yourhosthere.com:/test/welcome")
 828 ;;;(file-writable-p "/imap:yourhosthere.com:/test/welcome2")
 829 ;;; (delete-file "/imap:yourhosthere.com:/test/welcome")
 830 ;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcommen" t)
 831 ;;; (tramp-imap-get-file "/imap:yourhosthere.com:/test/welcome" t)
 832 ;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test"))
 833 ;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/old"))
 834 ;;;(tramp-imap-file-name-mailbox (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new"))
 835 ;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/two"))
 836 ;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/new/one"))
 837 ;;;(tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test"))
 838 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/4"))
 839 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/"))
 840 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
 841 ;;; (tramp-imap-file-name-parse (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
 842 ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen"))
 843 ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4"))
 844 ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") "extra")