mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2025-12-23 22:20:24 -08:00
Code Issues Projects Releases Wiki Activity

* files.el (file-remote-p): Introduce optional parameter CONNECTED.

Browse source 
* net/tramp.el:
* net/tramp-ftp.el:
* net/tramp-smb.el:
* net/tramp-uu.el:
* net/trampver.el: Migrate to Tramp 2.1.

* net/tramp-cache.el:
* net/tramp-fish.el:
* net/tramp-gw.el: New Tramp packages.

* net/tramp-util.el:
* net/tramp-vc.el: Removed.

* net/ange-ftp.el: Add ange-ftp property to 'start-file-process
(ange-ftp-file-remote-p): Handle optional parameter CONNECTED.

* net/rcompile.el (remote-compile): Handle Tramp 2.1 arguments.

* progmodes/compile.el (compilation-start): Redefine
`start-process' temporarily when `default-directory' is remote.
Remove case of synchronous compilation, this won't happen ever.
(compilation-setup): Make local variable `comint-file-name-prefix'
for remote compilation.
This commit is contained in:
Michael Albinus 2007-07-08 18:03:20 +00:00
parent eaaa2b09e3
commit 00d6fd04d8
15 changed files with 6384 additions and 5757 deletions
Download patch file Download diff file Expand all files Collapse all files

28
lisp/ChangeLog
View file

@ -1,3 +1,31 @@
2007-07-08 Michael Albinus <michael.albinus@gmx.de>
* files.el (file-remote-p): Introduce optional parameter CONNECTED.
* net/tramp.el:
* net/tramp-ftp.el:
* net/tramp-smb.el:
* net/tramp-uu.el:
* net/trampver.el: Migrate to Tramp 2.1.
* net/tramp-cache.el:
* net/tramp-fish.el:
* net/tramp-gw.el: New Tramp packages.
* net/tramp-util.el:
* net/tramp-vc.el: Removed.
* net/ange-ftp.el: Add ange-ftp property to 'start-file-process
(ange-ftp-file-remote-p): Handle optional parameter CONNECTED.
* net/rcompile.el (remote-compile): Handle Tramp 2.1 arguments.
* progmodes/compile.el (compilation-start): Redefine
`start-process' temporarily when `default-directory' is remote.
Remove case of synchronous compilation, this won't happen ever.
(compilation-setup): Make local variable `comint-file-name-prefix'
for remote compilation.
2007-07-08 Martin Rudalics <rudalics@gmx.at>
* novice.el (disabled-command-function): Fit window to buffer to

12
lisp/files.el
View file

@ -727,17 +727,23 @@ This is an interface to the function `load'."
(cons load-path (get-load-suffixes)))))
(load library))
(defun file-remote-p (file)
(defun file-remote-p (file &optional connected)
"Test whether FILE specifies a location on a remote system.
Return an identification of the system if the location is indeed
remote. The identification of the system may comprise a method
to access the system and its hostname, amongst other things.
For example, the filename \"/user@host:/foo\" specifies a location
on the system \"/user@host:\"."
on the system \"/user@host:\".
If CONNECTED is non-nil, the function returns an identification only
if FILE is located on a remote system, and a connection is established
to that remote system.
`file-remote-p' will never open a connection on its own."
(let ((handler (find-file-name-handler file 'file-remote-p)))
(if handler
(funcall handler 'file-remote-p file)
(funcall handler 'file-remote-p file connected)
nil)))
(defun file-local-copy (file)

14
lisp/net/ange-ftp.el
View file

@ -4132,8 +4132,15 @@ directory, so that Emacs will know its current contents."
(format "Getting %s" fn1))
tmp1))))
(defun ange-ftp-file-remote-p (file)
(ange-ftp-replace-name-component file ""))
(defun ange-ftp-file-remote-p (file &optional connected)
(and (or (not connected)
(let* ((parsed (ange-ftp-ftp-name file))
(host (nth 0 parsed))
(user (nth 1 parsed))
(proc (get-process (ange-ftp-ftp-process-buffer host user))))
(and proc (processp proc)
(memq (process-status proc) '(run open)))))
(ange-ftp-replace-name-component file "")))
(defun ange-ftp-load (file &optional noerror nomessage nosuffix)
(if (ange-ftp-ftp-name file)
@ -4360,7 +4367,10 @@ NEWNAME should be the name to give the new compressed or uncompressed file.")
;; This returns nil for any file name as argument.
(put 'vc-registered 'ange-ftp 'null)
;; We can handle process-file in a restricted way (just for chown).
;; Nothing possible for start-file-process.
(put 'process-file 'ange-ftp 'ange-ftp-process-file)
(put 'start-file-process 'ange-ftp 'ignore)
(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
;;; Define ways of getting at unmodified Emacs primitives,

3
lisp/net/rcompile.el
View file

@ -188,8 +188,7 @@ See \\[compile]."
(when (featurep 'tramp)
(set (make-local-variable 'comint-file-name-prefix)
(funcall (symbol-function 'tramp-make-tramp-file-name)
nil ;; multi-method. To be removed with Tramp 2.1.
nil
nil ;; method.
remote-compile-user
remote-compile-host
""))))))

316
lisp/net/tramp-cache.el Normal file
View file

@ -0,0 +1,316 @@
;;; -*- mode: Emacs-Lisp; coding: iso-2022-7bit; -*-
;;; tramp-cache.el --- file information caching for Tramp
;; Copyright (C) 2000, 2005, 2006, 2007 by Free Software Foundation, Inc.
;; Author: Daniel Pittman <daniel@inanna.danann.net>
;; Michael Albinus <michael.albinus@gmx.de>
;; 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 3 of the License, 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, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;; An implementation of information caching for remote files.
;; Each connection, identified by a vector [method user host
;; localname] or by a process, has a unique cache. We distinguish 3
;; kind of caches, depending on the key:
;;
;; - localname is NIL. This are reusable properties. Examples:
;; "remote-shell" identifies the POSIX shell to be called on the
;; remote host, or "perl" is the command to be called on the remote
;; host, when starting a Perl script. These properties are saved in
;; the file `tramp-persistency-file-name'.
;;
;; - localname is a string. This are temporary properties, which are
;; related to the file localname is referring to. Examples:
;; "file-exists-p" is t or nile, depending on the file existence, or
;; "file-attributes" caches the result of the function
;; `file-attributes'.
;;
;; - The key is a process. This are temporary properties related to
;; an open connection. Examples: "scripts" keeps shell script
;; definitions already sent to the remote shell, "last-cmd-time" is
;; the time stamp a command has been sent to the remote process.
;;; Code:
;; Pacify byte-compiler.
(eval-when-compile
(require 'cl)
(autoload 'tramp-message "tramp")
(autoload 'tramp-tramp-file-p "tramp")
;; We cannot autoload macro `with-parsed-tramp-file-name', it
;; results in problems of byte-compiled code.
(autoload 'tramp-dissect-file-name "tramp")
(autoload 'tramp-file-name-method "tramp")
(autoload 'tramp-file-name-user "tramp")
(autoload 'tramp-file-name-host "tramp")
(autoload 'tramp-file-name-localname "tramp")
(autoload 'time-stamp-string "time-stamp"))
;;; -- Cache --
(defvar tramp-cache-data (make-hash-table :test 'equal)
"Hash table for remote files properties.")
(defcustom tramp-persistency-file-name
(cond
;; GNU Emacs.
((and (boundp 'user-emacs-directory)
(stringp (symbol-value 'user-emacs-directory))
(file-directory-p (symbol-value 'user-emacs-directory)))
(expand-file-name "tramp" (symbol-value 'user-emacs-directory)))
((and (not (featurep 'xemacs)) (file-directory-p "~/.emacs.d/"))
"~/.emacs.d/tramp")
;; XEmacs.
((and (boundp 'user-init-directory)
(stringp (symbol-value 'user-init-directory))
(file-directory-p (symbol-value 'user-init-directory)))
(expand-file-name "tramp" (symbol-value 'user-init-directory)))
((and (featurep 'xemacs) (file-directory-p "~/.xemacs/"))
"~/.xemacs/tramp")
;; For users without `~/.emacs.d/' or `~/.xemacs/'.
(t "~/.tramp"))
"File which keeps connection history for Tramp connections."
:group 'tramp
:type 'file)
(defun tramp-get-file-property (vec file property default)
"Get the PROPERTY of FILE from the cache context of VEC.
Returns DEFAULT if not set."
;; Unify localname.
(setq vec (copy-sequence vec))
(aset vec 3 (directory-file-name file))
(let* ((hash (or (gethash vec tramp-cache-data)
(puthash vec (make-hash-table :test 'equal)
tramp-cache-data)))
(value (if (hash-table-p hash)
(gethash property hash default)
default)))
(tramp-message vec 8 "%s %s %s" file property value)
value))
(defun tramp-set-file-property (vec file property value)
"Set the PROPERTY of FILE to VALUE, in the cache context of VEC.
Returns VALUE."
;; Unify localname.
(setq vec (copy-sequence vec))
(aset vec 3 (directory-file-name file))
(let ((hash (or (gethash vec tramp-cache-data)
(puthash vec (make-hash-table :test 'equal)
tramp-cache-data))))
(puthash property value hash)
(tramp-message vec 8 "%s %s %s" file property value)
value))
(defun tramp-flush-file-property (vec file)
"Remove all properties of FILE in the cache context of VEC."
;; Unify localname.
(setq vec (copy-sequence vec))
(aset vec 3 (directory-file-name file))
(tramp-message vec 8 "%s" file)
(remhash vec tramp-cache-data))
(defun tramp-flush-directory-property (vec directory)
"Remove all properties of DIRECTORY in the cache context of VEC.
Remove also properties of all files in subdirectories."
(let ((directory (directory-file-name directory)))
(tramp-message vec 8 "%s" directory)
(maphash
'(lambda (key value)
(when (and (stringp key)
(string-match directory (tramp-file-name-localname key)))
(remhash key tramp-cache-data)))
tramp-cache-data)))
(defun tramp-cache-print (table)
"Prints hash table TABLE."
(when (hash-table-p table)
(let (result tmp)
(maphash
'(lambda (key value)
(setq tmp (format
"(%s %s)"
(if (processp key)
(prin1-to-string (prin1-to-string key))
(prin1-to-string key))
(if (hash-table-p value)
(tramp-cache-print value)
(if (bufferp value)
(prin1-to-string (prin1-to-string value))
(prin1-to-string value))))
result (if result (concat result " " tmp) tmp)))
table)
result)))
;; Reverting or killing a buffer should also flush file properties.
;; They could have been changed outside Tramp.
(defun tramp-flush-file-function ()
"Flush all Tramp cache properties from buffer-file-name."
(let ((bfn (buffer-file-name)))
(when (and (stringp bfn) (tramp-tramp-file-p bfn))
(let* ((v (tramp-dissect-file-name bfn))
(localname (tramp-file-name-localname v)))
(tramp-flush-file-property v localname)))))
(add-hook 'before-revert-hook 'tramp-flush-file-function)
(add-hook 'kill-buffer-hook 'tramp-flush-file-function)
(add-hook 'tramp-cache-unload-hook
'(lambda ()
(remove-hook 'before-revert-hook
'tramp-flush-file-function)
(remove-hook 'kill-buffer-hook
'tramp-flush-file-function)))
;;; -- Properties --
(defun tramp-get-connection-property (key property default)
"Get the named PROPERTY for the connection.
KEY identifies the connection, it is either a process or a vector.
If the value is not set for the connection, returns DEFAULT."
;; Unify key by removing localname from vector. Work with a copy in
;; order to avoid side effects.
(when (vectorp key)
(setq key (copy-sequence key))
(aset key 3 nil))
(let* ((hash (gethash key tramp-cache-data))
(value (if (hash-table-p hash)
(gethash property hash default)
default)))
(tramp-message key 7 "%s %s" property value)
value))
(defun tramp-set-connection-property (key property value)
"Set the named PROPERTY of a connection to VALUE.
KEY identifies the connection, it is either a process or a vector.
PROPERTY is set persistent when KEY is a vector."
;; Unify key by removing localname from vector. Work with a copy in
;; order to avoid side effects.
(when (vectorp key)
(setq key (copy-sequence key))
(aset key 3 nil))
(let ((hash (or (gethash key tramp-cache-data)
(puthash key (make-hash-table :test 'equal)
tramp-cache-data))))
(puthash property value hash)
;; This function is called also during initialization of
;; tramp-cache.el. `tramp-message´ is not defined yet at this
;; time, so we ignore the corresponding error.
(condition-case nil
(tramp-message key 7 "%s %s" property value)
(error nil))
value))
(defun tramp-flush-connection-property (key event)
"Remove all properties identified by KEY.
KEY identifies the connection, it is either a process or a
vector. EVENT is not used, it is just applied because this
function is intended to run also as process sentinel."
;; Unify key by removing localname from vector. Work with a copy in
;; order to avoid side effects.
(when (vectorp key)
(setq key (copy-sequence key))
(aset key 3 nil))
; (tramp-message key 7 "%s" event)
(remhash key tramp-cache-data))
(defun tramp-dump-connection-properties ()
"Writes persistent connection properties into file
`tramp-persistency-file-name'."
;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed.
(condition-case nil
(when (and (hash-table-p tramp-cache-data)
(not (zerop (hash-table-count tramp-cache-data)))
(stringp tramp-persistency-file-name))
(let ((cache (copy-hash-table tramp-cache-data)))
;; Remove temporary data.
(maphash
'(lambda (key value)
(if (and (vectorp key) (not (tramp-file-name-localname key)))
(progn
(remhash "process-name" value)
(remhash "process-buffer" value))
(remhash key cache)))
cache)
;; Dump it.
(with-temp-buffer
(insert
";; -*- emacs-lisp -*-"
;; `time-stamp-string' might not exist in all (X)Emacs flavors.
(condition-case nil
(progn
(format
" <%s %s>\n"
(time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S")
tramp-persistency-file-name))
(error "\n"))
";; Tramp connection history. Don't change this file.\n"
";; You can delete it, forcing Tramp to reapply the checks.\n\n"
(with-output-to-string
(pp (read (format "(%s)" (tramp-cache-print cache))))))
(write-region
(point-min) (point-max) tramp-persistency-file-name))))
(error nil)))
(add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)
(add-hook 'tramp-cache-unload-hook
'(lambda ()
(remove-hook 'kill-emacs-hook
'tramp-dump-connection-properties)))
(defun tramp-parse-connection-properties (method)
"Return a list of (user host) tuples allowed to access for METHOD.
This function is added always in `tramp-get-completion-function'
for all methods. Resulting data are derived from connection
history."
(let (res)
(maphash
'(lambda (key value)
(if (and (vectorp key)
(string-equal method (tramp-file-name-method key))
(not (tramp-file-name-localname key)))
(push (list (tramp-file-name-user key)
(tramp-file-name-host key))
res)))
tramp-cache-data)
res))
;; Read persistent connection history. Applied with
;; `load-in-progress', because it shall be evaluated only once.
(when load-in-progress
(condition-case err
(with-temp-buffer
(insert-file-contents tramp-persistency-file-name)
(let ((list (read (current-buffer)))
element key item)
(while (setq element (pop list))
(setq key (pop element))
(while (setq item (pop element))
(tramp-set-connection-property key (pop item) (car item))))))
(file-error
;; Most likely because the file doesn't exist yet. No message.
(clrhash tramp-cache-data))
(error
;; File is corrupted.
(message "%s" (error-message-string err))
(clrhash tramp-cache-data))))
(provide 'tramp-cache)
;;; tramp-cache.el ends here

1176
lisp/net/tramp-fish.el Normal file
View file

File diff suppressed because it is too large Load diff

26
lisp/net/tramp-ftp.el
View file

@ -10,8 +10,8 @@
;; 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.
;; the Free Software Foundation; either version 3 of the License, 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
@ -19,9 +19,8 @@
;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
@ -110,10 +109,13 @@ present for backward compatibility."
(list "" "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))
;; Add completion function for FTP method.
(unless (memq system-type '(windows-nt))
(tramp-set-completion-function
tramp-ftp-method
'((tramp-parse-netrc "~/.netrc"))))
'((tramp-parse-netrc "~/.netrc")))
;; If there is URL syntax, `substitute-in-file-name' needs special
;; handling.
(put 'substitute-in-file-name 'ange-ftp 'tramp-handle-substitute-in-file-name)
(defun tramp-ftp-file-name-handler (operation &rest args)
"Invoke the Ange-FTP handler for OPERATION.
@ -152,13 +154,7 @@ pass to the OPERATION."
(defun tramp-ftp-file-name-p (filename)
"Check if it's a filename that should be forwarded to Ange-FTP."
(let ((v (tramp-dissect-file-name filename)))
(string=
(tramp-find-method
(tramp-file-name-multi-method v)
(tramp-file-name-method v)
(tramp-file-name-user v)
(tramp-file-name-host v))
tramp-ftp-method)))
(string= (tramp-file-name-method v) tramp-ftp-method)))
(add-to-list 'tramp-foreign-file-name-handler-alist
(cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))
@ -172,8 +168,6 @@ pass to the OPERATION."
;; pretended in `tramp-file-name-handler' otherwise.
;; Furthermore, there are no backup files on FTP hosts.
;; Worth further investigations.
;; * Map /multi:ssh:out@gate:ftp:kai@real.host:/path/to.file
;; on Ange-FTP gateways.
;;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff
;;; tramp-ftp.el ends here

324
lisp/net/tramp-gw.el Normal file
View file

@ -0,0 +1,324 @@
;;; -*- coding: iso-8859-1; -*-
;;; tramp-gw.el --- Tramp utility functions for HTTP tunnels and SOCKS gateways
;; Copyright (C) 2007 Free Software Foundation, Inc.
;; Author: Michael Albinus <michael.albinus@gmx.de>
;; 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 3 of the License, 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, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Access functions for HTTP tunnels and SOCKS gateways from Tramp.
;; SOCKS functionality is implemented by socks.el from the w3 package.
;; HTTP tunnels are partly implemented in socks.el and url-http.el;
;; both implementations are not complete. Therefore, it is
;; implemented in this package.
;;; Code:
(require 'tramp)
;; Pacify byte-compiler
(eval-when-compile
(require 'cl)
(require 'custom))
;; Autoload the socks library. It is used only when we access a SOCKS server.
(autoload 'socks-open-network-stream "socks")
(defvar socks-username (user-login-name))
(defvar socks-server (list "Default server" "socks" 1080 5))
;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
(eval-when-compile
(when (featurep 'xemacs)
(byte-compiler-options (warnings (- unused-vars)))))
;; Define HTTP tunnel method ...
(defvar tramp-gw-tunnel-method "tunnel"
"*Method to connect HTTP gateways.")
;; ... and port.
(defvar tramp-gw-default-tunnel-port 8080
"*Default port for HTTP gateways.")
;; Define SOCKS method ...
(defvar tramp-gw-socks-method "socks"
"*Method to connect SOCKS servers.")
;; ... and port.
(defvar tramp-gw-default-socks-port 1080
"*Default port for SOCKS servers.")
;; Add a default for `tramp-default-user-alist'. Default is the local user.
(add-to-list 'tramp-default-user-alist
`(,tramp-gw-tunnel-method nil ,(user-login-name)))
(add-to-list 'tramp-default-user-alist
`(,tramp-gw-socks-method nil ,(user-login-name)))
;; Internal file name functions and variables.
(defvar tramp-gw-vector nil
"Keeps the remote host identification. Needed for Tramp messages.")
(defvar tramp-gw-gw-vector nil
"Current gateway identification vector.")
(defvar tramp-gw-gw-proc nil
"Current gateway process.")
;; This variable keeps the listening process, in order to reuse it for
;; new processes.
(defvar tramp-gw-aux-proc nil
"Process listening on local port, as mediation between SSH and the gateway.")
(defun tramp-gw-gw-proc-sentinel (proc event)
"Delete auxiliary process when we are deleted."
(unless (memq (process-status proc) '(run open))
(tramp-message
tramp-gw-vector 4 "Deleting auxiliary process `%s'" tramp-gw-gw-proc)
(let* (tramp-verbose
(p (tramp-get-connection-property proc "process" nil)))
(when (processp p) (delete-process p)))))
(defun tramp-gw-aux-proc-sentinel (proc event)
"Activate the different filters for involved gateway and auxiliary processes."
(when (memq (process-status proc) '(run open))
;; A new process has been spawned from `tramp-gw-aux-proc'.
(tramp-message
tramp-gw-vector 4
"Opening auxiliary process `%s', speaking with process `%s'"
proc tramp-gw-gw-proc)
(tramp-set-process-query-on-exit-flag proc nil)
;; We don't want debug messages, because the corresponding debug
;; buffer might be undecided.
(let (tramp-verbose)
(tramp-set-connection-property tramp-gw-gw-proc "process" proc)
(tramp-set-connection-property proc "process" tramp-gw-gw-proc))
;; Set the process-filter functions for both processes.
(set-process-filter proc 'tramp-gw-process-filter)
(set-process-filter tramp-gw-gw-proc 'tramp-gw-process-filter)
;; There might be already some output from the gateway process.
(with-current-buffer (process-buffer tramp-gw-gw-proc)
(unless (= (point-min) (point-max))
(let ((s (buffer-string)))
(delete-region (point) (point-max))
(tramp-gw-process-filter tramp-gw-gw-proc s))))))
(defun tramp-gw-process-filter (proc string)
(let (tramp-verbose)
(process-send-string
(tramp-get-connection-property proc "process" nil) string)))
(defun tramp-gw-open-connection (vec gw-vec target-vec)
"Open a remote connection to VEC (see `tramp-file-name' structure).
Take GW-VEC as SOCKS or HTTP gateway, i.e. its method must be a
gateway method. TARGET-VEC identifies where to connect to via
the gateway, it can be different from VEC when there are more
hops to be applied.
It returns a string like \"localhost#port\", which must be used
instead of the host name declared in TARGET-VEC."
;; Remember vectors for property retrieval.
(setq tramp-gw-vector vec
tramp-gw-gw-vector gw-vec)
;; Start listening auxiliary process.
(unless (and (processp tramp-gw-aux-proc)
(memq (process-status tramp-gw-aux-proc) '(listen)))
(let ((aux-vec
(vector "aux" (tramp-file-name-user gw-vec)
(tramp-file-name-host gw-vec) nil)))
(setq tramp-gw-aux-proc
(make-network-process
:name (tramp-buffer-name aux-vec) :buffer nil :host 'local
:server t :noquery t :service t :coding 'binary))
(set-process-sentinel tramp-gw-aux-proc 'tramp-gw-aux-proc-sentinel)
(tramp-set-process-query-on-exit-flag tramp-gw-aux-proc nil)
(tramp-message
vec 4 "Opening auxiliary process `%s', listening on port %d"
tramp-gw-aux-proc (process-contact tramp-gw-aux-proc :service))))
(let* ((gw-method
(intern
(tramp-find-method
(tramp-file-name-method gw-vec)
(tramp-file-name-user gw-vec)
(tramp-file-name-host gw-vec))))
(socks-username
(tramp-find-user
(tramp-file-name-method gw-vec)
(tramp-file-name-user gw-vec)
(tramp-file-name-host gw-vec)))
;; Declare the SOCKS server to be used.
(socks-server
(list "Tramp tempory socks server list"
;; Host name.
(tramp-file-name-real-host gw-vec)
;; Port number.
(or (tramp-file-name-port gw-vec)
(case gw-method
(tunnel tramp-gw-default-tunnel-port)
(socks tramp-gw-default-socks-port)))
;; Type. We support only http and socks5, NO socks4.
;; 'http could be used when HTTP tunnel works in socks.el.
5))
;; The function to be called.
(socks-function
(case gw-method
(tunnel 'tramp-gw-open-network-stream)
(socks 'socks-open-network-stream)))
socks-noproxy)
;; Open SOCKS process.
(setq tramp-gw-gw-proc
(funcall
socks-function
(tramp-buffer-name gw-vec)
(tramp-get-buffer gw-vec)
(tramp-file-name-real-host target-vec)
(tramp-file-name-port target-vec)))
(set-process-sentinel tramp-gw-gw-proc 'tramp-gw-gw-proc-sentinel)
(tramp-set-process-query-on-exit-flag tramp-gw-gw-proc nil)
(tramp-message
vec 4 "Opened %s process `%s'"
(case gw-method ('tunnel "HTTP tunnel") ('socks "SOCKS"))
tramp-gw-gw-proc)
;; Return the new host for gateway access.
(format "localhost#%d" (process-contact tramp-gw-aux-proc :service))))
(defun tramp-gw-open-network-stream (name buffer host service)
"Open stream to proxy server HOST:SERVICE.
Resulting process has name NAME and buffer BUFFER. If
authentication is requested from proxy server, provide it."
(let ((command (format (concat
"CONNECT %s:%d HTTP/1.1\r\n"
"Host: %s:%d\r\n"
"Connection: keep-alive\r\n"
"User-Agent: Tramp/%s\r\n")
host service host service tramp-version))
(authentication "")
(first t)
found proc)
(while (not found)
;; Clean up.
(when (processp proc) (delete-process proc))
(with-current-buffer buffer (erase-buffer))
;; Open network stream.
(setq proc (open-network-stream
name buffer (nth 1 socks-server) (nth 2 socks-server)))
(set-process-coding-system proc 'binary 'binary)
(tramp-set-process-query-on-exit-flag proc nil)
;; Send CONNECT command.
(process-send-string proc (format "%s%s\r\n" command authentication))
(tramp-message
tramp-gw-vector 6 "\n%s"
(format
"%s%s\r\n" command
(replace-regexp-in-string ;; no password in trace!
"Basic [^\r\n]+" "Basic xxxxx" authentication t)))
(with-current-buffer buffer
;; Trap errors to be traced in the right trace buffer. Often,
;; proxies have a timeout of 60". We wait 65" in order to
;; receive an answer this case.
(condition-case nil
(let (tramp-verbose)
(tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))
(error nil))
;; Check return code.
(goto-char (point-min))
(narrow-to-region
(point-min)
(or (search-forward-regexp "\r?\n\r?\n" nil t) (point-max)))
(tramp-message tramp-gw-vector 6 "\n%s" (buffer-string))
(goto-char (point-min))
(search-forward-regexp "^HTTP/[1-9]\\.[0-9]" nil t)
(case (condition-case nil (read (current-buffer)) (error))
;; Connected.
(200 (setq found t))
;; We need basic authentication.
(401 (setq authentication (tramp-gw-basic-authentication nil first)))
;; Target host not found.
(404 (tramp-error-with-buffer
(current-buffer) tramp-gw-vector 'file-error
"Host %s not found." host))
;; We need basic proxy authentication.
(407 (setq authentication (tramp-gw-basic-authentication t first)))
;; Connection failed.
(503 (tramp-error-with-buffer
(current-buffer) tramp-gw-vector 'file-error
"Connection to %s:%d failed." host service))
;; That doesn't work at all.
(t (tramp-error-with-buffer
(current-buffer) tramp-gw-vector 'file-error
"Access to HTTP server %s:%d failed."
(nth 1 socks-server) (nth 2 socks-server))))
;; Remove HTTP headers.
(delete-region (point-min) (point-max))
(widen)
(setq first nil)))
;; Return the process.
proc))
(defun tramp-gw-basic-authentication (proxy pw-cache)
"Return authentication header for CONNECT, based on server request.
PROXY is an indication whether we need a Proxy-Authorization header
or an Authorization header. If PW-CACHE is non-nil, check for
password in password cache. This is done for the first try only."
;; `tramp-current-*' must be set for `tramp-read-passwd' and
;; `tramp-clear-passwd'.
(let ((tramp-current-method (tramp-file-name-method tramp-gw-gw-vector))
(tramp-current-user (tramp-file-name-user tramp-gw-gw-vector))
(tramp-current-host (tramp-file-name-host tramp-gw-gw-vector)))
(unless pw-cache (tramp-clear-passwd))
;; We are already in the right buffer.
(tramp-message
tramp-gw-vector 5 "%s required"
(if proxy "Proxy authentication" "Authentication"))
;; Search for request header. We accept only basic authentication.
(goto-char (point-min))
(search-forward-regexp
"^\\(Proxy\\|WWW\\)-Authenticate:\\s-*Basic\\s-+realm=")
;; Return authentication string.
(format
"%s: Basic %s\r\n"
(if proxy "Proxy-Authorization" "Authorization")
(base64-encode-string
(format
"%s:%s"
socks-username
(tramp-read-passwd
proc
(format
"Password for %s@[%s]: " socks-username (read (current-buffer)))))))))
(provide 'tramp-gw)
;;; TODO:
;; * Provide descriptive Commentary.
;; * Enable it for several gateway processes in parallel.
;;; arch-tag: fcc9dbec-7503-4d73-b638-3c8aa59575f5
;;; tramp-gw.el ends here

789
lisp/net/tramp-smb.el
View file

File diff suppressed because it is too large Load diff

138
lisp/net/tramp-util.el
View file

@ -1,138 +0,0 @@
;;; -*- coding: iso-2022-7bit; -*-
;;; tramp-util.el --- Misc utility functions to use with Tramp
;; Copyright (C) 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007 Free Software Foundation, Inc.
;; Author: kai.grossjohann@gmx.net
;; Keywords: comm, extensions, processes
;; This file 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.
;; This file 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Some misc. utility functions that might go nicely with Tramp.
;; Mostly, these are kluges awaiting real solutions later on.
;;; Code:
(require 'compile)
(require 'tramp)
(add-hook 'tramp-util-unload-hook
'(lambda ()
(when (featurep 'tramp)
(unload-feature 'tramp 'force))))
;; Define a Tramp minor mode. It's intention is to redefine some keys for Tramp
;; specific functions, like compilation.
;; The key remapping works since Emacs 22 only. Unknown for XEmacs.
;; Pacify byte-compiler
(eval-when-compile
(unless (fboundp 'define-minor-mode)
(defalias 'define-minor-mode 'identity)
(defvar tramp-minor-mode))
(unless (featurep 'xemacs)
(defalias 'add-menu-button 'ignore)))
(defvar tramp-minor-mode-map (make-sparse-keymap)
"Keymap for Tramp minor mode.")
(define-minor-mode tramp-minor-mode "Tramp minor mode for utility functions."
:group 'tramp
:global nil
:init-value nil
:lighter " Tramp"
:keymap tramp-minor-mode-map
(setq tramp-minor-mode
(and tramp-minor-mode (tramp-tramp-file-p default-directory))))
(add-hook 'find-file-hooks 'tramp-minor-mode t)
(add-hook 'tramp-util-unload-hook
'(lambda ()
(remove-hook 'find-file-hooks 'tramp-minor-mode)))
(add-hook 'dired-mode-hook 'tramp-minor-mode t)
(add-hook 'tramp-util-unload-hook
'(lambda ()
(remove-hook 'dired-mode-hook 'tramp-minor-mode)))
(defun tramp-remap-command (old-command new-command)
"Replaces bindings of OLD-COMMAND by NEW-COMMAND.
If remapping functionality for keymaps is defined, this happens for all
bindings. Otherwise, only bindings active during invocation are taken
into account. XEmacs menubar bindings are not changed by this."
(if (functionp 'command-remapping)
;; Emacs 22
(eval
`(define-key tramp-minor-mode-map [remap ,old-command] new-command))
;; previous Emacs versions.
(mapcar
'(lambda (x)
(define-key tramp-minor-mode-map x new-command))
(where-is-internal old-command))))
(tramp-remap-command 'compile 'tramp-compile)
(tramp-remap-command 'recompile 'tramp-recompile)
;; XEmacs has an own mimic for menu entries
(when (fboundp 'add-menu-button)
(funcall 'add-menu-button
'("Tools" "Compile")
["Compile..."
(command-execute (if tramp-minor-mode 'tramp-compile 'compile))
:active (fboundp 'compile)])
(funcall 'add-menu-button
'("Tools" "Compile")
["Repeat Compilation"
(command-execute (if tramp-minor-mode 'tramp-recompile 'recompile))
:active (fboundp 'compile)]))
;; Utility functions.
(defun tramp-compile (command)
"Compile on remote host."
(interactive
(if (or compilation-read-command current-prefix-arg)
(list (read-from-minibuffer "Compile command: "
compile-command nil nil
'(compile-history . 1)))
(list compile-command)))
(setq compile-command command)
(save-some-buffers (not compilation-ask-about-save) nil)
(let ((d default-directory))
(save-excursion
(pop-to-buffer (get-buffer-create "*Compilation*") t)
(erase-buffer)
(setq default-directory d)))
(tramp-handle-shell-command command (get-buffer "*Compilation*"))
(pop-to-buffer (get-buffer "*Compilation*"))
(tramp-minor-mode 1)
(compilation-minor-mode 1))
(defun tramp-recompile ()
"Re-compile on remote host."
(interactive)
(save-some-buffers (not compilation-ask-about-save) nil)
(tramp-handle-shell-command compile-command (get-buffer "*Compilation*"))
(pop-to-buffer (get-buffer "*Compilation*"))
(tramp-minor-mode 1)
(compilation-minor-mode 1))
(provide 'tramp-util)
;;; arch-tag: 500f9992-a44e-46d0-83a7-980799251808
;;; tramp-util.el ends here

9
lisp/net/tramp-uu.el
View file

@ -9,8 +9,8 @@
;; This file 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.
;; the Free Software Foundation; either version 3 of the License, or
;; (at your option) any later version.
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
@ -18,9 +18,8 @@
;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Commentary:

536
lisp/net/tramp-vc.el
View file

@ -1,536 +0,0 @@
;;; tramp-vc.el --- Version control integration for TRAMP.el
;; Copyright (C) 2000, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, 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:
(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)
;; Avoid byte-compiler warnings if the byte-compiler supports this.
;; Currently, XEmacs supports this.
(eval-when-compile
(when (fboundp 'byte-compiler-options)
(let (unused-vars) ; Pacify Emacs byte-compiler
(defalias 'warnings 'identity) ; Pacify Emacs byte-compiler
(byte-compiler-options (warnings (- unused-vars))))))
;; -- 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 (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 (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))
(localname (tramp-file-name-localname 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-localname
(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
;; `shell-command' cannot be used; it isn't magic in XEmacs.
(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 (integerp 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)
; Pacify byte-compiler
(funcall (symbol-function '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)))
(localname (when file (tramp-file-name-localname v))))
(setq squeezed (delq nil (copy-sequence flags)))
(when file
(setq squeezed (append squeezed (list (file-relative-name
file default-directory)))))
(let ((w32-quote-process-args t))
(when (eq okstatus 'async)
(message "Tramp doesn't do async commands, running synchronously."))
;; `shell-command' cannot be used; it isn't magic in XEmacs.
(setq status (tramp-handle-shell-command
(mapconcat 'tramp-shell-quote-argument
(cons command squeezed) " ") t))
(when (or (not (integerp status))
(and (integerp 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))
; Pacify byte-compiler
(funcall (symbol-function 'vc-exec-after)
`(run-hook-with-args
'vc-post-command-functions ',command ',localname ',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
;;-)
(unless (fboundp 'process-file)
(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))))
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-do-command))))
;; 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 (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))
(localname (tramp-file-name-localname 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
;; `shell-command' cannot be used; it isn't magic in XEmacs.
(tramp-handle-shell-command
(mapconcat 'tramp-shell-quote-argument
(append (list command) args (list localname)) " ")
(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)))
;; Maybe okstatus can be `async' here. But then, maybe the
;; async thing is new in Emacs 21, but this function is only
;; used in Emacs 20.
(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)))
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-simple-command)))
;; `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'.
(funcall (symbol-function 'vc-default-workfile-unchanged-p)
(vc-backend filename) 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)))
;; The following check is probably to test whether
;; file-attributes returns correct last modification
;; times. This check needs to be changed.
(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))
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-workfile-unchanged-p)))
;; 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))
(remote-uid
;; With Emacs 22, `file-attributes' has got an optional parameter
;; ID-FORMAT. Handle this case backwards compatible.
(if (and (functionp 'subr-arity)
(= 2 (cdr (funcall (symbol-function 'subr-arity)
(symbol-function 'file-attributes)))))
(nth 2 (file-attributes file 'integer))
(nth 2 (file-attributes file)))))
(if (and uid (/= uid remote-uid))
(error "tramp-handle-vc-user-login-name cannot map a uid to a name")
(let* ((v (tramp-dissect-file-name (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!")))))))
;; The following defadvice is no longer necessary after changes in VC
;; on 2006-01-25, Andre.
(unless (fboundp 'process-file)
(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.
;;
;; With Emacs 22, the definition of `vc-user-login-name' has been
;; changed. It doesn't need to be adviced any longer.
(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
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-user-login-name))))
;; 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
(expand-file-name filename))))
(if (not (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-localname 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
(add-hook 'tramp-unload-hook
'(lambda () (ad-unadvise 'vc-file-owner)))
;; 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)
(add-hook 'tramp-unload-hook
'(lambda ()
(remove-hook 'find-file-hooks 'tramp-vc-setup-for-remote)))
;; No need to load this again if anyone asks.
(provide 'tramp-vc)
;;; arch-tag: 27cc42ce-da19-468d-ad5c-a2690558db60
;;; tramp-vc.el ends here

7044
lisp/net/tramp.el
View file

File diff suppressed because it is too large Load diff

18
lisp/net/trampver.el
View file

@ -11,8 +11,8 @@
;; 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.
;; the Free Software Foundation; either version 3 of the License, 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
@ -20,22 +20,26 @@
;; 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., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;; along with GNU Emacs; see the file COPYING. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Code:
;; In the Tramp CVS repository, the version numer and the bug report address
;; are auto-frobbed from configure.ac, so you should edit that file and run
;; "autoconf && ./configure" to change them.
;; "autoconf && ./configure" to change them. (X)Emacs version check is defined
;; in macro AC_EMACS_INFO of aclocal.m4; should be changed only there.
(defconst tramp-version "2.0.56"
(defconst tramp-version "2.1.10-pre"
"This version of Tramp.")
(defconst tramp-bug-report-address "tramp-devel@gnu.org"
"Email address to send bug reports to.")
;; Check for (X)Emacs version.
(let ((x (if (or (< emacs-major-version 21) (and (featurep 'xemacs) (< emacs-minor-version 4))) (format "Tramp 2.1.10-pre is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version)))) "ok")))
(unless (string-match "\\`ok\\'" x) (error x)))
(provide 'trampver)
;;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1

48
lisp/progmodes/compile.el
View file

@ -1075,7 +1075,8 @@ Returns the compilation buffer created."
(unless (getenv "EMACS")
(list "EMACS=t"))
(list "INSIDE_EMACS=t")
(copy-sequence process-environment))))
(copy-sequence process-environment)))
(start-process (symbol-function 'start-process)))
(set (make-local-variable 'compilation-arguments)
(list command mode name-function highlight-regexp))
(set (make-local-variable 'revert-buffer-function)
@ -1090,13 +1091,23 @@ Returns the compilation buffer created."
(if compilation-process-setup-function
(funcall compilation-process-setup-function))
(compilation-set-window-height outwin)
;; Redefine temporarily `start-process' in order to handle
;; remote compilation.
(fset 'start-process
(lambda (name buffer program &rest program-args)
(apply
(if (file-remote-p default-directory)
'start-file-process
start-process)
name buffer program program-args)))
;; Start the compilation.
(if (fboundp 'start-process)
(unwind-protect
(let ((proc (if (eq mode t)
(get-buffer-process
(with-no-warnings
(comint-exec outbuf (downcase mode-name)
shell-file-name nil `("-c" ,command))))
shell-file-name nil
`("-c" ,command))))
(start-process-shell-command (downcase mode-name)
outbuf command))))
;; Make the buffer's mode line show process state.
@ -1111,33 +1122,8 @@ Returns the compilation buffer created."
(error nil)))
(setq compilation-in-progress
(cons proc compilation-in-progress)))
;; No asynchronous processes available.
(message "Executing `%s'..." command)
;; Fake modeline display as if `start-process' were run.
(setq mode-line-process ":run")
(force-mode-line-update)
(sit-for 0) ; Force redisplay
(let* ((buffer-read-only nil) ; call-process needs to modify outbuf
(status (call-process shell-file-name nil outbuf nil "-c"
command)))
(cond ((numberp status)
(compilation-handle-exit 'exit status
(if (zerop status)
"finished\n"
(format "\
exited abnormally with code %d\n"
status))))
((stringp status)
(compilation-handle-exit 'signal status
(concat status "\n")))
(t
(compilation-handle-exit 'bizarre status status))))
;; Without async subprocesses, the buffer is not yet
;; fontified, so fontify it now.
(let ((font-lock-verbose nil)) ; shut up font-lock messages
(font-lock-fontify-buffer))
(set-buffer-modified-p nil)
(message "Executing `%s'...done" command)))
;; Unwindform: Reset original definition of `start-process'
(fset 'start-process start-process)))
;; Now finally cd to where the shell started make/grep/...
(setq default-directory thisdir))
(if (buffer-local-value 'compilation-scroll-output outbuf)
@ -1371,6 +1357,8 @@ Optional argument MINOR indicates this is called from
;; with the next-error function in simple.el, and it's only
;; coincidentally named similarly to compilation-next-error.
(setq next-error-function 'compilation-next-error-function)
(set (make-local-variable 'comint-file-name-prefix)
(or (file-remote-p default-directory) ""))
(set (make-local-variable 'font-lock-extra-managed-props)
'(directory message help-echo mouse-face debug))
(set (make-local-variable 'compilation-locs)