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