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