Mercurial > emacs

--- a/lisp/net/tramp-smb.el	Wed Oct 07 11:27:10 2009 +0000
+++ b/lisp/net/tramp-smb.el	Wed Oct 07 11:30:19 2009 +0000
@@ -68,11 +68,13 @@
   ;; `regexp-opt' not possible because of first string.
   (mapconcat
    'identity
-   '(;; Connection error / timeout
+   '(;; Connection error / timeout / unknown command.
      "Connection to \\S-+ failed"
      "Read from server failed, maybe it closed the connection"
      "Call timed out: server did not respond"
-     ;; Samba
+     "\\S-+: command not found"
+     "Server doesn't support UNIX CIFS calls"
+     ;; Samba.
      "ERRDOS"
      "ERRSRV"
      "ERRbadfile"
@@ -82,7 +84,7 @@
      "ERRnomem"
      "ERRnosuchshare"
      ;; Windows 4.0 (Windows NT), Windows 5.0 (Windows 2000),
-     ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003)
+     ;; Windows 5.1 (Windows XP), Windows 5.2 (Windows Server 2003).
      "NT_STATUS_ACCESS_DENIED"
      "NT_STATUS_ACCOUNT_LOCKED_OUT"
      "NT_STATUS_BAD_NETWORK_NAME"
@@ -128,20 +130,22 @@
 ;; New handlers should be added here.
 (defconst tramp-smb-file-name-handler-alist
   '(
-    ;; `access-file' performed by default handler
+    ;; `access-file' performed by default handler.
     (add-name-to-file . tramp-smb-handle-copy-file) ;; we're on Windows, honey.
-    ;; `byte-compiler-base-file-name' performed by default handler
+    ;; `byte-compiler-base-file-name' performed by default handler.
+    (copy-directory . tramp-smb-handle-copy-directory)
     (copy-file . tramp-smb-handle-copy-file)
     (delete-directory . tramp-smb-handle-delete-directory)
     (delete-file . tramp-smb-handle-delete-file)
-    ;; `diff-latest-backup-file' performed by default handler
+    ;; `diff-latest-backup-file' performed by default handler.
     (directory-file-name . tramp-handle-directory-file-name)
     (directory-files . tramp-smb-handle-directory-files)
-    (directory-files-and-attributes . tramp-smb-handle-directory-files-and-attributes)
+    (directory-files-and-attributes
+     . tramp-smb-handle-directory-files-and-attributes)
     (dired-call-process . ignore)
     (dired-compress-file . ignore)
     (dired-uncache . tramp-handle-dired-uncache)
-    ;; `expand-file-name' not necessary because we cannot expand "~/"
+    (expand-file-name . tramp-smb-handle-expand-file-name)
     (file-accessible-directory-p . tramp-smb-handle-file-directory-p)
     (file-attributes . tramp-smb-handle-file-attributes)
     (file-directory-p .  tramp-smb-handle-file-directory-p)
@@ -155,17 +159,17 @@
     (file-name-completion . tramp-handle-file-name-completion)
     (file-name-directory . tramp-handle-file-name-directory)
     (file-name-nondirectory . tramp-handle-file-name-nondirectory)
-    ;; `file-name-sans-versions' performed by default handler
+    ;; `file-name-sans-versions' performed by default handler.
     (file-newer-than-file-p . tramp-smb-handle-file-newer-than-file-p)
     (file-ownership-preserved-p . ignore)
     (file-readable-p . tramp-smb-handle-file-exists-p)
     (file-regular-p . tramp-handle-file-regular-p)
     (file-symlink-p . tramp-handle-file-symlink-p)
-    ;; `file-truename' performed by default handler
+    ;; `file-truename' performed by default handler.
     (file-writable-p . tramp-smb-handle-file-writable-p)
     (find-backup-file-name . tramp-handle-find-backup-file-name)
-    ;; `find-file-noselect' performed by default handler
-    ;; `get-file-buffer' performed by default handler
+    ;; `find-file-noselect' performed by default handler.
+    ;; `get-file-buffer' performed by default handler.
     (insert-directory . tramp-smb-handle-insert-directory)
     (insert-file-contents . tramp-handle-insert-file-contents)
     (load . tramp-handle-load)
@@ -173,7 +177,8 @@
     (make-directory-internal . tramp-smb-handle-make-directory-internal)
     (make-symbolic-link . ignore)
     (rename-file . tramp-smb-handle-rename-file)
-    (set-file-modes . ignore)
+    (set-file-modes . tramp-smb-handle-set-file-modes)
+    (set-file-times . ignore)
     (set-visited-file-modtime . ignore)
     (shell-command . ignore)
     (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name)
@@ -203,7 +208,50 @@
 	     (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler))


-;; File name primitives
+;; File name primitives.
+
+(defun tramp-smb-handle-copy-directory
+  (dirname newname &optional keep-date parents)
+  "Like `copy-directory' for Tramp files."
+  (setq dirname (expand-file-name dirname)
+	newname (expand-file-name newname))
+  (let ((t1 (tramp-tramp-file-p dirname))
+	(t2 (tramp-tramp-file-p newname)))
+    (with-parsed-tramp-file-name (if t1 dirname newname) nil
+      (if (or (null t1) (null t2))
+	  ;; We can copy recursively.
+	  (let ((prompt (tramp-smb-send-command v "prompt"))
+		(recurse (tramp-smb-send-command v "recurse")))
+	    (unless (file-directory-p newname)
+	      (make-directory newname parents))
+	    (unwind-protect
+		(unless
+		    (and
+		     prompt recurse
+		     (tramp-smb-send-command
+		      v (format "cd \"%s\""
+				(tramp-smb-get-localname localname t)))
+		     (tramp-smb-send-command
+		      v (format "lcd \"%s\"" (if t1 newname dirname)))
+		     (if t1
+			 (tramp-smb-send-command v "mget *")
+		       (tramp-smb-send-command v "mput *")))
+		  ;; Error.
+		  (with-current-buffer (tramp-get-connection-buffer v)
+		    (goto-char (point-min))
+		    (search-forward-regexp tramp-smb-errors nil t)
+		    (tramp-error
+		     v 'file-error
+		     "%s `%s'" (match-string 0) (if t1 dirname newname))))
+	      ;; Always go home.
+	      (tramp-smb-send-command v (format "cd \\"))
+	      ;; Toggle prompt and recurse OFF.
+	      (if prompt (tramp-smb-send-command v "prompt"))
+	      (if recurse (tramp-smb-send-command v "recurse"))))
+
+	;; We must do it file-wise.
+	(tramp-run-real-handler
+	 'copy-directory (list dirname newname keep-date parents))))))

 (defun tramp-smb-handle-copy-file
   (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
@@ -247,7 +295,10 @@
 	       v (format "put %s \"%s\"" filename file))
 	      (tramp-message
 	       v 0 "Copying file %s to file %s...done" filename newname)
-	    (tramp-error v 'file-error "Cannot copy `%s'" filename)))))))
+	    (tramp-error v 'file-error "Cannot copy `%s'" filename))))))
+
+  ;; KEEP-DATE handling.
+  (when keep-date (set-file-times newname (nth 5 (file-attributes filename)))))

 (defun tramp-smb-handle-delete-directory (directory &optional recursive)
   "Like `delete-directory' for Tramp files."
@@ -273,13 +324,13 @@
 	    (unless (and
 		     (tramp-smb-send-command v (format "cd \"%s\"" dir))
 		     (tramp-smb-send-command v (format "rmdir \"%s\"" file)))
-	      ;; Error
+	      ;; Error.
 	      (with-current-buffer (tramp-get-connection-buffer v)
 		(goto-char (point-min))
 		(search-forward-regexp tramp-smb-errors nil t)
 		(tramp-error
 		 v 'file-error "%s `%s'" (match-string 0) directory)))
-	  ;; Always go home
+	  ;; Always go home.
 	  (tramp-smb-send-command v (format "cd \\")))))))

 (defun tramp-smb-handle-delete-file (filename)
@@ -297,13 +348,13 @@
 	    (unless (and
 		     (tramp-smb-send-command v (format "cd \"%s\"" dir))
 		     (tramp-smb-send-command v (format "rm \"%s\"" file)))
-	      ;; Error
+	      ;; Error.
 	      (with-current-buffer (tramp-get-connection-buffer v)
 		(goto-char (point-min))
 		(search-forward-regexp tramp-smb-errors nil t)
 		(tramp-error
 		 v 'file-error "%s `%s'" (match-string 0) filename)))
-	  ;; Always go home
+	  ;; Always go home.
 	  (tramp-smb-send-command v (format "cd \\")))))))

 (defun tramp-smb-handle-directory-files
@@ -311,21 +362,21 @@
   "Like `directory-files' for Tramp files."
   (let ((result (mapcar 'directory-file-name
 			(file-name-all-completions "" directory))))
-    ;; Discriminate with regexp
+    ;; Discriminate with regexp.
     (when match
       (setq result
 	    (delete nil
 		    (mapcar (lambda (x) (when (string-match match x) x))
 			    result))))
-    ;; Append directory
+    ;; Append directory.
     (when full
       (setq result
 	    (mapcar
 	     (lambda (x) (expand-file-name x directory))
 	     result)))
-    ;; Sort them if necessary
+    ;; Sort them if necessary.
     (unless nosort (setq result (sort result 'string-lessp)))
-    ;; That's it
+    ;; That's it.
     result))

 (defun tramp-smb-handle-directory-files-and-attributes
@@ -337,6 +388,35 @@
 	      (if full x (expand-file-name x directory)) id-format)))
    (directory-files directory full match nosort)))

+(defun tramp-smb-handle-expand-file-name (name &optional dir)
+  "Like `expand-file-name' for Tramp files."
+  ;; If DIR is not given, use DEFAULT-DIRECTORY or "/".
+  (setq dir (or dir default-directory "/"))
+  ;; Unless NAME is absolute, concat DIR and NAME.
+  (unless (file-name-absolute-p name)
+    (setq name (concat (file-name-as-directory dir) name)))
+  ;; If NAME is not a Tramp file, run the real handler.
+  (if (not (tramp-tramp-file-p name))
+      (tramp-run-real-handler 'expand-file-name (list name nil))
+    ;; Dissect NAME.
+    (with-parsed-tramp-file-name name nil
+      (unless (tramp-run-real-handler 'file-name-absolute-p (list localname))
+	(setq localname (concat "/" localname)))
+      ;; Tilde expansion if necessary.  We use the user name as share,
+      ;; which is offen the case in work groups.
+      (when (string-match "\\`~[^/]*" localname)
+	(setq localname
+	      (replace-match
+	       (if (zerop (length (match-string 0 localname)))
+		   (tramp-file-name-real-user v)
+		 (match-string 0 localname))
+	       nil nil localname)))
+      ;; No tilde characters in file name, do normal
+      ;; `expand-file-name' (this does "/./" and "/../").
+      (tramp-make-tramp-file-name
+       method user host
+       (tramp-run-real-handler 'expand-file-name (list localname))))))
+
 (defun tramp-smb-handle-file-attributes (filename &optional id-format)
   "Like `file-attributes' for Tramp files."
   ;; Reading just the filename entry via "dir localname" is not
@@ -348,8 +428,7 @@
     (with-file-property v localname (format "file-attributes-%s" id-format)
       (let* ((entries (tramp-smb-get-file-entries
 		       (file-name-directory filename)))
-	     (entry (and entries
-			 (assoc (file-name-nondirectory filename) entries)))
+	     (entry (assoc (file-name-nondirectory filename) entries))
 	     (uid (if (and id-format (equal id-format 'string)) "nobody" -1))
 	     (gid (if (and id-format (equal id-format 'string)) "nogroup" -1))
 	     (inode (tramp-get-inode v))
@@ -442,7 +521,6 @@
     ;; Called from `dired-add-entry'.
     (setq filename (file-name-as-directory filename)))
   (with-parsed-tramp-file-name filename nil
-    (tramp-flush-file-property v (file-name-directory localname))
     (save-match-data
       (let ((base (file-name-nondirectory filename))
 	    ;; We should not destroy the cache entry.
@@ -527,10 +605,10 @@
     (save-match-data
       (let* ((share (tramp-smb-get-share localname))
 	     (ldir (file-name-directory dir)))
-	;; Make missing directory parts
+	;; Make missing directory parts.
 	(when (and parents share (not (file-directory-p ldir)))
 	  (make-directory ldir parents))
-	;; Just do it
+	;; Just do it.
 	(when (file-directory-p ldir)
 	  (make-directory-internal dir))
 	(unless (file-directory-p dir)
@@ -592,6 +670,17 @@

   (delete-file filename))

+(defun tramp-smb-handle-set-file-modes (filename mode)
+  "Like `set-file-modes' for Tramp files."
+  (with-parsed-tramp-file-name filename nil
+    (tramp-flush-file-property v localname)
+    (unless (tramp-smb-send-command
+	     v (format "chmod \"%s\" %s"
+		       (tramp-smb-get-localname localname t)
+		       (tramp-decimal-to-octal mode)))
+      (tramp-error
+       v 'file-error "Error while changing file's mode %s" filename))))
+
 (defun tramp-smb-handle-substitute-in-file-name (filename)
   "Like `handle-substitute-in-file-name' for Tramp files.
 \"//\" substitutes only in the local filename part.  Catches
@@ -652,7 +741,7 @@
 	(set-visited-file-modtime)))))


-;; Internal file name functions
+;; Internal file name functions.

 (defun tramp-smb-get-share (localname)
   "Returns the share name of LOCALNAME."
@@ -677,7 +766,7 @@
 		 (match-string 1 res)
 	       "")))

-      ;; Sometimes we have discarded `substitute-in-file-name'
+      ;; Sometimes we have discarded `substitute-in-file-name'.
       (when (string-match "\\(\\$\\$\\)\\(/\\|$\\)" res)
 	(setq res (replace-match "$" nil nil res 1)))

@@ -699,19 +788,19 @@
 	       res entry)

 	  (if (and (not share) cache)
-	      ;; Return cached shares
+	      ;; Return cached shares.
 	      (setq res cache)

-	    ;; Read entries
+	    ;; Read entries.
 	    (setq file (file-name-as-directory file))
 	    (when (string-match "^\\./" file)
 	      (setq file (substring file 1)))
 	    (if share
 		(tramp-smb-send-command v (format "dir \"%s*\"" file))
-	      ;; `tramp-smb-maybe-open-connection' lists also the share names
+	      ;; `tramp-smb-maybe-open-connection' lists also the share names.
 	      (tramp-smb-maybe-open-connection v))

-	    ;; Loop the listing
+	    ;; Loop the listing.
 	    (goto-char (point-min))
 	    (unless (re-search-forward tramp-smb-errors nil t)
 	      (while (not (eobp))
@@ -719,23 +808,23 @@
 		(forward-line)
 		(when entry (add-to-list 'res entry))))

-	    ;; Cache share entries
+	    ;; Cache share entries.
 	    (unless share
 	      (tramp-set-connection-property v "share-cache" res)))

-	  ;; Add directory itself
+	  ;; Add directory itself.
 	  (add-to-list 'res '("" "drwxrwxrwx" 0 (0 0)))

 	  ;; There's a very strange error (debugged with XEmacs 21.4.14)
 	  ;; If there's no short delay, it returns nil.  No idea about.
 	  (when (featurep 'xemacs) (sleep-for 0.01))

-	  ;; Return entries
+	  ;; Return entries.
 	  (delq nil res))))))

-;; Return either a share name (if SHARE is nil), or a file name
+;; Return either a share name (if SHARE is nil), or a file name.
 ;;
-;; If shares are listed, the following format is expected
+;; If shares are listed, the following format is expected:
 ;;
 ;; \s-\{8,8}                              - leading spaces
 ;; \S-\(.*\S-\)\s-*                       - share name, 14 char
@@ -807,13 +896,13 @@
       ;; Real listing.
       (block nil

-	;; year
+	;; year.
 	(if (string-match "\\([0-9]+\\)$" line)
 	    (setq year (string-to-number (match-string 1 line))
 		  line (substring line 0 -5))
 	  (return))

-	;; time
+	;; time.
 	(if (string-match "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)$" line)
 	    (setq hour (string-to-number (match-string 1 line))
 		  min  (string-to-number (match-string 2 line))
@@ -821,24 +910,24 @@
 		  line (substring line 0 -9))
 	  (return))

-	;; day
+	;; day.
 	(if (string-match "\\([0-9]+\\)$" line)
 	    (setq day  (string-to-number (match-string 1 line))
 		  line (substring line 0 -3))
 	  (return))

-	;; month
+	;; month.
 	(if (string-match "\\(\\w+\\)$" line)
 	    (setq month (match-string 1 line)
 		  line  (substring line 0 -4))
 	  (return))

-	;; weekday
+	;; weekday.
 	(if (string-match "\\(\\w+\\)$" line)
 	    (setq line (substring line 0 -5))
 	  (return))

-	;; size
+	;; size.
 	(if (string-match "\\([0-9]+\\)$" line)
 	    (let ((length (- (max 10 (1+ (length (match-string 1 line)))))))
 	      (setq size (string-to-number (match-string 1 line)))
@@ -847,7 +936,7 @@
 	      (setq line (substring line 0 length)))
 	  (return))

-	;; mode: ARCH, DIR, HIDDEN, RONLY, SYSTEM, VOLID
+	;; mode: ARCH, DIR, HIDDEN, RONLY, SYSTEM, VOLID.
 	(if (string-match "\\([ADHRSV]+\\)?$" line)
 	    (setq
 	     mode (or (match-string 1 line) "")
@@ -860,7 +949,7 @@
 	     line (substring line 0 -7))
 	  (return))

-	;; localname
+	;; localname.
 	(if (string-match "^\\s-+\\(\\S-\\(.*\\S-\\)?\\)\\s-*$" line)
 	    (setq localname (match-string 1 line))
 	  (return))))
@@ -876,7 +965,7 @@
       (list localname mode size mtime))))


-;; Connection functions
+;; Connection functions.

 (defun tramp-smb-send-command (vec command)
   "Send the COMMAND to connection VEC.
@@ -894,8 +983,32 @@
 	 (buf (tramp-get-buffer vec))
 	 (p (get-buffer-process buf)))

+    ;; Check whether we still have the same smbclient version.
+    ;; Otherwise, we must delete the connection cache, because
+    ;; capabilities migh have changed.
+    (unless (processp p)
+      (unless (let ((default-directory
+		      (tramp-compat-temporary-file-directory)))
+		(executable-find tramp-smb-program))
+	(tramp-error
+	 vec 'file-error
+	 "Cannot find command %s in %s" tramp-smb-program exec-path))
+
+      (let* ((default-directory (tramp-compat-temporary-file-directory))
+	     (smbclient-version
+	      (shell-command-to-string (concat tramp-smb-program " -V"))))
+	(unless (string-equal
+		 smbclient-version
+		 (tramp-get-connection-property vec "smbclient-version" ""))
+	  (tramp-flush-directory-property vec "")
+	  (tramp-flush-connection-property vec)
+	  (tramp-set-connection-property
+	   vec "smbclient-version" smbclient-version)
+	  (setq buf (tramp-get-buffer vec)))))
+
     ;; If too much time has passed since last command was sent, look
-    ;; whether has been an error message; maybe due to connection timeout.
+    ;; whether there has been an error message; maybe due to
+    ;; connection timeout.
     (with-current-buffer buf
       (goto-char (point-min))
       (when (and (> (tramp-time-diff
@@ -920,11 +1033,6 @@
 	(when buf (with-current-buffer buf (erase-buffer)))
 	(when (and p (processp p)) (delete-process p))

-	(unless (let ((default-directory
-			(tramp-compat-temporary-file-directory)))
-		  (executable-find tramp-smb-program))
-	  (error "Cannot find command %s in %s" tramp-smb-program exec-path))
-
 	(let* ((user      (tramp-file-name-user vec))
 	       (host      (tramp-file-name-host vec))
 	       (real-user (tramp-file-name-real-user vec))
@@ -962,17 +1070,12 @@
 	    (tramp-message
 	     vec 6 "%s" (mapconcat 'identity (process-command p) " "))
 	    (tramp-set-process-query-on-exit-flag p nil)
-	    (tramp-set-connection-property p "smb-share" share)

 	    ;; Set variables for computing the prompt for reading password.
 	    (setq tramp-current-method tramp-smb-method
 		  tramp-current-user user
 		  tramp-current-host host)

-	    ;; Set chunksize.  Otherwise, `tramp-send-string' might
-	    ;; try it itself.
-	    (tramp-set-connection-property p "chunksize" tramp-chunksize)
-
 	    ;; Play login scenario.
 	    (tramp-process-actions
 	     p vec
@@ -980,6 +1083,26 @@
 		 tramp-smb-actions-with-share
 	       tramp-smb-actions-without-share))

+	    ;; Check server version.
+	    (with-current-buffer (tramp-get-connection-buffer vec)
+	      (goto-char (point-min))
+	      (search-forward-regexp
+	       "Domain=\\[[^]]*\\] OS=\\[[^]]*\\] Server=\\[[^]]*\\]" nil t)
+	      (let ((smbserver-version (match-string 0)))
+		(when (not (string-equal
+			    smbserver-version
+			    (tramp-get-connection-property
+			     vec "smbserver-version" "")))
+		  (tramp-flush-directory-property vec "")
+		  (tramp-flush-connection-property vec)
+		  (tramp-set-connection-property
+		   vec "smbserver-version" smbserver-version))))
+
+	    ;; Set chunksize.  Otherwise, `tramp-send-string' might
+	    ;; try it itself.
+	    (tramp-set-connection-property p "smb-share" share)
+	    (tramp-set-connection-property p "chunksize" tramp-chunksize)
+
 	    (tramp-message
 	     vec 3 "Opening connection for //%s%s/%s...done"
 	     (if (not (zerop (length user))) (concat user "@") "")
@@ -1033,8 +1156,7 @@

 ;; * Error handling in case password is wrong.
 ;; * Read password from "~/.netrc".
-;; * Return more comprehensive file permission string.  Think whether it is
-;;   possible to implement `set-file-modes'.
+;; * Return more comprehensive file permission string.
 ;; * Handle links (FILENAME.LNK).
 ;; * Try to remove the inclusion of dummy "" directory.  Seems to be at
 ;;   several places, especially in `tramp-smb-handle-insert-directory'.