lisp/net/tramp-smb.el

   1 ;;; tramp-smb.el --- Tramp access functions for SMB servers
   2
   3 ;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   4 ;;   2009 Free Software Foundation, Inc.
   5
   6 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   7 ;; Keywords: comm, processes
   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 ;; Access functions for SMB servers like SAMBA or M$ Windows from Tramp.
  27
  28 ;;; Code:
  29
  30 (eval-when-compile (require 'cl))       ; block, return
  31 (require 'tramp)
  32 (require 'tramp-cache)
  33 (require 'tramp-compat)
  34
  35 ;; Define SMB method ...
  36 (defcustom tramp-smb-method "smb"
  37   "*Method to connect SAMBA and M$ SMB servers."
  38   :group 'tramp
  39   :type 'string)
  40
  41 ;; ... and add it to the method list.
  42 (add-to-list 'tramp-methods (cons tramp-smb-method nil))
  43
  44 ;; Add a default for `tramp-default-method-alist'. Rule: If there is
  45 ;; a domain in USER, it must be the SMB method.
  46 (add-to-list 'tramp-default-method-alist
  47              `(nil ,tramp-prefix-domain-regexp ,tramp-smb-method))
  48
  49 ;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method,
  50 ;; the anonymous user is chosen.
  51 (add-to-list 'tramp-default-user-alist
  52              `(,tramp-smb-method nil ""))
  53
  54 ;; Add completion function for SMB method.
  55 (tramp-set-completion-function
  56  tramp-smb-method
  57  '((tramp-parse-netrc "~/.netrc")))
  58
  59 (defcustom tramp-smb-program "smbclient"
  60   "*Name of SMB client to run."
  61   :group 'tramp
  62   :type 'string)
  63
  64 (defconst tramp-smb-prompt "^smb: .+> \\|^\\s-+Server\\s-+Comment$"
  65   "Regexp used as prompt in smbclient.")
  66
  67 (defconst tramp-smb-errors
  68   ;; `regexp-opt' not possible because of first string.
  69   (mapconcat
  70    'identity
  71    '(;; Connection error / timeout
  72      "Connection to \\S-+ failed"
  73      "Read from server failed, maybe it closed the connection"
  74      "Call timed out: server did not respond"
  75      ;; Samba
  76      "ERRDOS"
  77      "ERRSRV"
  78      "ERRbadfile"
  79      "ERRbadpw"
  80      "ERRfilexists"
  81      "ERRnoaccess"
  82      "ERRnomem"
  83      "ERRnosuchshare"
  84      ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
  85      ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003)
  86      "NT_STATUS_ACCESS_DENIED"
  87      "NT_STATUS_ACCOUNT_LOCKED_OUT"
  88      "NT_STATUS_BAD_NETWORK_NAME"
  89      "NT_STATUS_CANNOT_DELETE"
  90      "NT_STATUS_DIRECTORY_NOT_EMPTY"
  91      "NT_STATUS_DUPLICATE_NAME"
  92      "NT_STATUS_FILE_IS_A_DIRECTORY"
  93      "NT_STATUS_LOGON_FAILURE"
  94      "NT_STATUS_NETWORK_ACCESS_DENIED"
  95      "NT_STATUS_NO_SUCH_FILE"
  96      "NT_STATUS_OBJECT_NAME_COLLISION"
  97      "NT_STATUS_OBJECT_NAME_INVALID"
  98      "NT_STATUS_OBJECT_NAME_NOT_FOUND"
  99      "NT_STATUS_SHARING_VIOLATION"
 100      "NT_STATUS_TRUSTED_RELATIONSHIP_FAILURE"
 101      "NT_STATUS_WRONG_PASSWORD")
 102    "\\|")
 103   "Regexp for possible error strings of SMB servers.
 104 Used instead of analyzing error codes of commands.")
 105
 106 (defconst tramp-smb-actions-with-share
 107   '((tramp-smb-prompt tramp-action-succeed)
 108     (tramp-password-prompt-regexp tramp-action-password)
 109     (tramp-wrong-passwd-regexp tramp-action-permission-denied)
 110     (tramp-smb-errors tramp-action-permission-denied)
 111     (tramp-process-alive-regexp tramp-action-process-alive))
 112   "List of pattern/action pairs.
 113 This list is used for login to SMB servers.
 114
 115 See `tramp-actions-before-shell' for more info.")
 116
 117 (defconst tramp-smb-actions-without-share
 118   '((tramp-password-prompt-regexp tramp-action-password)
 119     (tramp-wrong-passwd-regexp tramp-action-permission-denied)
 120     (tramp-smb-errors tramp-action-permission-denied)
 121     (tramp-process-alive-regexp tramp-action-out-of-band))
 122   "List of pattern/action pairs.
 123 This list is used for login to SMB servers.
 124
 125 See `tramp-actions-before-shell' for more info.")
 126
 127 ;; New handlers should be added here.
 128 (defconst tramp-smb-file-name-handler-alist
 129   '(
 130     ;; `access-file' performed by default handler
 131     (add-name-to-file . tramp-smb-handle-copy-file) ;; we're on Windows, honey.
 132     ;; `byte-compiler-base-file-name' performed by default handler
 133     (copy-file . tramp-smb-handle-copy-file)
 134     (delete-directory . tramp-smb-handle-delete-directory)
 135     (delete-file . tramp-smb-handle-delete-file)
 136     ;; `diff-latest-backup-file' performed by default handler
 137     (directory-file-name . tramp-handle-directory-file-name)
 138     (directory-files . tramp-smb-handle-directory-files)
 139     (directory-files-and-attributes . tramp-smb-handle-directory-files-and-attributes)
 140     (dired-call-process . ignore)
 141     (dired-compress-file . ignore)
 142     ;; `dired-uncache' performed by default handler
 143     ;; `expand-file-name' not necessary because we cannot expand "~/"
 144     (file-accessible-directory-p . tramp-smb-handle-file-directory-p)
 145     (file-attributes . tramp-smb-handle-file-attributes)
 146     (file-directory-p .  tramp-smb-handle-file-directory-p)
 147     (file-executable-p . tramp-smb-handle-file-exists-p)
 148     (file-exists-p . tramp-smb-handle-file-exists-p)
 149     (file-local-copy . tramp-smb-handle-file-local-copy)
 150     (file-remote-p . tramp-handle-file-remote-p)
 151     (file-modes . tramp-handle-file-modes)
 152     (file-name-all-completions . tramp-smb-handle-file-name-all-completions)
 153     (file-name-as-directory . tramp-handle-file-name-as-directory)
 154     (file-name-completion . tramp-handle-file-name-completion)
 155     (file-name-directory . tramp-handle-file-name-directory)
 156     (file-name-nondirectory . tramp-handle-file-name-nondirectory)
 157     ;; `file-name-sans-versions' performed by default handler
 158     (file-newer-than-file-p . tramp-smb-handle-file-newer-than-file-p)
 159     (file-ownership-preserved-p . ignore)
 160     (file-readable-p . tramp-smb-handle-file-exists-p)
 161     (file-regular-p . tramp-handle-file-regular-p)
 162     (file-symlink-p . tramp-handle-file-symlink-p)
 163     ;; `file-truename' performed by default handler
 164     (file-writable-p . tramp-smb-handle-file-writable-p)
 165     (find-backup-file-name . tramp-handle-find-backup-file-name)
 166     ;; `find-file-noselect' performed by default handler
 167     ;; `get-file-buffer' performed by default handler
 168     (insert-directory . tramp-smb-handle-insert-directory)
 169     (insert-file-contents . tramp-handle-insert-file-contents)
 170     (load . tramp-handle-load)
 171     (make-directory . tramp-smb-handle-make-directory)
 172     (make-directory-internal . tramp-smb-handle-make-directory-internal)
 173     (make-symbolic-link . ignore)
 174     (rename-file . tramp-smb-handle-rename-file)
 175     (set-file-modes . ignore)
 176     (set-visited-file-modtime . ignore)
 177     (shell-command . ignore)
 178     (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name)
 179     (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory)
 180     (vc-registered . ignore)
 181     (verify-visited-file-modtime . ignore)
 182     (write-region . tramp-smb-handle-write-region)
 183 )
 184   "Alist of handler functions for Tramp SMB method.
 185 Operations not mentioned here will be handled by the default Emacs primitives.")
 186
 187 (defun tramp-smb-file-name-p (filename)
 188   "Check if it's a filename for SMB servers."
 189   (let ((v (tramp-dissect-file-name filename)))
 190     (string= (tramp-file-name-method v) tramp-smb-method)))
 191
 192 (defun tramp-smb-file-name-handler (operation &rest args)
 193   "Invoke the SMB related OPERATION.
 194 First arg specifies the OPERATION, second arg is a list of arguments to
 195 pass to the OPERATION."
 196   (let ((fn (assoc operation tramp-smb-file-name-handler-alist)))
 197     (if fn
 198         (save-match-data (apply (cdr fn) args))
 199       (tramp-run-real-handler operation args))))
 200
 201 (add-to-list 'tramp-foreign-file-name-handler-alist
 202              (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler))
 203
 204
 205 ;; File name primitives
 206
 207 (defun tramp-smb-handle-copy-file
 208   (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
 209   "Like `copy-file' for Tramp files.
 210 KEEP-DATE is not handled in case NEWNAME resides on an SMB server.
 211 PRESERVE-UID-GID is completely ignored."
 212   (setq filename (expand-file-name filename)
 213         newname (expand-file-name newname))
 214
 215   (let ((tmpfile (file-local-copy filename)))
 216
 217     (if tmpfile
 218         ;; Remote filename.
 219         (condition-case err
 220             (rename-file tmpfile newname ok-if-already-exists)
 221           ((error quit)
 222            (delete-file tmpfile)
 223            (signal (car err) (cdr err))))
 224
 225       ;; Remote newname.
 226       (when (file-directory-p newname)
 227         (setq newname (expand-file-name
 228                        (file-name-nondirectory filename) newname)))
 229
 230       (with-parsed-tramp-file-name newname nil
 231         (when (and (not ok-if-already-exists)
 232                    (file-exists-p newname))
 233           (tramp-error v 'file-already-exists newname))
 234
 235         ;; We must also flush the cache of the directory, because
 236         ;; file-attributes reads the values from there.
 237         (tramp-flush-file-property v (file-name-directory localname))
 238         (tramp-flush-file-property v localname)
 239         (let ((share (tramp-smb-get-share localname))
 240               (file (tramp-smb-get-localname localname t)))
 241           (unless share
 242             (tramp-error
 243              v 'file-error "Target `%s' must contain a share name" newname))
 244           (tramp-message v 0 "Copying file %s to file %s..." filename newname)
 245           (if (tramp-smb-send-command
 246                v (format "put %s \"%s\"" filename file))
 247               (tramp-message
 248                v 0 "Copying file %s to file %s...done" filename newname)
 249             (tramp-error v 'file-error "Cannot copy `%s'" filename)))))))
 250
 251 (defun tramp-smb-handle-delete-directory (directory)
 252   "Like `delete-directory' for Tramp files."
 253   (setq directory (directory-file-name (expand-file-name directory)))
 254   (when (file-exists-p directory)
 255     (with-parsed-tramp-file-name directory nil
 256       ;; We must also flush the cache of the directory, because
 257       ;; file-attributes reads the values from there.
 258       (tramp-flush-file-property v (file-name-directory localname))
 259       (tramp-flush-directory-property v localname)
 260       (let ((dir (tramp-smb-get-localname (file-name-directory localname) t))
 261             (file (file-name-nondirectory localname)))
 262         (unwind-protect
 263             (unless (and
 264                      (tramp-smb-send-command v (format "cd \"%s\"" dir))
 265                      (tramp-smb-send-command v (format "rmdir \"%s\"" file)))
 266               ;; Error
 267               (with-current-buffer (tramp-get-connection-buffer v)
 268                 (goto-char (point-min))
 269                 (search-forward-regexp tramp-smb-errors nil t)
 270                 (tramp-error
 271                  v 'file-error "%s `%s'" (match-string 0) directory)))
 272           ;; Always go home
 273           (tramp-smb-send-command v (format "cd \\")))))))
 274
 275 (defun tramp-smb-handle-delete-file (filename)
 276   "Like `delete-file' for Tramp files."
 277   (setq filename (expand-file-name filename))
 278   (when (file-exists-p filename)
 279     (with-parsed-tramp-file-name filename nil
 280       ;; We must also flush the cache of the directory, because
 281       ;; file-attributes reads the values from there.
 282       (tramp-flush-file-property v (file-name-directory localname))
 283       (tramp-flush-file-property v localname)
 284       (let ((dir (tramp-smb-get-localname (file-name-directory localname) t))
 285             (file (file-name-nondirectory localname)))
 286         (unwind-protect
 287             (unless (and
 288                      (tramp-smb-send-command v (format "cd \"%s\"" dir))
 289                      (tramp-smb-send-command v (format "rm \"%s\"" file)))
 290               ;; Error
 291               (with-current-buffer (tramp-get-connection-buffer v)
 292                 (goto-char (point-min))
 293                 (search-forward-regexp tramp-smb-errors nil t)
 294                 (tramp-error
 295                  v 'file-error "%s `%s'" (match-string 0) filename)))
 296           ;; Always go home
 297           (tramp-smb-send-command v (format "cd \\")))))))
 298
 299 (defun tramp-smb-handle-directory-files
 300   (directory &optional full match nosort)
 301   "Like `directory-files' for Tramp files."
 302   (let ((result (mapcar 'directory-file-name
 303                         (file-name-all-completions "" directory))))
 304     ;; Discriminate with regexp
 305     (when match
 306       (setq result
 307             (delete nil
 308                     (mapcar (lambda (x) (when (string-match match x) x))
 309                             result))))
 310     ;; Append directory
 311     (when full
 312       (setq result
 313             (mapcar
 314              (lambda (x) (expand-file-name x directory))
 315              result)))
 316     ;; Sort them if necessary
 317     (unless nosort (setq result (sort result 'string-lessp)))
 318     ;; That's it
 319     result))
 320
 321 (defun tramp-smb-handle-directory-files-and-attributes
 322   (directory &optional full match nosort id-format)
 323   "Like `directory-files-and-attributes' for Tramp files."
 324   (mapcar
 325    (lambda (x)
 326      ;; We cannot call `file-attributes' for backward compatibility reasons.
 327      ;; Its optional parameter ID-FORMAT is introduced with Emacs 22.
 328      (cons x (tramp-smb-handle-file-attributes
 329         (if full x (expand-file-name x directory)) id-format)))
 330    (directory-files directory full match nosort)))
 331
 332 (defun tramp-smb-handle-file-attributes (filename &optional id-format)
 333   "Like `file-attributes' for Tramp files."
 334   ;; Reading just the filename entry via "dir localname" is not
 335   ;; possible, because when filename is a directory, some smbclient
 336   ;; versions return the content of the directory, and other versions
 337   ;; don't.  Therefore, the whole content of the upper directory is
 338   ;; retrieved, and the entry of the filename is extracted from.
 339   (with-parsed-tramp-file-name filename nil
 340     (with-file-property v localname (format "file-attributes-%s" id-format)
 341       (let* ((entries (tramp-smb-get-file-entries
 342                        (file-name-directory filename)))
 343              (entry (and entries
 344                          (assoc (file-name-nondirectory filename) entries)))
 345              (uid (if (and id-format (equal id-format 'string)) "nobody" -1))
 346              (gid (if (and id-format (equal id-format 'string)) "nogroup" -1))
 347              (inode (tramp-get-inode v))
 348              (device (tramp-get-device v)))
 349
 350         ;; Check result.
 351         (when entry
 352           (list (and (string-match "d" (nth 1 entry))
 353                      t)       ;0 file type
 354                 -1            ;1 link count
 355                 uid           ;2 uid
 356                 gid           ;3 gid
 357                 '(0 0)        ;4 atime
 358                 (nth 3 entry) ;5 mtime
 359                 '(0 0)        ;6 ctime
 360                 (nth 2 entry) ;7 size
 361                 (nth 1 entry) ;8 mode
 362                 nil           ;9 gid weird
 363                 inode         ;10 inode number
 364                 device))))))  ;11 file system number
 365
 366 (defun tramp-smb-handle-file-directory-p (filename)
 367   "Like `file-directory-p' for Tramp files."
 368   (and (file-exists-p filename)
 369        (eq ?d (aref (nth 8 (file-attributes filename)) 0))))
 370
 371 (defun tramp-smb-handle-file-exists-p (filename)
 372   "Like `file-exists-p' for Tramp files."
 373   (not (null (file-attributes filename))))
 374
 375 (defun tramp-smb-handle-file-local-copy (filename)
 376   "Like `file-local-copy' for Tramp files."
 377   (with-parsed-tramp-file-name filename nil
 378     (let ((file (tramp-smb-get-localname localname t))
 379           (tmpfile (tramp-compat-make-temp-file filename)))
 380       (unless (file-exists-p filename)
 381         (tramp-error
 382          v 'file-error
 383          "Cannot make local copy of non-existing file `%s'" filename))
 384       (tramp-message v 4 "Fetching %s to tmp file %s..." filename tmpfile)
 385       (if (tramp-smb-send-command v (format "get \"%s\" %s" file tmpfile))
 386           (tramp-message
 387            v 4 "Fetching %s to tmp file %s...done" filename tmpfile)
 388         (tramp-error
 389          v 'file-error
 390          "Cannot make local copy of file `%s'" filename))
 391       tmpfile)))
 392
 393 ;; This function should return "foo/" for directories and "bar" for
 394 ;; files.
 395 (defun tramp-smb-handle-file-name-all-completions (filename directory)
 396   "Like `file-name-all-completions' for Tramp files."
 397   (all-completions
 398    filename
 399    (with-parsed-tramp-file-name directory nil
 400      (with-file-property v localname "file-name-all-completions"
 401        (save-match-data
 402          (let ((entries (tramp-smb-get-file-entries directory)))
 403            (mapcar
 404             (lambda (x)
 405               (list
 406                (if (string-match "d" (nth 1 x))
 407                    (file-name-as-directory (nth 0 x))
 408                  (nth 0 x))))
 409             entries)))))))
 410
 411 (defun tramp-smb-handle-file-newer-than-file-p (file1 file2)
 412   "Like `file-newer-than-file-p' for Tramp files."
 413   (cond
 414    ((not (file-exists-p file1)) nil)
 415    ((not (file-exists-p file2)) t)
 416    (t (tramp-time-less-p (nth 5 (file-attributes file2))
 417                          (nth 5 (file-attributes file1))))))
 418
 419 (defun tramp-smb-handle-file-writable-p (filename)
 420   "Like `file-writable-p' for Tramp files."
 421   (if (file-exists-p filename)
 422       (string-match "w" (or (nth 8 (file-attributes filename)) ""))
 423     (let ((dir (file-name-directory filename)))
 424       (and (file-exists-p dir)
 425            (file-writable-p dir)))))
 426
 427 (defun tramp-smb-handle-insert-directory
 428   (filename switches &optional wildcard full-directory-p)
 429   "Like `insert-directory' for Tramp files."
 430   (setq filename (expand-file-name filename))
 431   (when full-directory-p
 432     ;; Called from `dired-add-entry'.
 433     (setq filename (file-name-as-directory filename)))
 434   (with-parsed-tramp-file-name filename nil
 435     (tramp-flush-file-property v (file-name-directory localname))
 436     (save-match-data
 437       (let ((base (file-name-nondirectory filename))
 438             ;; We should not destroy the cache entry.
 439             (entries (copy-sequence
 440                       (tramp-smb-get-file-entries
 441                        (file-name-directory filename)))))
 442
 443         (when wildcard
 444           (string-match "\\." base)
 445           (setq base (replace-match "\\\\." nil nil base))
 446           (string-match "\\*" base)
 447           (setq base (replace-match ".*" nil nil base))
 448           (string-match "\\?" base)
 449           (setq base (replace-match ".?" nil nil base)))
 450
 451         ;; Filter entries.
 452         (setq entries
 453               (delq
 454                nil
 455                (if (or wildcard (zerop (length base)))
 456                    ;; Check for matching entries.
 457                    (mapcar
 458                     (lambda (x)
 459                       (when (string-match
 460                              (format "^%s" base) (nth 0 x))
 461                         x))
 462                     entries)
 463                  ;; We just need the only and only entry FILENAME.
 464                  (list (assoc base entries)))))
 465
 466         ;; Sort entries.
 467         (setq entries
 468               (sort
 469                entries
 470                (lambda (x y)
 471                  (if (string-match "t" switches)
 472                      ;; Sort by date.
 473                      (tramp-time-less-p (nth 3 y) (nth 3 x))
 474                    ;; Sort by name.
 475                    (string-lessp (nth 0 x) (nth 0 y))))))
 476
 477         ;; Handle "-F" switch.
 478         (when (string-match "F" switches)
 479           (mapc
 480            (lambda (x)
 481              (when (not (zerop (length (car x))))
 482                (cond
 483                 ((char-equal ?d (string-to-char (nth 1 x)))
 484                  (setcar x (concat (car x) "/")))
 485                 ((char-equal ?x (string-to-char (nth 1 x)))
 486                  (setcar x (concat (car x) "*"))))))
 487            entries))
 488
 489         ;; Print entries.
 490         (mapcar
 491          (lambda (x)
 492            (when (not (zerop (length (nth 0 x))))
 493              (insert
 494               (format
 495                "%10s %3d %-8s %-8s %8s %s %s\n"
 496                (nth 1 x) ; mode
 497                1 "nobody" "nogroup"
 498                (nth 2 x) ; size
 499                (format-time-string
 500                 (if (tramp-time-less-p
 501                      (tramp-time-subtract (current-time) (nth 3 x))
 502                      tramp-half-a-year)
 503                     "%b %e %R"
 504                   "%b %e  %Y")
 505                 (nth 3 x)) ; date
 506                (nth 0 x))) ; file name
 507              (forward-line)
 508              (beginning-of-line)))
 509            entries)))))
 510
 511 (defun tramp-smb-handle-make-directory (dir &optional parents)
 512   "Like `make-directory' for Tramp files."
 513   (setq dir (directory-file-name (expand-file-name dir)))
 514   (unless (file-name-absolute-p dir)
 515     (setq dir (expand-file-name dir default-directory)))
 516   (with-parsed-tramp-file-name dir nil
 517     (save-match-data
 518       (let* ((share (tramp-smb-get-share localname))
 519              (ldir (file-name-directory dir)))
 520         ;; Make missing directory parts
 521         (when (and parents share (not (file-directory-p ldir)))
 522           (make-directory ldir parents))
 523         ;; Just do it
 524         (when (file-directory-p ldir)
 525           (make-directory-internal dir))
 526         (unless (file-directory-p dir)
 527           (tramp-error v 'file-error "Couldn't make directory %s" dir))))))
 528
 529 (defun tramp-smb-handle-make-directory-internal (directory)
 530   "Like `make-directory-internal' for Tramp files."
 531   (setq directory (directory-file-name (expand-file-name directory)))
 532   (unless (file-name-absolute-p directory)
 533     (setq directory (expand-file-name directory default-directory)))
 534   (with-parsed-tramp-file-name directory nil
 535     (save-match-data
 536       (let* ((file (tramp-smb-get-localname localname t)))
 537         (when (file-directory-p (file-name-directory directory))
 538           (tramp-smb-send-command v (format "mkdir \"%s\"" file))
 539           ;; We must also flush the cache of the directory, because
 540           ;; file-attributes reads the values from there.
 541           (tramp-flush-file-property v (file-name-directory localname)))
 542         (unless (file-directory-p directory)
 543           (tramp-error
 544            v 'file-error "Couldn't make directory %s" directory))))))
 545
 546 (defun tramp-smb-handle-rename-file
 547   (filename newname &optional ok-if-already-exists)
 548   "Like `rename-file' for Tramp files."
 549   (setq filename (expand-file-name filename)
 550         newname (expand-file-name newname))
 551
 552   (let ((tmpfile (file-local-copy filename)))
 553
 554     (if tmpfile
 555         ;; Remote filename.
 556         (condition-case err
 557             (rename-file tmpfile newname ok-if-already-exists)
 558           ((error quit)
 559            (delete-file tmpfile)
 560            (signal (car err) (cdr err))))
 561
 562       ;; Remote newname.
 563       (when (file-directory-p newname)
 564         (setq newname (expand-file-name
 565                       (file-name-nondirectory filename) newname)))
 566
 567       (with-parsed-tramp-file-name newname nil
 568         (when (and (not ok-if-already-exists)
 569                    (file-exists-p newname))
 570           (tramp-error v 'file-already-exists newname))
 571         ;; We must also flush the cache of the directory, because
 572         ;; file-attributes reads the values from there.
 573         (tramp-flush-file-property v (file-name-directory localname))
 574         (tramp-flush-file-property v localname)
 575         (let ((file (tramp-smb-get-localname localname t)))
 576           (tramp-message v 0 "Copying file %s to file %s..." filename newname)
 577           (if (tramp-smb-send-command v (format "put %s \"%s\"" filename file))
 578               (tramp-message
 579                v 0 "Copying file %s to file %s...done" filename newname)
 580             (tramp-error v 'file-error "Cannot rename `%s'" filename))))))
 581
 582   (delete-file filename))
 583
 584 (defun tramp-smb-handle-substitute-in-file-name (filename)
 585   "Like `handle-substitute-in-file-name' for Tramp files.
 586 \"//\" substitutes only in the local filename part.  Catches
 587 errors for shares like \"C$/\", which are common in Microsoft Windows."
 588   (with-parsed-tramp-file-name filename nil
 589     ;; Ignore in LOCALNAME everything before "//".
 590     (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname))
 591       (setq filename
 592             (concat (file-remote-p filename)
 593                     (replace-match "\\1" nil nil localname)))))
 594   (condition-case nil
 595       (tramp-run-real-handler 'substitute-in-file-name (list filename))
 596     (error filename)))
 597
 598 (defun tramp-smb-handle-write-region
 599   (start end filename &optional append visit lockname confirm)
 600   "Like `write-region' for Tramp files."
 601   (setq filename (expand-file-name filename))
 602   (with-parsed-tramp-file-name filename nil
 603     (unless (eq append nil)
 604       (tramp-error
 605          v 'file-error "Cannot append to file using Tramp (`%s')" filename))
 606     ;; XEmacs takes a coding system as the seventh argument, not `confirm'.
 607     (when (and (not (featurep 'xemacs))
 608                confirm (file-exists-p filename))
 609       (unless (y-or-n-p (format "File %s exists; overwrite anyway? "
 610                                 filename))
 611         (tramp-error v 'file-error "File not overwritten")))
 612     ;; We must also flush the cache of the directory, because
 613     ;; `file-attributes' reads the values from there.
 614     (tramp-flush-file-property v (file-name-directory localname))
 615     (tramp-flush-file-property v localname)
 616     (let ((file (tramp-smb-get-localname localname t))
 617           (curbuf (current-buffer))
 618           (tmpfile (tramp-compat-make-temp-file filename)))
 619       ;; We say `no-message' here because we don't want the visited file
 620       ;; modtime data to be clobbered from the temp file.  We call
 621       ;; `set-visited-file-modtime' ourselves later on.
 622       (tramp-run-real-handler
 623        'write-region
 624        (if confirm ; don't pass this arg unless defined for backward compat.
 625            (list start end tmpfile append 'no-message lockname confirm)
 626          (list start end tmpfile append 'no-message lockname)))
 627
 628       (tramp-message v 5 "Writing tmp file %s to file %s..." tmpfile filename)
 629       (unwind-protect
 630           (if (tramp-smb-send-command v (format "put %s \"%s\"" tmpfile file))
 631               (tramp-message
 632                v 5 "Writing tmp file %s to file %s...done" tmpfile filename)
 633             (tramp-error v 'file-error "Cannot write `%s'" filename))
 634         (delete-file tmpfile))
 635
 636       (unless (equal curbuf (current-buffer))
 637         (tramp-error
 638          v 'file-error
 639          "Buffer has changed from `%s' to `%s'" curbuf (current-buffer)))
 640       (when (eq visit t)
 641         (set-visited-file-modtime)))))
 642
 643
 644 ;; Internal file name functions
 645
 646 (defun tramp-smb-get-share (localname)
 647   "Returns the share name of LOCALNAME."
 648   (save-match-data
 649     (when (string-match "^/?\\([^/]+\\)/" localname)
 650       (match-string 1 localname))))
 651
 652 (defun tramp-smb-get-localname (localname convert)
 653   "Returns the file name of LOCALNAME.
 654 If CONVERT is non-nil exchange \"/\" by \"\\\\\"."
 655   (save-match-data
 656     (let ((res localname))
 657
 658       (setq
 659        res (if (string-match "^/?[^/]+/\\(.*\\)" res)
 660                (if convert
 661                    (mapconcat
 662                     (lambda (x) (if (equal x ?/) "\\" (char-to-string x)))
 663                     (match-string 1 res) "")
 664                  (match-string 1 res))
 665              (if (string-match "^/?\\([^/]+\\)$" res)
 666                  (match-string 1 res)
 667                "")))
 668
 669       ;; Sometimes we have discarded `substitute-in-file-name'
 670       (when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" res)
 671         (setq res (replace-match "$" nil nil res 1)))
 672
 673       res)))
 674
 675 ;; Share names of a host are cached. It is very unlikely that the
 676 ;; shares do change during connection.
 677 (defun tramp-smb-get-file-entries (directory)
 678   "Read entries which match DIRECTORY.
 679 Either the shares are listed, or the `dir' command is executed.
 680 Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)."
 681   (with-parsed-tramp-file-name directory nil
 682     (setq localname (or localname "/"))
 683     (with-file-property v localname "file-entries"
 684       (with-current-buffer (tramp-get-buffer v)
 685         (let* ((share (tramp-smb-get-share localname))
 686                (file (tramp-smb-get-localname localname nil))
 687                (cache (tramp-get-connection-property v "share-cache" nil))
 688                res entry)
 689
 690           (if (and (not share) cache)
 691               ;; Return cached shares
 692               (setq res cache)
 693
 694             ;; Read entries
 695             (setq file (file-name-as-directory file))
 696             (when (string-match "^\\./" file)
 697               (setq file (substring file 1)))
 698             (if share
 699                 (tramp-smb-send-command v (format "dir \"%s*\"" file))
 700               ;; `tramp-smb-maybe-open-connection' lists also the share names
 701               (tramp-smb-maybe-open-connection v))
 702
 703             ;; Loop the listing
 704             (goto-char (point-min))
 705             (unless (re-search-forward tramp-smb-errors nil t)
 706               (while (not (eobp))
 707                 (setq entry (tramp-smb-read-file-entry share))
 708                 (forward-line)
 709                 (when entry (add-to-list 'res entry))))
 710
 711             ;; Cache share entries
 712             (unless share
 713               (tramp-set-connection-property v "share-cache" res)))
 714
 715           ;; Add directory itself
 716           (add-to-list 'res '("" "drwxrwxrwx" 0 (0 0)))
 717
 718           ;; There's a very strange error (debugged with XEmacs 21.4.14)
 719           ;; If there's no short delay, it returns nil.  No idea about.
 720           (when (featurep 'xemacs) (sleep-for 0.01))
 721
 722           ;; Return entries
 723           (delq nil res))))))
 724
 725 ;; Return either a share name (if SHARE is nil), or a file name
 726 ;;
 727 ;; If shares are listed, the following format is expected
 728 ;;
 729 ;; \s-\{8,8}                              - leading spaces
 730 ;; \S-\(.*\S-\)\s-*                       - share name, 14 char
 731 ;; \s-                                    - space delimeter
 732 ;; \S-+\s-*                               - type, 8 char, "Disk    " expected
 733 ;; \(\s-\{2,2\}.*\)?                      - space delimeter, comment
 734 ;;
 735 ;; Entries provided by smbclient DIR aren't fully regular.
 736 ;; They should have the format
 737 ;;
 738 ;; \s-\{2,2}                              - leading spaces
 739 ;; \S-\(.*\S-\)\s-*                       - file name, 30 chars, left bound
 740 ;; \s-+[ADHRSV]*                          - permissions, 7 chars, right bound
 741 ;; \s-                                    - space delimeter
 742 ;; \s-+[0-9]+                             - size, 8 chars, right bound
 743 ;; \s-\{2,2\}                             - space delimeter
 744 ;; \w\{3,3\}                              - weekday
 745 ;; \s-                                    - space delimeter
 746 ;; \w\{3,3\}                              - month
 747 ;; \s-                                    - space delimeter
 748 ;; [ 12][0-9]                             - day
 749 ;; \s-                                    - space delimeter
 750 ;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time
 751 ;; \s-                                    - space delimeter
 752 ;; [0-9]\{4,4\}                           - year
 753 ;;
 754 ;; samba/src/client.c (http://samba.org/doxygen/samba/client_8c-source.html)
 755 ;; has function display_finfo:
 756 ;;
 757 ;;   d_printf("  %-30s%7.7s %8.0f  %s",
 758 ;;            finfo->name,
 759 ;;            attrib_string(finfo->mode),
 760 ;;            (double)finfo->size,
 761 ;;            asctime(LocalTime(&t)));
 762 ;;
 763 ;; in Samba 1.9, there's the following code:
 764 ;;
 765 ;;   DEBUG(0,("  %-30s%7.7s%10d  %s",
 766 ;;         CNV_LANG(finfo->name),
 767 ;;         attrib_string(finfo->mode),
 768 ;;         finfo->size,
 769 ;;         asctime(LocalTime(&t))));
 770 ;;
 771 ;; Problems:
 772 ;; * Modern regexp constructs, like spy groups and counted repetitions, aren't
 773 ;;   available in older Emacsen.
 774 ;; * The length of constructs (file name, size) might exceed the default.
 775 ;; * File names might contain spaces.
 776 ;; * Permissions might be empty.
 777 ;;
 778 ;; So we try to analyze backwards.
 779 (defun tramp-smb-read-file-entry (share)
 780   "Parse entry in SMB output buffer.
 781 If SHARE is result, entries are of type dir. Otherwise, shares are listed.
 782 Result is the list (LOCALNAME MODE SIZE MTIME)."
 783 ;; We are called from `tramp-smb-get-file-entries', which sets the
 784 ;; current buffer.
 785   (let ((line (buffer-substring (point) (tramp-compat-line-end-position)))
 786         localname mode size month day hour min sec year mtime)
 787
 788     (if (not share)
 789
 790         ;; Read share entries.
 791         (when (string-match "^\\s-+\\(\\S-\\(.*\\S-\\)?\\)\\s-+Disk" line)
 792           (setq localname (match-string 1 line)
 793                 mode "dr-xr-xr-x"
 794                 size 0))
 795
 796       ;; Real listing.
 797       (block nil
 798
 799         ;; year
 800         (if (string-match "\\([0-9]+\\)$" line)
 801             (setq year (string-to-number (match-string 1 line))
 802                   line (substring line 0 -5))
 803           (return))
 804
 805         ;; time
 806         (if (string-match "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)$" line)
 807             (setq hour (string-to-number (match-string 1 line))
 808                   min  (string-to-number (match-string 2 line))
 809                   sec  (string-to-number (match-string 3 line))
 810                   line (substring line 0 -9))
 811           (return))
 812
 813         ;; day
 814         (if (string-match "\\([0-9]+\\)$" line)
 815             (setq day  (string-to-number (match-string 1 line))
 816                   line (substring line 0 -3))
 817           (return))
 818
 819         ;; month
 820         (if (string-match "\\(\\w+\\)$" line)
 821             (setq month (match-string 1 line)
 822                   line  (substring line 0 -4))
 823           (return))
 824
 825         ;; weekday
 826         (if (string-match "\\(\\w+\\)$" line)
 827             (setq line (substring line 0 -5))
 828           (return))
 829
 830         ;; size
 831         (if (string-match "\\([0-9]+\\)$" line)
 832             (let ((length (- (max 10 (1+ (length (match-string 1 line)))))))
 833               (setq size (string-to-number (match-string 1 line)))
 834               (when (string-match "\\([ADHRSV]+\\)" (substring line length))
 835                 (setq length (+ length (match-end 0))))
 836               (setq line (substring line 0 length)))
 837           (return))
 838
 839         ;; mode: ARCH, DIR, HIDDEN, RONLY, SYSTEM, VOLID
 840         (if (string-match "\\([ADHRSV]+\\)?$" line)
 841             (setq
 842              mode (or (match-string 1 line) "")
 843              mode (save-match-data (format
 844                     "%s%s"
 845                     (if (string-match "D" mode) "d" "-")
 846                     (mapconcat
 847                      (lambda (x) "") "    "
 848                      (concat "r" (if (string-match "R" mode) "-" "w") "x"))))
 849              line (substring line 0 -7))
 850           (return))
 851
 852         ;; localname
 853         (if (string-match "^\\s-+\\(\\S-\\(.*\\S-\\)?\\)\\s-*$" line)
 854             (setq localname (match-string 1 line))
 855           (return))))
 856
 857     (when (and localname mode size)
 858       (setq mtime
 859             (if (and sec min hour day month year)
 860                 (encode-time
 861                  sec min hour day
 862                  (cdr (assoc (downcase month) tramp-parse-time-months))
 863                  year)
 864               '(0 0)))
 865       (list localname mode size mtime))))
 866
 867
 868 ;; Connection functions
 869
 870 (defun tramp-smb-send-command (vec command)
 871   "Send the COMMAND to connection VEC.
 872 Returns nil if there has been an error message from smbclient."
 873   (tramp-smb-maybe-open-connection vec)
 874   (tramp-message vec 6 "%s" command)
 875   (tramp-send-string vec command)
 876   (tramp-smb-wait-for-output vec))
 877
 878 (defun tramp-smb-maybe-open-connection (vec)
 879   "Maybe open a connection to HOST, log in as USER, using `tramp-smb-program'.
 880 Does not do anything if a connection is already open, but re-opens the
 881 connection if a previous connection has died for some reason."
 882   (let* ((share (tramp-smb-get-share (tramp-file-name-localname vec)))
 883          (buf (tramp-get-buffer vec))
 884          (p (get-buffer-process buf)))
 885
 886     ;; If too much time has passed since last command was sent, look
 887     ;; whether has been an error message; maybe due to connection timeout.
 888     (with-current-buffer buf
 889       (goto-char (point-min))
 890       (when (and (> (tramp-time-diff
 891                      (current-time)
 892                      (tramp-get-connection-property
 893                       p "last-cmd-time" '(0 0 0)))
 894                     60)
 895                  p (processp p) (memq (process-status p) '(run open))
 896                  (re-search-forward tramp-smb-errors nil t))
 897         (delete-process p)
 898         (setq p nil)))
 899
 900     ;; Check whether it is still the same share.
 901     (unless
 902         (and p (processp p) (memq (process-status p) '(run open))
 903              (string-equal
 904               share
 905               (tramp-get-connection-property p "smb-share" "")))
 906
 907       (save-match-data
 908         ;; There might be unread output from checking for share names.
 909         (when buf (with-current-buffer buf (erase-buffer)))
 910         (when (and p (processp p)) (delete-process p))
 911
 912         (unless (let ((default-directory
 913                         (tramp-compat-temporary-file-directory)))
 914                   (executable-find tramp-smb-program))
 915           (error "Cannot find command %s in %s" tramp-smb-program exec-path))
 916
 917         (let* ((user      (tramp-file-name-user vec))
 918                (host      (tramp-file-name-host vec))
 919                (real-user (tramp-file-name-real-user vec))
 920                (real-host (tramp-file-name-real-host vec))
 921                (domain    (tramp-file-name-domain vec))
 922                (port      (tramp-file-name-port vec))
 923                args)
 924
 925           (if share
 926               (setq args (list (concat "//" real-host "/" share)))
 927             (setq args (list "-L" real-host )))
 928
 929           (if (not (zerop (length real-user)))
 930               (setq args (append args (list "-U" real-user)))
 931             (setq args (append args (list "-N"))))
 932
 933           (when domain (setq args (append args (list "-W" domain))))
 934           (when port   (setq args (append args (list "-p" port))))
 935           (setq args (append args (list "-s" "/dev/null")))
 936
 937           ;; OK, let's go.
 938           (tramp-message
 939            vec 3 "Opening connection for //%s%s/%s..."
 940            (if (not (zerop (length user))) (concat user "@") "")
 941            host (or share ""))
 942
 943           (let* ((coding-system-for-read nil)
 944                  (process-connection-type tramp-process-connection-type)
 945                  (p (let ((default-directory
 946                             (tramp-compat-temporary-file-directory)))
 947                       (apply #'start-process
 948                              (tramp-buffer-name vec) (tramp-get-buffer vec)
 949                              tramp-smb-program args))))
 950
 951             (tramp-message
 952              vec 6 "%s" (mapconcat 'identity (process-command p) " "))
 953             (tramp-set-process-query-on-exit-flag p nil)
 954             (tramp-set-connection-property p "smb-share" share)
 955
 956             ;; Set variables for computing the prompt for reading password.
 957             (setq tramp-current-method tramp-smb-method
 958                   tramp-current-user user
 959                   tramp-current-host host)
 960
 961             ;; Set chunksize.  Otherwise, `tramp-send-string' might
 962             ;; try it itself.
 963             (tramp-set-connection-property p "chunksize" tramp-chunksize)
 964
 965             ;; Play login scenario.
 966             (tramp-process-actions
 967              p vec
 968              (if share
 969                  tramp-smb-actions-with-share
 970                tramp-smb-actions-without-share))
 971
 972             (tramp-message
 973              vec 3 "Opening connection for //%s%s/%s...done"
 974              (if (not (zerop (length user))) (concat user "@") "")
 975              host (or share ""))))))))
 976
 977 ;; We don't use timeouts.  If needed, the caller shall wrap around.
 978 (defun tramp-smb-wait-for-output (vec)
 979   "Wait for output from smbclient command.
 980 Returns nil if an error message has appeared."
 981   (with-current-buffer (tramp-get-buffer vec)
 982     (let ((p (get-buffer-process (current-buffer)))
 983           (found (progn (goto-char (point-min))
 984                         (re-search-forward tramp-smb-prompt nil t)))
 985           (err   (progn (goto-char (point-min))
 986                         (re-search-forward tramp-smb-errors nil t))))
 987
 988       ;; Algorithm: get waiting output.  See if last line contains
 989       ;; tramp-smb-prompt sentinel or tramp-smb-errors strings.
 990       ;; If not, wait a bit and again get waiting output.
 991       (while (and (not found) (not err))
 992
 993         ;; Accept pending output.
 994         (tramp-accept-process-output p)
 995
 996         ;; Search for prompt.
 997         (goto-char (point-min))
 998         (setq found (re-search-forward tramp-smb-prompt nil t))
 999
1000         ;; Search for errors.
1001         (goto-char (point-min))
1002         (setq err (re-search-forward tramp-smb-errors nil t)))
1003
1004       ;; When the process is still alive, read pending output.
1005       (while (and (not found) (memq (process-status p) '(run open)))
1006
1007         ;; Accept pending output.
1008         (tramp-accept-process-output p)
1009
1010         ;; Search for prompt.
1011         (goto-char (point-min))
1012         (setq found (re-search-forward tramp-smb-prompt nil t)))
1013
1014       ;; Return value is whether no error message has appeared.
1015       (tramp-message vec 6 "\n%s" (buffer-string))
1016       (not err))))
1017
1018
1019 (provide 'tramp-smb)
1020
1021 ;;; TODO:
1022
1023 ;; * Error handling in case password is wrong.
1024 ;; * Read password from "~/.netrc".
1025 ;; * Return more comprehensive file permission string.  Think whether it is
1026 ;;   possible to implement `set-file-modes'.
1027 ;; * Handle links (FILENAME.LNK).
1028 ;; * Try to remove the inclusion of dummy "" directory.  Seems to be at
1029 ;;   several places, especially in `tramp-smb-handle-insert-directory'.
1030 ;; * (RMS) Use unwind-protect to clean up the state so as to make the state
1031 ;;   regular again.
1032 ;; * Make it multi-hop capable.
1033
1034 ;; arch-tag: fcc9dbec-7503-4d73-b638-3c8aa59575f5
1035 ;;; tramp-smb.el ends here