Mercurial > emacs
diff lisp/net/tramp-vc.el @ 45861:7b663a89ef2a
*** empty log message ***
author | Kai Großjohann <kgrossjo@eu.uu.net> |
---|---|
date | Mon, 17 Jun 2002 11:47:23 +0000 |
parents | |
children | 09acf3f65bb5 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/net/tramp-vc.el Mon Jun 17 11:47:23 2002 +0000 @@ -0,0 +1,480 @@ +;;; tramp-vc.el --- Version control integration for TRAMP.el + +;; Copyright (C) 2000 by Free Software Foundation, Inc. + +;; Author: Daniel Pittman <daniel@danann.net> +;; Keywords: comm, processes + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; See the main module, 'tramp.el' for discussion of the purpose of TRAMP. +;; This module provides integration between remote files accessed by TRAMP and +;; the Emacs version control system. + +;;; Code: + +(eval-when-compile + (require 'cl)) +(require 'vc) +;; Old VC defines vc-rcs-release in vc.el, new VC requires extra module. +(unless (boundp 'vc-rcs-release) + (require 'vc-rcs)) +(require 'tramp) + +;; -- vc -- + +;; This used to blow away the file-name-handler-alist and reinstall +;; TRAMP into it. This was intended to let VC work remotely. It didn't, +;; at least not in my XEmacs 21.2 install. +;; +;; In any case, tramp-run-real-handler now deals correctly with disabling +;; the things that should be, making this a no-op. +;; +;; I have removed it from the tramp-file-name-handler-alist because the +;; shortened version does nothing. This is for reference only now. +;; +;; Daniel Pittman <daniel@danann.net> +;; +;; (defun tramp-handle-vc-registered (file) +;; "Like `vc-registered' for tramp files." +;; (tramp-run-real-handler 'vc-registered (list file))) + +;; `vc-do-command' +;; This function does not deal well with remote files, so we define +;; our own version and make a backup of the original function and +;; call our version for tramp files and the original version for +;; normal files. + +;; The following function is pretty much copied from vc.el, but +;; the part that actually executes a command is changed. +;; CCC: this probably works for Emacs 21, too. +(defun tramp-vc-do-command (buffer okstatus command file last &rest flags) + "Like `vc-do-command' but invoked for tramp files. +See `vc-do-command' for more information." + (save-match-data + (and file (setq file (tramp-handle-expand-file-name file))) + (if (not buffer) (setq buffer "*vc*")) + (if vc-command-messages + (message "Running `%s' on `%s'..." command file)) + (let ((obuf (current-buffer)) (camefrom (current-buffer)) + (squeezed nil) + (olddir default-directory) + vc-file status) + (let* ((v (tramp-dissect-file-name (tramp-handle-expand-file-name file))) + (multi-method (tramp-file-name-multi-method v)) + (method (tramp-file-name-method v)) + (user (tramp-file-name-user v)) + (host (tramp-file-name-host v)) + (path (tramp-file-name-path v))) + (set-buffer (get-buffer-create buffer)) + (set (make-local-variable 'vc-parent-buffer) camefrom) + (set (make-local-variable 'vc-parent-buffer-name) + (concat " from " (buffer-name camefrom))) + (setq default-directory olddir) + + (erase-buffer) + + (mapcar + (function + (lambda (s) (and s (setq squeezed (append squeezed (list s)))))) + flags) + (if (and (eq last 'MASTER) file + (setq vc-file (vc-name file))) + (setq squeezed + (append squeezed + (list (tramp-file-name-path + (tramp-dissect-file-name vc-file)))))) + (if (and file (eq last 'WORKFILE)) + (progn + (let* ((pwd (expand-file-name default-directory)) + (preflen (length pwd))) + (if (string= (substring file 0 preflen) pwd) + (setq file (substring file preflen)))) + (setq squeezed (append squeezed (list file))))) + ;; Unless we (save-window-excursion) the layout of windows in + ;; the current frame changes. This is painful, at best. + ;; + ;; As a point of note, (save-excursion) is still here only because + ;; it preserves (point) in the current buffer. (save-window-excursion) + ;; does not, at least under XEmacs 21.2. + ;; + ;; I trust that the FSF support this as well. I can't find useful + ;; documentation to check :( + ;; + ;; Daniel Pittman <daniel@danann.net> + (save-excursion + (save-window-excursion + ;; Actually execute remote command + (tramp-handle-shell-command + (mapconcat 'tramp-shell-quote-argument + (cons command squeezed) " ") t) + ;;(tramp-wait-for-output) + ;; Get status from command + (tramp-send-command multi-method method user host "echo $?") + (tramp-wait-for-output) + ;; Make sure to get status from last line of output. + (goto-char (point-max)) (forward-line -1) + (setq status (read (current-buffer))) + (message "Command %s returned status %d." command status))) + (goto-char (point-max)) + (set-buffer-modified-p nil) + (forward-line -1) + (if (or (not (integerp status)) (and okstatus (< okstatus status))) + (progn + (pop-to-buffer buffer) + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer) + (error "Running `%s'...FAILED (%s)" command + (if (integerp status) + (format "status %d" status) + status)) + ) + (if vc-command-messages + (message "Running %s...OK" command)) + ) + (set-buffer obuf) + status)) + )) + +;; Following code snarfed from Emacs 21 vc.el and slightly tweaked. +(defun tramp-vc-do-command-new (buffer okstatus command file &rest flags) + "Like `vc-do-command' but for TRAMP files. +This function is for the new VC which comes with Emacs 21. +Since TRAMP doesn't do async commands yet, this function doesn't, either." + (and file (setq file (expand-file-name file))) + (if vc-command-messages + (message "Running %s on %s..." command file)) + (save-current-buffer + (unless (eq buffer t) (vc-setup-buffer buffer)) + (let ((squeezed nil) + (inhibit-read-only t) + (status 0)) + (let* ((v (when file (tramp-dissect-file-name file))) + (multi-method (when file (tramp-file-name-multi-method v))) + (method (when file (tramp-file-name-method v))) + (user (when file (tramp-file-name-user v))) + (host (when file (tramp-file-name-host v))) + (path (when file (tramp-file-name-path v)))) + (setq squeezed (delq nil (copy-sequence flags))) + (when file + (setq squeezed (append squeezed (list path)))) + (let ((w32-quote-process-args t)) + (when (eq okstatus 'async) + (message "Tramp doesn't do async commands, running synchronously.")) + (setq status (tramp-handle-shell-command + (mapconcat 'tramp-shell-quote-argument + (cons command squeezed) " ") t)) + (when (or (not (integerp status)) (and okstatus (< okstatus status))) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer) + (error "Running %s...FAILED (%s)" command + (if (integerp status) (format "status %d" status) status)))) + (if vc-command-messages + (message "Running %s...OK" command)) + (vc-exec-after + `(run-hook-with-args + 'vc-post-command-functions ',command ',path ',flags)) + status)))) + + +;; The context for a VC command is the current buffer. +;; That makes a test on the buffers file more reliable than a test on the +;; arguments. +;; This is needed to handle remote VC correctly - else we test against the +;; local VC system and get things wrong... +;; Daniel Pittman <daniel@danann.net> +;;-(if (fboundp 'vc-call-backend) +;;- () ;; This is the new VC for which we don't have an appropriate advice yet +(if (fboundp 'vc-call-backend) + (defadvice vc-do-command + (around tramp-advice-vc-do-command + (buffer okstatus command file &rest flags) + activate) + "Invoke tramp-vc-do-command for tramp files." + (let ((file (symbol-value 'file))) ;pacify byte-compiler + (if (or (and (stringp file) (tramp-tramp-file-p file)) + (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name)))) + (setq ad-return-value + (apply 'tramp-vc-do-command-new buffer okstatus command + file ;(or file (buffer-file-name)) + flags)) + ad-do-it))) + (defadvice vc-do-command + (around tramp-advice-vc-do-command + (buffer okstatus command file last &rest flags) + activate) + "Invoke tramp-vc-do-command for tramp files." + (let ((file (symbol-value 'file))) ;pacify byte-compiler + (if (or (and (stringp file) (tramp-tramp-file-p file)) + (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name)))) + (setq ad-return-value + (apply 'tramp-vc-do-command buffer okstatus command + (or file (buffer-file-name)) last flags)) + ad-do-it)))) +;;-) + + +;; XEmacs uses this to do some of its work. Like vc-do-command, we +;; need to enhance it to make VC work via TRAMP-mode. +;; +;; Like the previous function, this is a cut-and-paste job from the VC +;; file. It's based on the vc-do-command code. +;; CCC: this isn't used in Emacs 21, so do as before. +(defun tramp-vc-simple-command (okstatus command file &rest args) + ;; Simple version of vc-do-command, for use in vc-hooks only. + ;; Don't switch to the *vc-info* buffer before running the + ;; command, because that would change its default directory + (save-match-data + (let* ((v (tramp-dissect-file-name (tramp-handle-expand-file-name file))) + (multi-method (tramp-file-name-multi-method v)) + (method (tramp-file-name-method v)) + (user (tramp-file-name-user v)) + (host (tramp-file-name-host v)) + (path (tramp-file-name-path v))) + (save-excursion (set-buffer (get-buffer-create "*vc-info*")) + (erase-buffer)) + (let ((exec-path (append vc-path exec-path)) exec-status + ;; Add vc-path to PATH for the execution of this command. + (process-environment + (cons (concat "PATH=" (getenv "PATH") + path-separator + (mapconcat 'identity vc-path path-separator)) + process-environment))) + ;; Call the actual process. See tramp-vc-do-command for discussion of + ;; why this does both (save-window-excursion) and (save-excursion). + ;; + ;; As a note, I don't think that the process-environment stuff above + ;; has any effect on the remote system. This is a hard one though as + ;; there is no real reason to expect local and remote paths to be + ;; identical... + ;; + ;; Daniel Pittman <daniel@danann.net> + (save-excursion + (save-window-excursion + ;; Actually execute remote command + (tramp-handle-shell-command + (mapconcat 'tramp-shell-quote-argument + (append (list command) args (list path)) " ") + (get-buffer-create"*vc-info*")) + ;(tramp-wait-for-output) + ;; Get status from command + (tramp-send-command multi-method method user host "echo $?") + (tramp-wait-for-output) + (setq exec-status (read (current-buffer))) + (message "Command %s returned status %d." command exec-status))) + + (cond ((> exec-status okstatus) + (switch-to-buffer (get-file-buffer file)) + (shrink-window-if-larger-than-buffer + (display-buffer "*vc-info*")) + (error "Couldn't find version control information"))) + exec-status)))) + +;; This function does not exist any more in Emacs-21's VC +(defadvice vc-simple-command + (around tramp-advice-vc-simple-command + (okstatus command file &rest args) + activate) + "Invoke tramp-vc-simple-command for tramp files." + (let ((file (symbol-value 'file))) ;pacify byte-compiler + (if (or (and (stringp file) (tramp-tramp-file-p file)) + (and (buffer-file-name) (tramp-tramp-file-p (buffer-file-name)))) + (setq ad-return-value + (apply 'tramp-vc-simple-command okstatus command + (or file (buffer-file-name)) args)) + ad-do-it))) + + +;; `vc-workfile-unchanged-p' +;; This function does not deal well with remote files, so we do the +;; same as for `vc-do-command'. + +;; `vc-workfile-unchanged-p' checks the modification time, we cannot +;; do that for remote files, so here's a version which relies on diff. +;; CCC: this one probably works for Emacs 21, too. +(defun tramp-vc-workfile-unchanged-p + (filename &optional want-differences-if-changed) + (if (fboundp 'vc-backend-diff) + ;; Old VC. Call `vc-backend-diff'. + (let ((status (funcall (symbol-function 'vc-backend-diff) + filename nil nil + (not want-differences-if-changed)))) + (zerop status)) + ;; New VC. Call `vc-default-workfile-unchanged-p'. + (vc-default-workfile-unchanged-p (vc-backend file) filename))) + +(defadvice vc-workfile-unchanged-p + (around tramp-advice-vc-workfile-unchanged-p + (filename &optional want-differences-if-changed) + activate) + "Invoke tramp-vc-workfile-unchanged-p for tramp files." + (if (and (stringp filename) + (tramp-tramp-file-p filename) + (not + (let ((v (tramp-dissect-file-name filename))) + (tramp-get-remote-perl (tramp-file-name-multi-method v) + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v))))) + (setq ad-return-value + (tramp-vc-workfile-unchanged-p filename want-differences-if-changed)) + ad-do-it)) + + +;; Redefine a function from vc.el -- allow tramp files. +;; `save-match-data' seems not to be required -- it isn't in +;; the original version, either. +;; CCC: this might need some work -- how does the Emacs 21 version +;; work, anyway? Does it work over ange-ftp? Hm. +(if (not (fboundp 'vc-backend-checkout)) + () ;; our replacement won't work and is unnecessary anyway +(defun vc-checkout (filename &optional writable rev) + "Retrieve a copy of the latest version of the given file." + ;; If ftp is on this system and the name matches the ange-ftp format + ;; for a remote file, the user is trying something that won't work. + (funcall (symbol-function 'vc-backend-checkout) filename writable rev) + (vc-resynch-buffer filename t t)) +) + + +;; Do we need to advise the vc-user-login-name function anyway? +;; This will return the correct login name for the owner of a +;; file. It does not deal with the default remote user name... +;; +;; That is, when vc calls (vc-user-login-name), we return the +;; local login name, something that may be different to the remote +;; default. +;; +;; The remote VC operations will occur as the user that we logged +;; in with however - not always the same as the local user. +;; +;; In the end, I did advise the function. This is because, well, +;; the thing didn't work right otherwise ;) +;; +;; Daniel Pittman <daniel@danann.net> + +(defun tramp-handle-vc-user-login-name (&optional uid) + "Return the default user name on the remote machine. +Whenever VC calls this function, `file' is bound to the file name +in question. If no uid is provided or the uid is equal to the uid +owning the file, then we return the user name given in the file name. + +This should only be called when `file' is bound to the +filename we are thinking about..." + ;; Pacify byte-compiler; this symbol is bound in the calling + ;; function. CCC: Maybe it would be better to move the + ;; boundness-checking into this function? + (let ((file (symbol-value 'file))) + (if (and uid (/= uid (nth 2 (file-attributes file)))) + (error "tramp-handle-vc-user-login-name cannot map a uid to a name") + (let* ((v (tramp-dissect-file-name (tramp-handle-expand-file-name file))) + (u (tramp-file-name-user v))) + (cond ((stringp u) u) + ((vectorp u) (elt u (1- (length u)))) + ((null u) (user-login-name)) + (t (error "tramp-handle-vc-user-login-name cannot cope!"))))))) + + +(defadvice vc-user-login-name + (around tramp-vc-user-login-name activate) + "Support for files on remote machines accessed by TRAMP." + ;; We rely on the fact that `file' is bound when this is called. + ;; This appears to be the case everywhere in vc.el and vc-hooks.el + ;; as of Emacs 20.5. + ;; + ;; CCC TODO there should be a real solution! Talk to Andre Spiegel + ;; about this. + (let ((file (when (boundp 'file) + (symbol-value 'file)))) ;pacify byte-compiler + (or (and (stringp file) + (tramp-tramp-file-p file) ; tramp file + (setq ad-return-value + (save-match-data + (tramp-handle-vc-user-login-name uid)))) ; get the owner name + ad-do-it))) ; else call the original + + +;; Determine the name of the user owning a file. +(defun tramp-file-owner (filename) + "Return who owns FILE (user name, as a string)." + (let ((v (tramp-dissect-file-name + (tramp-handle-expand-file-name filename)))) + (if (not (tramp-handle-file-exists-p filename)) + nil ; file cannot be opened + ;; file exists, find out stuff + (save-excursion + (tramp-send-command + (tramp-file-name-multi-method v) (tramp-file-name-method v) + (tramp-file-name-user v) (tramp-file-name-host v) + (format "%s -Lld %s" + (tramp-get-ls-command (tramp-file-name-multi-method v) + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v)) + (tramp-shell-quote-argument (tramp-file-name-path v)))) + (tramp-wait-for-output) + ;; parse `ls -l' output ... + ;; ... file mode flags + (read (current-buffer)) + ;; ... number links + (read (current-buffer)) + ;; ... uid (as a string) + (symbol-name (read (current-buffer))))))) + +;; Wire ourselves into the VC infrastructure... +;; This function does not exist any more in Emacs-21's VC +;; CCC: it appears that no substitute is needed for Emacs 21. +(defadvice vc-file-owner + (around tramp-vc-file-owner activate) + "Support for files on remote machines accessed by TRAMP." + (let ((filename (ad-get-arg 0))) + (or (and (tramp-file-name-p filename) ; tramp file + (setq ad-return-value + (save-match-data + (tramp-file-owner filename)))) ; get the owner name + ad-do-it))) ; else call the original + + +;; We need to make the version control software backend version +;; information local to the current buffer. This is because each TRAMP +;; buffer can (theoretically) have a different VC version and I am +;; *way* too lazy to try and push the correct value into each new +;; buffer. +;; +;; Remote VC costs will just have to be paid, at least for the moment. +;; Well, at least, they will right until I feel guilty about doing a +;; botch job here and fix it. :/ +;; +;; Daniel Pittman <daniel@danann.net> +;; CCC: this is probably still needed for Emacs 21. +(defun tramp-vc-setup-for-remote () + "Make the backend release variables buffer local. +This makes remote VC work correctly at the cost of some processing time." + (when (and (buffer-file-name) + (tramp-tramp-file-p (buffer-file-name))) + (make-local-variable 'vc-rcs-release) + (setq vc-rcs-release nil))) +(add-hook 'find-file-hooks 'tramp-vc-setup-for-remote t) + +;; No need to load this again if anyone asks. +(provide 'tramp-vc) + +;;; tramp-vc.el ends here