diff options
Diffstat (limited to 'lisp/net')
55 files changed, 7935 insertions, 8158 deletions
diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index c009671ce7c..3ed356a8d8d 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -676,6 +676,7 @@ "Accessing remote files and directories using FTP made as simple and transparent as possible." :group 'files + :group 'comm :prefix "ange-ftp-") (defcustom ange-ftp-name-format @@ -721,6 +722,7 @@ parenthesized expressions in REGEXP for the components (in that order)." "^Data connection \\|" "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|" "^500 .*AUTH\\|^KERBEROS\\|" + "^504 Unknown security mechanism\\|" "^530 Please login with USER and PASS\\|" ; non kerberised vsFTPd "^534 Kerberos Authentication not enabled\\|" "^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT") @@ -1733,7 +1735,10 @@ good, skip, fatal, or unknown." ange-ftp-gateway-tmp-name-template ange-ftp-tmp-name-template))) -(defalias 'ange-ftp-del-tmp-name 'delete-file) +(defun ange-ftp-del-tmp-name (filename) + "Force to delete temporary file." + (delete-file filename)) + ;;;; ------------------------------------------------------------ ;;;; Interactive gateway program support. @@ -3503,8 +3508,9 @@ system TYPE.") (file-exists-p file) (ange-ftp-real-file-executable-p file)))) -(defun ange-ftp-delete-file (file) - (interactive "fDelete file: ") +(defun ange-ftp-delete-file (file &optional trash) + (interactive (list (read-file-name "Delete file: " nil default-directory) + (null current-prefix-arg))) (setq file (expand-file-name file)) (let ((parsed (ange-ftp-ftp-name file))) (if parsed @@ -3522,7 +3528,7 @@ system TYPE.") (format "FTP Error: \"%s\"" (cdr result)) file))) (ange-ftp-delete-file-entry file)) - (ange-ftp-real-delete-file file)))) + (ange-ftp-real-delete-file file trash)))) (defun ange-ftp-file-modtime (file) "Return the modification time of remote file FILE. @@ -3826,7 +3832,8 @@ so return the size on the remote host exactly. See RFC 3659." (ange-ftp-call-cont cont result line))) (defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists - keep-date preserve-uid-gid) + keep-date preserve-uid-gid + preserve-selinux-context) (interactive "fCopy file: \nFCopy %s to file: \np") (ange-ftp-copy-file-internal filename newname @@ -4894,7 +4901,7 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") ;; ;; This is the Unix dl version. ;; (let ((opoint (point)) ;; case-fold-search hidden) -;; (or eol (setq eol (save-excursion (end-of-line) (point)))) +;; (or eol (setq eol (line-end-position))) ;; (setq hidden (and selective-display ;; (save-excursion ;; (search-forward "\r" eol t)))) @@ -5293,7 +5300,7 @@ Other orders of $ and _ seem to all work just fine.") ;; ;; This is the VMS version. ;; (let (opoint hidden case-fold-search) ;; (setq opoint (point)) -;; (or eol (setq eol (save-excursion (end-of-line) (point)))) +;; (or eol (setq eol (line-end-position))) ;; (setq hidden (and selective-display ;; (save-excursion (search-forward "\r" eol t)))) ;; (if hidden @@ -5651,7 +5658,7 @@ Other orders of $ and _ seem to all work just fine.") ;; ;; This is the MTS version. ;; (let (opoint hidden case-fold-search) ;; (setq opoint (point) -;; eol (save-excursion (end-of-line) (point)) +;; eol (line-end-position) ;; hidden (and selective-display ;; (save-excursion (search-forward "\r" eol t)))) ;; (if hidden @@ -5872,7 +5879,7 @@ Other orders of $ and _ seem to all work just fine.") ;; ;; This is the CMS version. ;; (let ((opoint (point)) ;; case-fold-search hidden) -;; (or eol (setq eol (save-excursion (end-of-line) (point)))) +;; (or eol (setq eol (line-end-position))) ;; (setq hidden (and selective-display ;; (save-excursion ;; (search-forward "\r" eol t)))) @@ -6146,5 +6153,4 @@ be recognized automatically (they are all valid BS2000 hosts too)." (provide 'ange-ftp) -;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316 ;;; ange-ftp.el ends here diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 14d58cf4466..bcf1a506f7a 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -204,26 +204,24 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Variables -(eval-when-compile (require 'cl) - (require 'thingatpt) - (require 'term) - (require 'dired) - (require 'executable) - (require 'w3-auto nil t)) +(eval-when-compile (require 'cl)) (defgroup browse-url nil "Use a web browser to look at a URL." :prefix "browse-url-" :link '(emacs-commentary-link "browse-url") - :group 'hypermedia) + :group 'external + :group 'comm) ;;;###autoload (defcustom browse-url-browser-function (cond ((memq system-type '(windows-nt ms-dos cygwin)) 'browse-url-default-windows-browser) - ((memq system-type '(darwin)) 'browse-url-default-macosx-browser) - (t 'browse-url-default-browser)) + ((memq system-type '(darwin)) + 'browse-url-default-macosx-browser) + (t + 'browse-url-default-browser)) "Function to display the current buffer in a WWW browser. This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. @@ -263,7 +261,19 @@ regexp should probably be \".\" to specify a default browser." (function :tag "Your own function") (alist :tag "Regexp/function association list" :key-type regexp :value-type function)) - :version "21.1" + :version "24.1" + :group 'browse-url) + +(defcustom browse-url-mailto-function 'browse-url-mail + "Function to display mailto: links. +This variable uses the same syntax as the +`browse-url-browser-function' variable. If the +`browse-url-mailto-function' variable is nil, that variable will +be used instead." + :type '(choice + (function-item :tag "Emacs Mail" :value browse-url-mail) + (function-item :tag "None" nil)) + :version "24.1" :group 'browse-url) (defcustom browse-url-netscape-program "netscape" @@ -312,8 +322,11 @@ Defaults to the value of `browse-url-mozilla-arguments' at the time :type '(repeat (string :tag "Argument")) :group 'browse-url) -;;;###autoload -(defcustom browse-url-firefox-program (purecopy "firefox") +(defcustom browse-url-firefox-program + (let ((candidates '("firefox" "iceweasel"))) + (while (and candidates (not (executable-find (car candidates)))) + (setq candidates (cdr candidates))) + (or (car candidates) "firefox")) "The name by which to invoke Firefox." :type 'string :group 'browse-url) @@ -330,8 +343,7 @@ Defaults to the value of `browse-url-firefox-arguments' at the time :type '(repeat (string :tag "Argument")) :group 'browse-url) -;;;###autoload -(defcustom browse-url-galeon-program (purecopy "galeon") +(defcustom browse-url-galeon-program "galeon" "The name by which to invoke Galeon." :type 'string :group 'browse-url) @@ -604,7 +616,7 @@ down (this *won't* always work)." :group 'browse-url) (defcustom browse-url-elinks-wrapper '("xterm" "-e") - "*Wrapper command prepended to the Elinks command-line." + "Wrapper command prepended to the Elinks command-line." :type '(repeat (string :tag "Wrapper")) :group 'browse-url) @@ -636,7 +648,6 @@ regarding its parameter treatment." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL input -;;;###autoload (defun browse-url-url-at-point () (let ((url (thing-at-point 'url))) (set-text-properties 0 (length url) nil url) @@ -752,6 +763,9 @@ narrowed." (add-hook 'kill-buffer-hook 'browse-url-delete-temp-file) +(declare-function dired-get-filename "dired" + (&optional localp no-error-if-not-filep)) + ;;;###autoload (defun browse-url-of-dired-file () "In Dired, ask a WWW browser to display the file named on this line." @@ -776,22 +790,27 @@ narrowed." (defun browse-url (url &rest args) "Ask a WWW browser to load URL. Prompts for a URL, defaulting to the URL at or before point. Variable -`browse-url-browser-function' says which browser to use." +`browse-url-browser-function' says which browser to use. +If the URL is a mailto: URL, consult `browse-url-mailto-function' +first, if that exists." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) - (let ((process-environment (copy-sequence process-environment))) + (let ((process-environment (copy-sequence process-environment)) + (function (or (and (string-match "\\`mailto:" url) + browse-url-mailto-function) + browse-url-browser-function))) ;; When connected to various displays, be careful to use the display of ;; the currently selected frame, rather than the original start display, ;; which may not even exist any more. (if (stringp (frame-parameter (selected-frame) 'display)) (setenv "DISPLAY" (frame-parameter (selected-frame) 'display))) - (if (and (consp browse-url-browser-function) - (not (functionp browse-url-browser-function))) + (if (and (consp function) + (not (functionp function))) ;; The `function' can be an alist; look down it for first match ;; and apply the function (which might be a lambda). (catch 'done - (dolist (bf browse-url-browser-function) + (dolist (bf function) (when (string-match (car bf) url) (apply (cdr bf) url args) (throw 'done t))) @@ -799,7 +818,7 @@ Prompts for a URL, defaulting to the URL at or before point. Variable url)) ;; Unbound symbols go down this leg, since void-function from ;; apply is clearer than wrong-type-argument from dolist. - (apply browse-url-browser-function url args)))) + (apply function url args)))) ;;;###autoload (defun browse-url-at-point (&optional arg) @@ -872,7 +891,6 @@ one showing the selected frame." (and (not (equal display (getenv "DISPLAY"))) display))) -;;;###autoload (defun browse-url-default-browser (url &rest args) "Find a suitable browser and ask it to load URL. Default to the URL around or before point. @@ -889,6 +907,7 @@ The order attempted is gnome-moz-remote, Mozilla, Firefox, Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3." (apply (cond + ((browse-url-can-use-xdg-open) 'browse-url-xdg-open) ((executable-find browse-url-gnome-moz-program) 'browse-url-gnome-moz) ((executable-find browse-url-mozilla-program) 'browse-url-mozilla) ((executable-find browse-url-firefox-program) 'browse-url-firefox) @@ -902,6 +921,38 @@ Galeon, Konqueror, Netscape, Mosaic, Lynx in an xterm, and then W3." (lambda (&rest ignore) (error "No usable browser found")))) url args)) +(defun browse-url-can-use-xdg-open () + "Check if xdg-open can be used, i.e. we are on Gnome, KDE or xfce4." + (and (getenv "DISPLAY") + (executable-find "xdg-open") + ;; xdg-open may call gnome-open and that does not wait for its child + ;; to finish. This child may then be killed when the parent dies. + ;; Use nohup to work around. + (executable-find "nohup") + (or (getenv "GNOME_DESKTOP_SESSION_ID") + ;; GNOME_DESKTOP_SESSION_ID is deprecated, check on Dbus also. + (condition-case nil + (eq 0 (call-process + "dbus-send" nil nil nil + "--dest=org.gnome.SessionManager" + "--print-reply" + "/org/gnome/SessionManager" + "org.gnome.SessionManager.CanShutdown")) + (error nil)) + (equal (getenv "KDE_FULL_SESSION") "true") + (condition-case nil + (eq 0 (call-process + "/bin/sh" nil nil nil + "-c" + "xprop -root _DT_SAVE_MODE|grep xfce4")) + (error nil))))) + + +;;;###autoload +(defun browse-url-xdg-open (url &optional new-window) + (interactive (browse-url-interactive-arg "URL: ")) + (call-process "nohup" nil nil nil "xdg-open" url)) + ;;;###autoload (defun browse-url-netscape (url &optional new-window) "Ask the Netscape WWW browser to load URL. @@ -1347,6 +1398,10 @@ with possible additional arguments `browse-url-xterm-args'." ;; --- Lynx in an Emacs "term" window --- +(declare-function term-char-mode "term" ()) +(declare-function term-send-down "term" ()) +(declare-function term-send-string "term" (proc str)) + ;;;###autoload (defun browse-url-text-emacs (url &optional new-buffer) "Ask a text browser to load URL. @@ -1367,6 +1422,7 @@ used instead of `browse-url-new-window-flag'." (buf (get-buffer "*text browser*")) (proc (and buf (get-buffer-process buf))) (n browse-url-text-input-attempts)) + (require 'term) (if (and (browse-url-maybe-new-window new-buffer) buf) ;; Rename away the OLD buffer. This isn't very polite, but ;; term insists on working in a buffer named *lynx* and would @@ -1439,20 +1495,27 @@ used instead of `browse-url-new-window-flag'." (to (assoc "To" alist)) (subject (assoc "Subject" alist)) (body (assoc "Body" alist)) - (rest (delete to (delete subject (delete body alist)))) + (rest (delq to (delq subject (delq body alist)))) (to (cdr to)) (subject (cdr subject)) (body (cdr body)) (mail-citation-hook (unless body mail-citation-hook))) (if (browse-url-maybe-new-window new-window) (compose-mail-other-window to subject rest nil - (if body - (list 'insert body) - (list 'insert-buffer (current-buffer)))) + (list 'insert-buffer (current-buffer))) (compose-mail to subject rest nil nil - (if body - (list 'insert body) - (list 'insert-buffer (current-buffer)))))))) + (list 'insert-buffer (current-buffer)))) + (when body + (goto-char (point-min)) + (unless (or (search-forward (concat "\n" mail-header-separator "\n") + nil 'move) + (bolp)) + (insert "\n")) + (goto-char (prog1 + (point) + (insert (replace-regexp-in-string "\r\n" "\n" body)) + (unless (bolp) + (insert "\n")))))))) ;; --- Random browser --- @@ -1531,5 +1594,4 @@ from `browse-url-elinks-wrapper'." (provide 'browse-url) -;; arch-tag: d2079573-5c06-4097-9598-f550fba19430 ;;; browse-url.el ends here diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 941fdc09f1d..ca1a1743231 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -39,6 +39,7 @@ (declare-function dbus-method-error-internal "dbusbind.c") (declare-function dbus-register-signal "dbusbind.c") (declare-function dbus-register-method "dbusbind.c") +(declare-function dbus-send-signal "dbusbind.c") (defvar dbus-debug) (defvar dbus-registered-objects-table) @@ -91,12 +92,10 @@ (defmacro dbus-ignore-errors (&rest body) "Execute BODY; signal D-Bus error when `dbus-debug' is non-nil. Otherwise, return result of last form in BODY, or all other errors." + (declare (indent 0) (debug t)) `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) - -(put 'dbus-ignore-errors 'lisp-indent-function 0) -(put 'dbus-ignore-errors 'edebug-form-spec '(form body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) (defvar dbus-event-error-hooks nil @@ -107,15 +106,12 @@ catched in `condition-case' by `dbus-error'.") ;;; Hash table of registered functions. -;; We create it here. So we have a simple test in dbusbind.c, whether -;; the Lisp code has been loaded. -(setq dbus-registered-objects-table (make-hash-table :test 'equal)) - (defvar dbus-return-values-table (make-hash-table :test 'equal) "Hash table for temporary storing arguments of reply messages. -A key in this hash table is a list (BUS SERIAL). BUS is either the -symbol `:system' or the symbol `:session'. SERIAL is the serial number -of the reply message. See `dbus-call-method-non-blocking-handler' and +A key in this hash table is a list (BUS SERIAL). BUS is either a +Lisp symbol, `:system' or `:session', or a string denoting the +bus address. SERIAL is the serial number of the reply message. +See `dbus-call-method-non-blocking-handler' and `dbus-call-method-non-blocking'.") (defun dbus-list-hash-table () @@ -186,8 +182,19 @@ association to the service from D-Bus." (defun dbus-unregister-service (bus service) "Unregister all objects related to SERVICE from D-Bus BUS. -BUS must be either the symbol `:system' or the symbol `:session'. -SERVICE must be a known service name." +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. SERVICE must be a known service name. + +The function returns a keyword, indicating the result of the +operation. One of the following keywords is returned: + +`:released': Service has become the primary owner of the name. + +`:non-existent': Service name does not exist on this bus. + +`:not-owner': We are neither the primary owner nor waiting in the +queue of this service." + (maphash (lambda (key value) (dolist (elt value) @@ -197,9 +204,14 @@ SERVICE must be a known service name." (puthash key (delete elt value) dbus-registered-objects-table) (remhash key dbus-registered-objects-table)))))) dbus-registered-objects-table) - (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "ReleaseName" service)) + (let ((reply (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "ReleaseName" service))) + (case reply + (1 :released) + (2 :non-existent) + (3 :not-owner) + (t (signal 'dbus-error (list "Could not unregister service" service)))))) (defun dbus-call-method-non-blocking-handler (&rest args) "Handler for reply messages of asynchronous D-Bus message calls. @@ -243,7 +255,7 @@ This handler is applied when a \"NameOwnerChanged\" signal has arrived. SERVICE is the object name for which the name owner has been changed. OLD-OWNER is the previous owner of SERVICE, or the empty string if SERVICE was not owned yet. NEW-OWNER is the new -owner of SERVICE, or the empty string if SERVICE looses any name owner. +owner of SERVICE, or the empty string if SERVICE loses any name owner. usage: (dbus-name-owner-changed-handler service old-owner new-owner)" (save-match-data @@ -352,15 +364,15 @@ EVENT is a list which starts with symbol `dbus-event': (dbus-event BUS TYPE SERIAL SERVICE PATH INTERFACE MEMBER HANDLER &rest ARGS) BUS identifies the D-Bus the message is coming from. It is -either the symbol `:system' or the symbol `:session'. TYPE is -the D-Bus message type which has caused the event, SERIAL is the -serial number of the received D-Bus message. SERVICE and PATH -are the unique name and the object path of the D-Bus object -emitting the message. INTERFACE and MEMBER denote the message -which has been sent. HANDLER is the function which has been -registered for this message. ARGS are the arguments passed to -HANDLER, when it is called during event handling in -`dbus-handle-event'. +either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. TYPE is the D-Bus message type which +has caused the event, SERIAL is the serial number of the received +D-Bus message. SERVICE and PATH are the unique name and the +object path of the D-Bus object emitting the message. INTERFACE +and MEMBER denote the message which has been sent. HANDLER is +the function which has been registered for this message. ARGS +are the arguments passed to HANDLER, when it is called during +event handling in `dbus-handle-event'. This function raises a `dbus-error' signal in case the event is not well formed." @@ -368,7 +380,8 @@ not well formed." (unless (and (listp event) (eq (car event) 'dbus-event) ;; Bus symbol. - (symbolp (nth 1 event)) + (or (symbolp (nth 1 event)) + (stringp (nth 1 event))) ;; Type. (and (natnump (nth 2 event)) (< dbus-message-type-invalid (nth 2 event))) @@ -433,9 +446,10 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (defun dbus-event-bus-name (event) "Return the bus name the event is coming from. -The result is either the symbol `:system' or the symbol `:session'. -EVENT is a D-Bus event, see `dbus-check-event'. This function -raises a `dbus-error' signal in case the event is not well formed." +The result is either a Lisp symbol, `:system' or `:session', or a +string denoting the bus address. EVENT is a D-Bus event, see +`dbus-check-event'. This function raises a `dbus-error' signal +in case the event is not well formed." (dbus-check-event event) (nth 1 event)) @@ -565,10 +579,11 @@ apply "Return all interfaces and sub-nodes of SERVICE, registered at object path PATH at bus BUS. -BUS must be either the symbol `:system' or the symbol `:session'. -SERVICE must be a known service name, and PATH must be a valid -object path. The last two parameters are strings. The result, -the introspection data, is a string in XML format." +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. SERVICE must be a known service name, +and PATH must be a valid object path. The last two parameters +are strings. The result, the introspection data, is a string in +XML format." ;; We don't want to raise errors. `dbus-call-method-non-blocking' ;; is used, because the handler can be registered in our Emacs ;; instance; caller an callee would block each other. @@ -869,20 +884,23 @@ name of the property, and its value. If there are no properties, (add-to-list 'result (cons (car dict) (caadr dict)) 'append))))) (defun dbus-register-property - (bus service path interface property access value) + (bus service path interface property access value + &optional emits-signal dont-register-service) "Register property PROPERTY on the D-Bus BUS. -BUS is either the symbol `:system' or the symbol `:session'. +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. SERVICE is the D-Bus service name of the D-Bus. It must be a -known name. - -PATH is the D-Bus object path SERVICE is registered. INTERFACE -is the name of the interface used at PATH, PROPERTY is the name -of the property of INTERFACE. ACCESS indicates, whether the -property can be changed by other services via D-Bus. It must be -either the symbol `:read' or `:readwrite'. VALUE is the initial -value of the property, it can be of any valid type (see +known name (See discussion of DONT-REGISTER-SERVICE below). + +PATH is the D-Bus object path SERVICE is registered (See +discussion of DONT-REGISTER-SERVICE below). INTERFACE is the +name of the interface used at PATH, PROPERTY is the name of the +property of INTERFACE. ACCESS indicates, whether the property +can be changed by other services via D-Bus. It must be either +the symbol `:read' or `:readwrite'. VALUE is the initial value +of the property, it can be of any valid type (see `dbus-call-method' for details). If PROPERTY already exists on PATH, it will be overwritten. For @@ -892,29 +910,58 @@ can be changed by `dbus-set-property'. The interface \"org.freedesktop.DBus.Properties\" is added to PATH, including a default handler for the \"Get\", \"GetAll\" and -\"Set\" methods of this interface." +\"Set\" methods of this interface. When EMITS-SIGNAL is non-nil, +the signal \"PropertiesChanged\" is sent when the property is +changed by `dbus-set-property'. + +When DONT-REGISTER-SERVICE is non-nil, the known name SERVICE is +not registered. This means that other D-Bus clients have no way +of noticing the newly registered property. When interfaces are +constructed incrementally by adding single methods or properties +at a time, DONT-REGISTER-SERVICE can be used to prevent other +clients from discovering the still incomplete interface." (unless (member access '(:read :readwrite)) (signal 'dbus-error (list "Access type invalid" access))) ;; Register SERVICE. - (unless (member service (dbus-list-names bus)) + (unless (or dont-register-service + (member service (dbus-list-names bus))) (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "RequestName" service 0)) - ;; Add the handler. We use `dbus-service-emacs' as service name, in - ;; order to let unregister SERVICE despite of this default handler. + ;; Add handlers for the three property-related methods. (dbus-register-method - bus service path dbus-interface-properties "Get" 'dbus-property-handler) + bus service path dbus-interface-properties "Get" + 'dbus-property-handler 'dont-register) (dbus-register-method - bus service path dbus-interface-properties "GetAll" 'dbus-property-handler) + bus service path dbus-interface-properties "GetAll" + 'dbus-property-handler 'dont-register) (dbus-register-method - bus service path dbus-interface-properties "Set" 'dbus-property-handler) + bus service path dbus-interface-properties "Set" + 'dbus-property-handler 'dont-register) + + ;; Register the name SERVICE with BUS. + (unless dont-register-service + (dbus-register-service bus service)) + + ;; Send the PropertiesChanged signal. + (when emits-signal + (dbus-send-signal + bus service path dbus-interface-properties "PropertiesChanged" + (list (list :dict-entry property (list :variant value))) + '(:array))) ;; Create a hash table entry. We use nil for the unique name, ;; because the property might be accessed from anybody. (let ((key (list bus interface property)) - (val (list (list nil service path (cons access value))))) + (val + (list + (list + nil service path + (cons + (if emits-signal (list access :emits-signal) (list access)) + value))))) (puthash key val dbus-registered-objects-table) ;; Return the object. @@ -924,6 +971,7 @@ PATH, including a default handler for the \"Get\", \"GetAll\" and "Default handler for the \"org.freedesktop.DBus.Properties\" interface. It will be registered for all objects created by `dbus-register-object'." (let ((bus (dbus-event-bus-name last-input-event)) + (service (dbus-event-service-name last-input-event)) (path (dbus-event-path-name last-input-event)) (method (dbus-event-member-name last-input-event)) (interface (car args)) @@ -931,25 +979,40 @@ It will be registered for all objects created by `dbus-register-object'." (cond ;; "Get" returns a variant. ((string-equal method "Get") - (let ((val (gethash (list bus interface property) - dbus-registered-objects-table))) - (when (string-equal path (nth 2 (car val))) - (list (list :variant (cdar (last (car val)))))))) + (let ((entry (gethash (list bus interface property) + dbus-registered-objects-table))) + (when (string-equal path (nth 2 (car entry))) + (list (list :variant (cdar (last (car entry)))))))) ;; "Set" expects a variant. ((string-equal method "Set") - (let ((val (gethash (list bus interface property) - dbus-registered-objects-table))) - (unless (consp (car (last (car val)))) + (let* ((value (caar (cddr args))) + (entry (gethash (list bus interface property) + dbus-registered-objects-table)) + ;; The value of the hash table is a list; in case of + ;; properties it contains just one element (UNAME SERVICE + ;; PATH OBJECT). OBJECT is a cons cell of a list, which + ;; contains a list of annotations (like :read, + ;; :read-write, :emits-signal), and the value of the + ;; property. + (object (car (last (car entry))))) + (unless (consp object) (signal 'dbus-error (list "Property not registered at path" property path))) - (unless (equal (caar (last (car val))) :readwrite) + (unless (member :readwrite (car object)) (signal 'dbus-error (list "Property not writable at path" property path))) (puthash (list bus interface property) - (list (append (butlast (car val)) - (list (cons :readwrite (caar (cddr args)))))) + (list (append (butlast (car entry)) + (list (cons (car object) value)))) dbus-registered-objects-table) + ;; Send the "PropertiesChanged" signal. + (when (member :emits-signal (car object)) + (dbus-send-signal + bus service path dbus-interface-properties "PropertiesChanged" + (list (list :dict-entry property (list :variant value))) + '(:array))) + ;; Return empty reply. :ignore)) ;; "GetAll" returns "a{sv}". @@ -979,5 +1042,4 @@ It will be registered for all objects created by `dbus-register-object'." (provide 'dbus) -;; arch-tag: a47caf84-9162-4811-90cc-5d388e37b9bd ;;; dbus.el ends here diff --git a/lisp/net/dig.el b/lisp/net/dig.el index e65e5eaab32..4b013fa517b 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -129,12 +129,11 @@ Buffer should contain output generated by `dig-invoke'." (put 'dig-mode 'mode-class 'special) -(defvar dig-mode-map nil) -(unless dig-mode-map - (setq dig-mode-map (make-sparse-keymap)) - (suppress-keymap dig-mode-map) - - (define-key dig-mode-map "q" 'dig-exit)) +(defvar dig-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map) + (define-key map "q" 'dig-exit) + map)) (define-derived-mode dig-mode nil "Dig" "Major mode for displaying dig output." @@ -184,5 +183,4 @@ Returns nil for domain/class/type queries that result in no data." (provide 'dig) -;; arch-tag: 1d61726e-9400-4013-9ae7-4035e0c7f7d6 ;;; dig.el ends here diff --git a/lisp/net/dns.el b/lisp/net/dns.el index 6e727edf339..06469eec59c 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -101,7 +101,7 @@ If nil, /etc/resolv.conf and nslookup will be consulted.") (defun dns-read-string-name (string buffer) (with-temp-buffer - (set-buffer-multibyte nil) + (unless (featurep 'xemacs) (set-buffer-multibyte nil)) (insert string) (goto-char (point-min)) (dns-read-name buffer))) @@ -135,7 +135,7 @@ If nil, /etc/resolv.conf and nslookup will be consulted.") "Write a DNS packet according to SPEC. If TCP-P, the first two bytes of the package with be the length field." (with-temp-buffer - (set-buffer-multibyte nil) + (unless (featurep 'xemacs) (set-buffer-multibyte nil)) (dns-write-bytes (dns-get 'id spec) 2) (dns-write-bytes (logior @@ -151,7 +151,7 @@ If TCP-P, the first two bytes of the package with be the length field." (lsh (if (dns-get 'truncated-p spec) 1 0) -1) (lsh (if (dns-get 'recursion-desired-p spec) 1 0) 0))) (dns-write-bytes - (cond + (cond ((eq (dns-get 'response-code spec) 'no-error) 0) ((eq (dns-get 'response-code spec) 'format-error) 1) ((eq (dns-get 'response-code spec) 'server-failure) 2) @@ -186,7 +186,7 @@ If TCP-P, the first two bytes of the package with be the length field." (defun dns-read (packet) (with-temp-buffer - (set-buffer-multibyte nil) + (unless (featurep 'xemacs) (set-buffer-multibyte nil)) (let ((spec nil) queries answers authorities additionals) (insert packet) @@ -263,7 +263,7 @@ If TCP-P, the first two bytes of the package with be the length field." (point (point))) (prog1 (with-temp-buffer - (set-buffer-multibyte nil) + (unless (featurep 'xemacs) (set-buffer-multibyte nil)) (insert string) (goto-char (point-min)) (cond @@ -391,7 +391,7 @@ If REVERSEP, look up an IP address." (if (not dns-servers) (message "No DNS server configuration found") (with-temp-buffer - (set-buffer-multibyte nil) + (unless (featurep 'xemacs) (set-buffer-multibyte nil)) (let ((process (condition-case () (dns-make-network-process (car dns-servers)) (error @@ -438,5 +438,4 @@ If REVERSEP, look up an IP address." (provide 'dns) -;; arch-tag: d0edd0c4-4cce-4538-ae92-06c3356ee80a ;;; dns.el ends here diff --git a/lisp/net/eudc-bob.el b/lisp/net/eudc-bob.el index 8210ace5a8a..0f6aae39618 100644 --- a/lisp/net/eudc-bob.el +++ b/lisp/net/eudc-bob.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. diff --git a/lisp/net/eudc-export.el b/lisp/net/eudc-export.el index 0a9b3d935e8..f5d4311fce3 100644 --- a/lisp/net/eudc-export.el +++ b/lisp/net/eudc-export.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. diff --git a/lisp/net/eudc-hotlist.el b/lisp/net/eudc-hotlist.el index 7411d08f955..7cfb7a159e9 100644 --- a/lisp/net/eudc-hotlist.el +++ b/lisp/net/eudc-hotlist.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. @@ -32,9 +33,18 @@ (require 'eudc) (defvar eudc-hotlist-menu nil) -(defvar eudc-hotlist-mode-map nil) (defvar eudc-hotlist-list-beginning nil) +(defvar eudc-hotlist-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'eudc-hotlist-add-server) + (define-key map "d" 'eudc-hotlist-delete-server) + (define-key map "s" 'eudc-hotlist-select-server) + (define-key map "t" 'eudc-hotlist-transpose-servers) + (define-key map "q" 'eudc-hotlist-quit-edit) + (define-key map "x" 'kill-this-buffer) + map)) + (defun eudc-hotlist-mode () "Major mode used to edit the hotlist of servers. @@ -168,16 +178,6 @@ These are the special commands of this mode: (forward-line 1) (transpose-lines 1)))))) -(setq eudc-hotlist-mode-map - (let ((map (make-sparse-keymap))) - (define-key map "a" 'eudc-hotlist-add-server) - (define-key map "d" 'eudc-hotlist-delete-server) - (define-key map "s" 'eudc-hotlist-select-server) - (define-key map "t" 'eudc-hotlist-transpose-servers) - (define-key map "q" 'eudc-hotlist-quit-edit) - (define-key map "x" 'kill-this-buffer) - map)) - (defconst eudc-hotlist-menu '("EUDC Hotlist Edit" ["---" nil nil] diff --git a/lisp/net/eudc-vars.el b/lisp/net/eudc-vars.el index b01e2a0378a..54c7ae074c3 100644 --- a/lisp/net/eudc-vars.el +++ b/lisp/net/eudc-vars.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. @@ -38,7 +39,7 @@ :group 'comm) (defcustom eudc-server nil - "*The name or IP address of the directory server. + "The name or IP address of the directory server. A port number may be specified by appending a colon and a number to the name of the server. Use `localhost' if the directory server resides on your computer (BBDB backend)." @@ -55,7 +56,7 @@ This variable is updated when protocol-specific libraries are loaded, *do not change manually*.") (defcustom eudc-protocol nil - "*The directory protocol to use to query the server. + "The directory protocol to use to query the server. Supported protocols are specified by `eudc-supported-protocols'." :type `(choice :menu-tag "Protocol" ,@(mapcar (lambda (s) @@ -66,13 +67,13 @@ Supported protocols are specified by `eudc-supported-protocols'." (defcustom eudc-strict-return-matches t - "*Ignore or allow entries not containing all requested return attributes. + "Ignore or allow entries not containing all requested return attributes. If non-nil, such entries are ignored." :type 'boolean :group 'eudc) (defcustom eudc-default-return-attributes nil - "*A list of default attributes to extract from directory entries. + "A list of default attributes to extract from directory entries. If set to the symbol `all', return all attributes. A value of nil means return the default attributes as configured in the server." @@ -86,7 +87,7 @@ server." :group 'eudc) (defcustom eudc-multiple-match-handling-method 'select - "*What to do when multiple entries match an inline expansion query. + "What to do when multiple entries match an inline expansion query. Possible values are: `first' (equivalent to nil) which means keep the first match only, `select' pop-up a selection buffer, @@ -106,7 +107,7 @@ Possible values are: :group 'eudc) (defcustom eudc-duplicate-attribute-handling-method '((email . duplicate)) - "*A method to handle entries containing duplicate attributes. + "A method to handle entries containing duplicate attributes. This is either an alist (ATTR . METHOD) or a symbol METHOD. The alist form of the variable associates a method to an individual attribute, the second form specifies a method applicable to all attributes. @@ -135,7 +136,7 @@ different values." (defcustom eudc-inline-query-format '((name) (firstname name)) - "*Format of an inline expansion query. + "Format of an inline expansion query. This is a list of FORMATs. A FORMAT is itself a list of one or more EUDC attribute names. A FORMAT applies if it contains as many attributes as there are individual words in the inline query string. @@ -163,12 +164,12 @@ must be set in a protocol/server-local fashion, see `eudc-server-set' and :group 'eudc) (defcustom eudc-expansion-overwrites-query t - "*If non-nil, expanding a query overwrites the query string." + "If non-nil, expanding a query overwrites the query string." :type 'boolean :group 'eudc) (defcustom eudc-inline-expansion-format '("%s" email) - "*A list specifying the format of the expansion of inline queries. + "A list specifying the format of the expansion of inline queries. This variable controls what `eudc-expand-inline' actually inserts in the buffer. First element is a string passed to `format'. Remaining elements are symbols indicating attribute names; the corresponding values @@ -188,7 +189,7 @@ are passed as additional arguments to `format'." :group 'eudc) (defcustom eudc-inline-expansion-servers 'server-then-hotlist - "*Which servers to contact for the expansion of inline queries. + "Which servers to contact for the expansion of inline queries. Possible values are: `current-server': the EUDC current server. `hotlist': the servers of the hotlist in the order they appear, @@ -202,7 +203,7 @@ Possible values are: :group 'eudc) (defcustom eudc-max-servers-to-query nil - "*Maximum number of servers to query for an inline expansion. + "Maximum number of servers to query for an inline expansion. If nil, query all servers available from `eudc-inline-expansion-servers'." :tag "Max Number of Servers to Query" :type '(choice :tag "Max. Servers" @@ -217,7 +218,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'." :group 'eudc) (defcustom eudc-query-form-attributes '(name firstname email phone) - "*A list of attributes presented in the query form." + "A list of attributes presented in the query form." :tag "Attributes in Query Forms" :type '(repeat (choice @@ -248,7 +249,7 @@ If nil, query all servers available from `eudc-inline-expansion-servers'." (telephonenumber . "Phone") (uniqueidentifier . "ID") (objectclass . "Object Class")) - "*Alist of user-defined names for directory attributes. + "Alist of user-defined names for directory attributes. These names are used as prompt strings in query/response forms instead of the raw directory attribute names. Prompt strings for attributes that are not listed here @@ -261,14 +262,14 @@ at `_' characters and capitalizing the individual words." :group 'eudc) (defcustom eudc-use-raw-directory-names nil - "*If non-nil, use attributes names as defined in the directory. + "If non-nil, use attributes names as defined in the directory. Otherwise, directory query/response forms display the user attribute names defined in `eudc-user-attribute-names-alist'." :type 'boolean :group 'eudc) (defcustom eudc-attribute-display-method-alist nil - "*An alist specifying methods to display attribute values. + "An alist specifying methods to display attribute values. Each member of the list is of the form (NAME . FUNC) where NAME is a lowercased string naming a directory attribute (translated according to `eudc-user-attribute-names-alist' if `eudc-use-raw-directory-names' is @@ -282,7 +283,7 @@ attribute values for display." (defcustom eudc-external-viewers '(("ImageMagick" "display" "-") ("ShowAudio" "showaudio")) - "*A list of viewer program specifications. + "A list of viewer program specifications. Viewers are programs which can be piped a directory attribute value for display or arbitrary processing. Each specification is a list whose first element is a string naming the viewer. The second element is the @@ -299,12 +300,12 @@ arguments that should be passed to the program." :group 'eudc) (defcustom eudc-options-file "~/.eudc-options" - "*A file where the `servers' hotlist is stored." + "A file where the `servers' hotlist is stored." :type '(file :Tag "File Name:") :group 'eudc) (defcustom eudc-mode-hook nil - "*Normal hook run on entry to EUDC mode." + "Normal hook run on entry to EUDC mode." :type '(repeat (sexp :tag "Hook definition")) :group 'eudc) @@ -322,7 +323,7 @@ arguments that should be passed to the program." (address . (eudc-bbdbify-address address "Address")) (phone . ((eudc-bbdbify-phone phone "Phone") (eudc-bbdbify-phone office_phone "Office Phone")))) - "*A mapping from BBDB to PH/QI fields. + "A mapping from BBDB to PH/QI fields. This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where BBDB-FIELD is the name of a field that must be defined in your BBDB environment (standard field names are `name', `company', `net', `phone', @@ -357,7 +358,7 @@ BBDB fields. SPECs are sexps which are evaluated: (net . mail) (address . (eudc-bbdbify-address postaladdress "Address")) (phone . ((eudc-bbdbify-phone telephonenumber "Phone")))) - "*A mapping from BBDB to LDAP attributes. + "A mapping from BBDB to LDAP attributes. This is a list of cons cells (BBDB-FIELD . SPEC-OR-LIST) where BBDB-FIELD is the name of a field that must be defined in your BBDB environment (standard field names are `name', `company', `net', `phone', diff --git a/lisp/net/eudc.el b/lisp/net/eudc.el index b35d13c2086..baff848eb0b 100644 --- a/lisp/net/eudc.el +++ b/lisp/net/eudc.el @@ -830,10 +830,7 @@ see `eudc-inline-expansion-servers'" (let* ((end (point)) (beg (save-excursion (if (re-search-backward "\\([:,]\\|^\\)[ \t]*" - (save-excursion - (beginning-of-line) - (point)) - 'move) + (point-at-bol) 'move) (goto-char (match-end 0))) (point))) (query-words (split-string (buffer-substring beg end) "[ \t]+")) @@ -1295,5 +1292,4 @@ This does nothing except loading eudc by autoload side-effect." (provide 'eudc) -;; arch-tag: e18872b6-db83-400b-869d-be54e9a4160c ;;; eudc.el ends here diff --git a/lisp/net/eudcb-bbdb.el b/lisp/net/eudcb-bbdb.el index c952bbd55ea..0b50f51617e 100644 --- a/lisp/net/eudcb-bbdb.el +++ b/lisp/net/eudcb-bbdb.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. diff --git a/lisp/net/eudcb-ldap.el b/lisp/net/eudcb-ldap.el index 75b40c1dcd1..192f0f4600f 100644 --- a/lisp/net/eudcb-ldap.el +++ b/lisp/net/eudcb-ldap.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. diff --git a/lisp/net/eudcb-mab.el b/lisp/net/eudcb-mab.el index 6277392289c..4d34bfde9d0 100644 --- a/lisp/net/eudcb-mab.el +++ b/lisp/net/eudcb-mab.el @@ -6,6 +6,7 @@ ;; Author: John Wiegley <johnw@newartisans.com> ;; Maintainer: FSF ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. diff --git a/lisp/net/eudcb-ph.el b/lisp/net/eudcb-ph.el index 8d36daf34d3..794fcdfb5fa 100644 --- a/lisp/net/eudcb-ph.el +++ b/lisp/net/eudcb-ph.el @@ -6,6 +6,7 @@ ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: Pavel Janík <Pavel@Janik.cz> ;; Keywords: comm +;; Package: eudc ;; This file is part of GNU Emacs. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el new file mode 100644 index 00000000000..e49af2948e6 --- /dev/null +++ b/lisp/net/gnutls.el @@ -0,0 +1,115 @@ +;;; gnutls.el --- Support SSL/TLS connections through GnuTLS + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Ted Zlatanov <tzz@lifelogs.com> +;; Keywords: comm, tls, ssl, encryption +;; Originally-By: Simon Josefsson (See http://josefsson.org/emacs-security/) +;; Thanks-To: Lars Magne Ingebrigtsen <larsi@gnus.org> + +;; 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides language bindings for the GnuTLS library +;; using the corresponding core functions in gnutls.c. + +;; Simple test: +;; +;; (open-gnutls-stream "tls" "tls-buffer" "yourserver.com" "https") +;; (open-gnutls-stream "tls" "tls-buffer" "imap.gmail.com" "imaps") + +;;; Code: + +(defgroup gnutls nil + "Emacs interface to the GnuTLS library." + :prefix "gnutls-" + :group 'net-utils) + +(defcustom gnutls-log-level 0 + "Logging level to be used by `starttls-negotiate' and GnuTLS." + :type 'integer + :group 'gnutls) + +(defun open-gnutls-stream (name buffer host service) + "Open a SSL/TLS connection for a service to a host. +Returns a subprocess-object to represent the connection. +Input and output work as for subprocesses; `delete-process' closes it. +Args are NAME BUFFER HOST SERVICE. +NAME is name for process. It is modified if necessary to make it unique. +BUFFER is the buffer (or `buffer-name') to associate with the process. + Process output goes at end of that buffer, unless you specify + an output stream or filter function to handle the output. + BUFFER may be also nil, meaning that this process is not associated + with any buffer +Third arg is name of the host to connect to, or its IP address. +Fourth arg SERVICE is name of the service desired, or an integer +specifying a port number to connect to. + +This is a very simple wrapper around `gnutls-negotiate'. See its +documentation for the specific parameters you can use to open a +GnuTLS connection, including specifying the credential type, +trust and key files, and priority string." + (let ((proc (open-network-stream name buffer host service))) + (gnutls-negotiate proc 'gnutls-x509pki))) + +(declare-function gnutls-boot "gnutls.c" (proc type proplist)) + +(defun gnutls-negotiate (proc type &optional priority-string + trustfiles keyfiles) + "Negotiate a SSL/TLS connection. +TYPE is `gnutls-x509pki' (default) or `gnutls-anon'. Use nil for the default. +PROC is a process returned by `open-network-stream'. +PRIORITY-STRING is as per the GnuTLS docs, default is \"NORMAL\". +TRUSTFILES is a list of CA bundles. +KEYFILES is a list of client keys." + (let* ((type (or type 'gnutls-x509pki)) + (trustfiles (or trustfiles + '("/etc/ssl/certs/ca-certificates.crt"))) + (priority-string (or priority-string + (cond + ((eq type 'gnutls-anon) + "NORMAL:+ANON-DH:!ARCFOUR-128") + ((eq type 'gnutls-x509pki) + "NORMAL")))) + (params `(:priority ,priority-string + :loglevel ,gnutls-log-level + :trustfiles ,trustfiles + :keyfiles ,keyfiles + :callbacks nil)) + ret) + + (gnutls-message-maybe + (setq ret (gnutls-boot proc type params)) + "boot: %s") + + proc)) + +(declare-function gnutls-errorp "gnutls.c" (error)) +(declare-function gnutls-error-string "gnutls.c" (error)) + +(defun gnutls-message-maybe (doit format &rest params) + "When DOIT, message with the caller name followed by FORMAT on PARAMS." + ;; (apply 'debug format (or params '(nil))) + (when (gnutls-errorp doit) + (message "%s: (err=[%s] %s) %s" + "gnutls.el" + doit (gnutls-error-string doit) + (apply 'format format (or params '(nil)))))) + +(provide 'gnutls) + +;;; gnutls.el ends here diff --git a/lisp/net/goto-addr.el b/lisp/net/goto-addr.el index 49dbd97aca8..3bcf985052e 100644 --- a/lisp/net/goto-addr.el +++ b/lisp/net/goto-addr.el @@ -76,7 +76,7 @@ (defgroup goto-address nil "Click to browse URL or to send to e-mail address." :group 'mouse - :group 'hypermedia) + :group 'comm) ;; I don't expect users to want fontify'ing without highlighting. diff --git a/lisp/net/hmac-def.el b/lisp/net/hmac-def.el index 459d0b81779..a7a408e853b 100644 --- a/lisp/net/hmac-def.el +++ b/lisp/net/hmac-def.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> -;; Keywords: HMAC, RFC-2104 +;; Keywords: HMAC, RFC2104 ;; This file is part of GNU Emacs. @@ -22,7 +22,7 @@ ;;; Commentary: -;; This program is implemented from RFC 2104, +;; This program is implemented from RFC2104, ;; "HMAC: Keyed-Hashing for Message Authentication". ;;; Code: @@ -80,5 +80,4 @@ If BIT is non-nil, truncate output to specified bits." (provide 'hmac-def) -;; arch-tag: 645adcef-b835-4900-a10a-11f636c982b9 ;;; hmac-def.el ends here diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el index c433d7004d8..e61ea80456f 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999, 2001, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Shuhei KOBAYASHI <shuhei@aqua.ocn.ne.jp> -;; Keywords: HMAC, RFC-2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 +;; Keywords: HMAC, RFC2104, HMAC-MD5, MD5, KEYED-MD5, CRAM-MD5 ;; This file is part of GNU Emacs. @@ -79,5 +79,4 @@ (provide 'hmac-md5) -;; arch-tag: 0ab3f4f6-3d4b-4167-a9fa-635b7fed7f27 ;;; hmac-md5.el ends here diff --git a/lisp/net/imap.el b/lisp/net/imap.el index 0a20eadffcf..b542088f7f8 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -139,6 +139,7 @@ (eval-when-compile (require 'cl)) (eval-and-compile + ;; For Emacs <22.2 and XEmacs. (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))) (autoload 'starttls-open-stream "starttls") (autoload 'starttls-negotiate "starttls") @@ -267,7 +268,7 @@ See also `imap-log'." :type 'string) (defcustom imap-read-timeout (if (string-match - "windows-nt\\|os/2\\|emx\\|cygwin" + "windows-nt\\|os/2\\|cygwin" (symbol-name system-type)) 1.0 0.1) @@ -475,10 +476,10 @@ sure of changing the value of `foo'." (setcdr alist (imap-remassoc key (cdr alist))) alist))) -(defsubst imap-disable-multibyte () +(defmacro imap-disable-multibyte () "Enable multibyte in the current buffer." - (when (fboundp 'set-buffer-multibyte) - (set-buffer-multibyte nil))) + (unless (featurep 'xemacs) + '(set-buffer-multibyte nil))) (defsubst imap-utf7-encode (string) (if imap-use-utf7 @@ -515,6 +516,16 @@ sure of changing the value of `foo'." ;; Server functions; stream stuff: +(defun imap-log (string-or-buffer) + (when imap-log + (with-current-buffer (get-buffer-create imap-log-buffer) + (imap-disable-multibyte) + (buffer-disable-undo) + (goto-char (point-max)) + (if (bufferp string-or-buffer) + (insert-buffer-substring string-or-buffer) + (insert string-or-buffer))))) + (defun imap-kerberos4-stream-p (buffer) (imap-capability 'AUTH=KERBEROS_V4 buffer)) @@ -569,12 +580,6 @@ sure of changing the value of `foo'." (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) (erase-buffer) (message "Opening Kerberos 4 IMAP connection with `%s'...%s" cmd (if response (concat "done, " response) "failed")) @@ -645,12 +650,7 @@ sure of changing the value of `foo'." (setq response (match-string 1))))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (message "GSSAPI IMAP connection: %s" (or response "failed")) (if (and response (let ((case-fold-search nil)) @@ -701,12 +701,7 @@ sure of changing the value of `foo'." (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process)))))) @@ -740,12 +735,7 @@ sure of changing the value of `foo'." (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (memq (process-status process) '(open run)) process)))) @@ -764,12 +754,7 @@ sure of changing the value of `foo'." (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (memq (process-status process) '(open run)) process)))) @@ -803,12 +788,7 @@ sure of changing the value of `foo'." (not (imap-parse-greeting))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (erase-buffer) (when (memq (process-status process) '(open run)) (setq done process))))) @@ -845,11 +825,7 @@ sure of changing the value of `foo'." (not (re-search-forward "[0-9]+ OK.*\r?\n" nil t))) (accept-process-output process 1) (sit-for 1)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring buffer))) + (imap-log buffer) (when (and (setq tls-info (starttls-negotiate process)) (memq (process-status process) '(open run))) (setq done process))) @@ -1227,7 +1203,7 @@ password is remembered in the buffer." (when user (setq imap-username user)) (when passwd (setq imap-password passwd)) (if imap-auth - (and (setq imap-last-authenticator + (and (setq imap-last-authenticator (assq imap-auth imap-authenticator-alist)) (funcall (nth 2 imap-last-authenticator) (current-buffer)) (setq imap-state 'auth)) @@ -1959,12 +1935,7 @@ on failure." (defun imap-send-command-1 (cmdstr) (setq cmdstr (concat cmdstr imap-client-eol)) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert cmdstr))) + (imap-log cmdstr) (process-send-string imap-process cmdstr)) (defun imap-send-command (command &optional buffer) @@ -2002,13 +1973,7 @@ on failure." (stream imap-stream) (eol imap-client-eol)) (with-current-buffer cmd - (and imap-log - (with-current-buffer (get-buffer-create - imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert-buffer-substring cmd))) + (imap-log cmd) (process-send-region process (point-min) (point-max))) (process-send-string process imap-client-eol)))) @@ -2084,18 +2049,13 @@ Return nil if no complete line has arrived." (with-current-buffer (process-buffer proc) (goto-char (point-max)) (insert string) - (and imap-log - (with-current-buffer (get-buffer-create imap-log-buffer) - (imap-disable-multibyte) - (buffer-disable-undo) - (goto-char (point-max)) - (insert string))) + (imap-log string) (let (end) (goto-char (point-min)) (while (setq end (imap-find-next-line)) (save-restriction (narrow-to-region (point-min) end) - (delete-backward-char (length imap-server-eol)) + (delete-char (- (length imap-server-eol))) (goto-char (point-min)) (unwind-protect (cond ((eq imap-state 'initial) @@ -3093,5 +3053,4 @@ Return nil if no complete line has arrived." (provide 'imap) -;; arch-tag: 27369ed6-33e4-482f-96f1-8bb906ba70f7 ;;; imap.el ends here diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index afdb0fe3e13..88284af06f0 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -1,7 +1,7 @@ ;;; ldap.el --- client interface to LDAP for Emacs -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: FSF @@ -43,7 +43,7 @@ :group 'comm) (defcustom ldap-default-host nil - "*Default LDAP server. + "Default LDAP server. A TCP port number can be appended to that name using a colon as a separator." :type '(choice (string :tag "Host name") @@ -51,14 +51,14 @@ a separator." :group 'ldap) (defcustom ldap-default-port nil - "*Default TCP port for LDAP connections. + "Default TCP port for LDAP connections. Initialized from the LDAP library at build time. Default value is 389." :type '(choice (const :tag "Use library default" nil) (integer :tag "Port number")) :group 'ldap) (defcustom ldap-default-base nil - "*Default base for LDAP searches. + "Default base for LDAP searches. This is a string using the syntax of RFC 1779. For instance, \"o=ACME, c=US\" limits the search to the Acme organization in the United States." @@ -68,7 +68,7 @@ Acme organization in the United States." (defcustom ldap-host-parameters-alist nil - "*Alist of host-specific options for LDAP transactions. + "Alist of host-specific options for LDAP transactions. The format of each list element is (HOST PROP1 VAL1 PROP2 VAL2 ...). HOST is the hostname of an LDAP server (with an optional TCP port number appended to it using a colon as a separator). @@ -148,28 +148,28 @@ Valid properties include: :group 'ldap) (defcustom ldap-ldapsearch-prog "ldapsearch" - "*The name of the ldapsearch command line program." + "The name of the ldapsearch command line program." :type '(string :tag "`ldapsearch' Program") :group 'ldap) (defcustom ldap-ldapsearch-args '("-LL" "-tt") - "*A list of additional arguments to pass to `ldapsearch'." + "A list of additional arguments to pass to `ldapsearch'." :type '(repeat :tag "`ldapsearch' Arguments" (string :tag "Argument")) :group 'ldap) (defcustom ldap-ignore-attribute-codings nil - "*If non-nil, do not encode/decode LDAP attribute values." + "If non-nil, do not encode/decode LDAP attribute values." :type 'boolean :group 'ldap) (defcustom ldap-default-attribute-decoder nil - "*Decoder function to use for attributes whose syntax is unknown." + "Decoder function to use for attributes whose syntax is unknown." :type 'symbol :group 'ldap) (defcustom ldap-coding-system 'utf-8 - "*Coding system of LDAP string values. + "Coding system of LDAP string values. LDAP v3 specifies the coding system of strings to be UTF-8." :type 'symbol :group 'ldap) @@ -556,13 +556,9 @@ an alist of attribute/value pairs." (if (and sizelimit (not (equal "" sizelimit))) (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) - (eval `(call-process ldap-ldapsearch-prog - nil - buf - nil - ,@arglist - ,@ldap-ldapsearch-args - ,@filter)) + (apply #'call-process ldap-ldapsearch-prog + nil buf nil + (append arglist ldap-ldapsearch-args filter)) (insert "\n") (goto-char (point-min)) @@ -579,9 +575,7 @@ an alist of attribute/value pairs." (while (progn (skip-chars-forward " \t\n") (not (eobp))) - (setq dn (buffer-substring (point) (save-excursion - (end-of-line) - (point)))) + (setq dn (buffer-substring (point) (point-at-eol))) (forward-line 1) (while (looking-at "^\\([A-Za-z][-A-Za-z0-9]*\ \\|[0-9]+\\(?:\\.[0-9]+\\)*\\)\\(;[-A-Za-z0-9]+\\)*[=:\t ]+\ @@ -617,5 +611,4 @@ an alist of attribute/value pairs." (provide 'ldap) -;; arch-tag: 47913a76-6155-42e6-ac58-6d28b5d50eb0 ;;; ldap.el ends here diff --git a/lisp/net/mairix.el b/lisp/net/mairix.el index a7c834b3b94..2655c4feb79 100644 --- a/lisp/net/mairix.el +++ b/lisp/net/mairix.el @@ -735,23 +735,21 @@ VALUES may contain values for editable fields from current article." ;;;; Major mode for editing/deleting/saving searches -(defvar mairix-searches-mode-map nil "'mairix-searches-mode' keymap.") - -;; Keymap -(if (not mairix-searches-mode-map) - (let ((map (make-keymap))) - (define-key map [(return)] 'mairix-select-search) - (define-key map [(down)] 'mairix-next-search) - (define-key map [(up)] 'mairix-previous-search) - (define-key map [(right)] 'mairix-next-search) - (define-key map [(left)] 'mairix-previous-search) - (define-key map "\C-p" 'mairix-previous-search) - (define-key map "\C-n" 'mairix-next-search) - (define-key map [(q)] 'mairix-select-quit) - (define-key map [(e)] 'mairix-select-edit) - (define-key map [(d)] 'mairix-select-delete) - (define-key map [(s)] 'mairix-select-save) - (setq mairix-searches-mode-map map))) +(defvar mairix-searches-mode-map + (let ((map (make-keymap))) + (define-key map [(return)] 'mairix-select-search) + (define-key map [(down)] 'mairix-next-search) + (define-key map [(up)] 'mairix-previous-search) + (define-key map [(right)] 'mairix-next-search) + (define-key map [(left)] 'mairix-previous-search) + (define-key map "\C-p" 'mairix-previous-search) + (define-key map "\C-n" 'mairix-next-search) + (define-key map [(q)] 'mairix-select-quit) + (define-key map [(e)] 'mairix-select-edit) + (define-key map [(d)] 'mairix-select-delete) + (define-key map [(s)] 'mairix-select-save) + map) + "'mairix-searches-mode' keymap.") (defvar mairix-searches-mode-font-lock-keywords) diff --git a/lisp/net/net-utils.el b/lisp/net/net-utils.el index f13b1348b88..256b1f95088 100644 --- a/lisp/net/net-utils.el +++ b/lisp/net/net-utils.el @@ -55,8 +55,7 @@ :group 'comm :version "20.3") -(defcustom net-utils-remove-ctl-m - (member system-type (list 'windows-nt 'msdos)) +(defcustom net-utils-remove-ctl-m (memq system-type '(windows-nt msdos)) "If non-nil, remove control-Ms from output." :group 'net-utils :type 'boolean) @@ -82,7 +81,7 @@ ;; On GNU/Linux and Irix, the system's ping program seems to send packets ;; indefinitely unless told otherwise (defcustom ping-program-options - (and (memq system-type (list 'linux 'gnu/linux 'irix)) + (and (memq system-type '(gnu/linux irix)) (list "-c" "4")) "Options for the ping program. These options can be used to limit how many ICMP packets are emitted." @@ -889,5 +888,4 @@ from SEARCH-STRING. With argument, prompt for whois server." (provide 'net-utils) -;; arch-tag: 97119e91-9edb-4376-838b-bf7058fa1314 ;;; net-utils.el ends here diff --git a/lisp/net/netrc.el b/lisp/net/netrc.el index 17fea10cf62..1b0d4df53c2 100644 --- a/lisp/net/netrc.el +++ b/lisp/net/netrc.el @@ -4,6 +4,7 @@ ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news +;; ;; Modularized by Ted Zlatanov <tzz@lifelogs.com> ;; when it was part of Gnus. @@ -33,45 +34,44 @@ ;;; .netrc and .authinfo rc parsing ;;; -;; use encrypt if loaded (encrypt-file-alist has to be set as well) -(autoload 'encrypt-find-model "encrypt") -(autoload 'encrypt-insert-file-contents "encrypt") -(defalias 'netrc-point-at-eol - (if (fboundp 'point-at-eol) - 'point-at-eol - 'line-end-position)) -(defvar encrypt-file-alist) -(eval-when-compile - ;; This is unnecessary in the compiled version as it is a macro. - (if (fboundp 'bound-and-true-p) - (defalias 'netrc-bound-and-true-p 'bound-and-true-p) - (defmacro netrc-bound-and-true-p (var) - "Return the value of symbol VAR if it is bound, else nil." - `(and (boundp (quote ,var)) ,var)))) - (defgroup netrc nil "Netrc configuration." :group 'comm) +(defcustom netrc-file "~/.authinfo" + "File where user credentials are stored." + :type 'file + :group 'netrc) + (defvar netrc-services-file "/etc/services" "The name of the services file.") -(defun netrc-parse (file) +(defvar netrc-cache nil) + +(defun netrc-parse (&optional file) (interactive "fFile to Parse: ") "Parse FILE and return a list of all entries in the file." + (unless file + (setq file netrc-file)) (if (listp file) + ;; We got already parsed contents; just return it. file (when (file-exists-p file) (with-temp-buffer (let ((tokens '("machine" "default" "login" "password" "account" "macdef" "force" "port")) - (encryption-model (when (netrc-bound-and-true-p encrypt-file-alist) - (encrypt-find-model file))) alist elem result pair) - (if encryption-model - (encrypt-insert-file-contents file encryption-model) - (insert-file-contents file)) + (if (and netrc-cache + (equal (car netrc-cache) (nth 5 (file-attributes file)))) + ;; Store the contents of the file heavily encrypted in memory. + (insert (base64-decode-string (rot13-string (cdr netrc-cache)))) + (insert-file-contents file) + (when (string-match "\\.gpg\\'" file) + (setq netrc-cache (cons (nth 5 (file-attributes file)) + (rot13-string + (base64-encode-string + (buffer-string))))))) (goto-char (point-min)) ;; Go through the file, line by line. (while (not (eobp)) @@ -131,19 +131,23 @@ Entries without port tokens default to DEFAULTPORT." ;; No machine name matches, so we look for default entries. (while rest (when (assoc "default" (car rest)) - (push (car rest) result)) + (let ((elem (car rest))) + (setq elem (delete (assoc "default" elem) elem)) + (push elem result))) (pop rest))) (when result (setq result (nreverse result)) - (while (and result - (not (netrc-port-equal - (or port defaultport "nntp") - ;; when port is not given in the netrc file, - ;; it should mean "any port" - (or (netrc-get (car result) "port") - defaultport port)))) - (pop result)) - (car result)))) + (if (not port) + (car result) + (while (and result + (not (netrc-port-equal + (or port defaultport "nntp") + ;; when port is not given in the netrc file, + ;; it should mean "any port" + (or (netrc-get (car result) "port") + defaultport port)))) + (pop result)) + (car result))))) (defun netrc-machine-user-or-password (mode authinfo-file-or-list machines ports defaults) "Get the user name or password according to MODE from AUTHINFO-FILE-OR-LIST. @@ -159,9 +163,9 @@ MODE can be \"login\" or \"password\", suitable for passing to (defaults (or defaults '(nil))) info) (if (listp mode) - (setq info - (mapcar - (lambda (mode-element) + (setq info + (mapcar + (lambda (mode-element) (netrc-machine-user-or-password mode-element authinfo-list @@ -220,7 +224,33 @@ MODE can be \"login\" or \"password\", suitable for passing to (eq type (car (cddr service))))))) (cadr service))) +(defun netrc-store-data (file host port user password) + (with-temp-buffer + (when (file-exists-p file) + (insert-file-contents file)) + (goto-char (point-max)) + (unless (bolp) + (insert "\n")) + (insert (format "machine %s login %s password %s port %s\n" + host user password port)) + (write-region (point-min) (point-max) file nil 'silent))) + +;;;###autoload +(defun netrc-credentials (machine &rest ports) + "Return a user name/password pair. +Port specifications will be prioritised in the order they are +listed in the PORTS list." + (let ((list (netrc-parse)) + found) + (if (not ports) + (setq found (netrc-machine list machine)) + (while (and ports + (not found)) + (setq found (netrc-machine list machine (pop ports))))) + (when found + (list (cdr (assoc "login" found)) + (cdr (assoc "password" found)))))) + (provide 'netrc) -;; arch-tag: af9929cc-2d12-482f-936e-eb4366f9fa55 ;;; netrc.el ends here diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index 677a7c12780..95e87e8c688 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -8,6 +8,7 @@ ;; URL: http://www.nongnu.org/newsticker ;; Keywords: News, RSS, Atom ;; Time-stamp: "6. Dezember 2009, 19:15:32 (ulf)" +;; Package: newsticker ;; ====================================================================== diff --git a/lisp/net/newst-plainview.el b/lisp/net/newst-plainview.el index 5bf56bd9d7a..987c9f0413b 100644 --- a/lisp/net/newst-plainview.el +++ b/lisp/net/newst-plainview.el @@ -7,6 +7,7 @@ ;; Filename: newst-plainview.el ;; URL: http://www.nongnu.org/newsticker ;; Time-stamp: "6. Dezember 2009, 19:17:02 (ulf)" +;; Package: newsticker ;; ====================================================================== diff --git a/lisp/net/newst-reader.el b/lisp/net/newst-reader.el index 75f20f9b73a..92766cb0a41 100644 --- a/lisp/net/newst-reader.el +++ b/lisp/net/newst-reader.el @@ -7,6 +7,7 @@ ;; Filename: newst-reader.el ;; URL: http://www.nongnu.org/newsticker ;; Time-stamp: "6. Dezember 2009, 19:16:38 (ulf)" +;; Package: newsticker ;; ====================================================================== diff --git a/lisp/net/newst-ticker.el b/lisp/net/newst-ticker.el index 15fd13624be..6a9e12b8e5f 100644 --- a/lisp/net/newst-ticker.el +++ b/lisp/net/newst-ticker.el @@ -8,6 +8,7 @@ ;; URL: http://www.nongnu.org/newsticker ;; Keywords: News, RSS, Atom ;; Time-stamp: "6. Dezember 2009, 19:16:00 (ulf)" +;; Package: newsticker ;; ====================================================================== diff --git a/lisp/net/newst-treeview.el b/lisp/net/newst-treeview.el index 8afe22a7904..3552107a37a 100644 --- a/lisp/net/newst-treeview.el +++ b/lisp/net/newst-treeview.el @@ -8,6 +8,7 @@ ;; Created: 2007 ;; Keywords: News, RSS, Atom ;; Time-stamp: "6. Dezember 2009, 19:17:28 (ulf)" +;; Package: newsticker ;; ====================================================================== diff --git a/lisp/net/newsticker.el b/lisp/net/newsticker.el index 2f6897d64f4..c8ad9a32274 100644 --- a/lisp/net/newsticker.el +++ b/lisp/net/newsticker.el @@ -9,6 +9,7 @@ ;; Created: 17. June 2003 ;; Keywords: News, RSS, Atom ;; Time-stamp: "6. Dezember 2009, 19:15:18 (ulf)" +;; Version: 1.99 ;; ====================================================================== diff --git a/lisp/net/ntlm.el b/lisp/net/ntlm.el index 10bcb19a93a..78dd641d958 100644 --- a/lisp/net/ntlm.el +++ b/lisp/net/ntlm.el @@ -27,9 +27,9 @@ ;; This library is a direct translation of the Samba release 2.2.0 ;; implementation of Windows NT and LanManager compatible password ;; encryption. -;; +;; ;; Interface functions: -;; +;; ;; ntlm-build-auth-request ;; This will return a binary string, which should be used in the ;; base64 encoded form and it is the caller's responsibility to encode @@ -40,7 +40,7 @@ ;; (which will be a binary string) as the first argument and to ;; encode the returned string with base64. The second argument user ;; should be given in user@domain format. -;; +;; ;; ntlm-get-password-hashes ;; ;; @@ -534,5 +534,4 @@ into a Unicode string. PASSWD is truncated to 128 bytes if longer." (provide 'ntlm) -;; arch-tag: 348ace18-f8e2-4176-8fe9-d9ab4e96f296 ;;; ntlm.el ends here diff --git a/lisp/net/quickurl.el b/lisp/net/quickurl.el index 11f68533864..2312f7a2375 100644 --- a/lisp/net/quickurl.el +++ b/lisp/net/quickurl.el @@ -173,7 +173,20 @@ in your ~/.emacs (after loading/requiring quickurl).") (defvar quickurl-urls nil "URL alist for use with `quickurl' and `quickurl-ask'.") -(defvar quickurl-list-mode-map nil +(defvar quickurl-list-mode-map + (let ((map (make-sparse-keymap))) + (suppress-keymap map t) + (define-key map "a" #'quickurl-list-add-url) + (define-key map [(control m)] #'quickurl-list-insert-url) + (define-key map "u" #'quickurl-list-insert-naked-url) + (define-key map " " #'quickurl-list-insert-with-lookup) + (define-key map "l" #'quickurl-list-insert-lookup) + (define-key map "d" #'quickurl-list-insert-with-desc) + (define-key map [(control g)] #'quickurl-list-quit) + (define-key map "q" #'quickurl-list-quit) + (define-key map [mouse-2] #'quickurl-list-mouse-select) + (define-key map "?" #'describe-mode) + map) "Local keymap for a `quickurl-list-mode' buffer.") (defvar quickurl-list-buffer-name "*quickurl-list*" @@ -420,21 +433,6 @@ current buffer, this default action can be modifed via ;; quickurl-list mode. -(unless quickurl-list-mode-map - (let ((map (make-sparse-keymap))) - (suppress-keymap map t) - (define-key map "a" #'quickurl-list-add-url) - (define-key map [(control m)] #'quickurl-list-insert-url) - (define-key map "u" #'quickurl-list-insert-naked-url) - (define-key map " " #'quickurl-list-insert-with-lookup) - (define-key map "l" #'quickurl-list-insert-lookup) - (define-key map "d" #'quickurl-list-insert-with-desc) - (define-key map [(control g)] #'quickurl-list-quit) - (define-key map "q" #'quickurl-list-quit) - (define-key map [mouse-2] #'quickurl-list-mouse-select) - (define-key map "?" #'describe-mode) - (setq quickurl-list-mode-map map))) - (put 'quickurl-list-mode 'mode-class 'special) ;;;###autoload @@ -508,9 +506,7 @@ TYPE dictates what will be inserted, options are: `with-lookup' - Insert \"lookup <URL:url>\" `with-desc' - Insert \"description <URL:url>\" `lookup' - Insert the lookup for that URL" - (let ((url (nth (save-excursion - (beginning-of-line) - (count-lines (point-min) (point))) + (let ((url (nth (count-lines (point-min) (line-beginning-position)) quickurl-urls))) (if url (with-current-buffer quickurl-list-last-buffer @@ -544,5 +540,4 @@ TYPE dictates what will be inserted, options are: (provide 'quickurl) -;; arch-tag: a8183ea5-80c2-4082-a7d1-b0fdf2da467e ;;; quickurl.el ends here diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index b4f97466baa..964f9c44ccc 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -1,9 +1,11 @@ ;;; rcirc.el --- default, simple IRC client. -;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2005, 2006, 2007, 2008, 2009, 2010, 2011 +;; Free Software Foundation, Inc. -;; Author: Ryan Yeske -;; URL: http://www.nongnu.org/rcirc +;; Author: Ryan Yeske <rcyeske@gmail.com> +;; Maintainers: Ryan Yeske <rcyeske@gmail.com>, +;; Deniz Dogan <deniz.a.m.dogan@gmail.com> ;; Keywords: comm ;; This file is part of GNU Emacs. @@ -114,15 +116,15 @@ connected to automatically." :type 'string :group 'rcirc) -(defcustom rcirc-default-user-name (user-login-name) +(defcustom rcirc-default-user-name "user" "Your user name sent to the server when connecting." + :version "24.1" ; changed default :type 'string :group 'rcirc) -(defcustom rcirc-default-full-name (if (string= (user-full-name) "") - rcirc-default-user-name - (user-full-name)) +(defcustom rcirc-default-full-name "unknown" "The full name sent to the server when connecting." + :version "24.1" ; changed default :type 'string :group 'rcirc) @@ -375,6 +377,9 @@ and the cdr part is used for encoding." (defvar rcirc-nick-name-history nil "History variable for \\[rcirc] call.") +(defvar rcirc-user-name-history nil + "History variable for \\[rcirc] call.") + ;;;###autoload (defun rcirc (arg) "Connect to all servers in `rcirc-server-alist'. @@ -399,8 +404,12 @@ If ARG is non-nil, instead prompt for connection parameters." (or (plist-get server-plist :nick) rcirc-default-nick) 'rcirc-nick-name-history)) - (password (read-passwd "IRC Password: " - (plist-get server-plist 'password))) + (user-name (read-string "IRC Username: " + (or (plist-get server-plist :user-name) + rcirc-default-user-name) + 'rcirc-user-name-history)) + (password (read-passwd "IRC Password: " nil + (plist-get server-plist :password))) (channels (split-string (read-string "IRC Channels: " (mapconcat 'identity @@ -408,11 +417,7 @@ If ARG is non-nil, instead prompt for connection parameters." :channels) " ")) "[, ]+" t))) - - (when (= 0 (length password)) - (setq password nil)) - - (rcirc-connect server port nick rcirc-default-user-name + (rcirc-connect server port nick user-name rcirc-default-full-name channels password)) ;; connect to servers in `rcirc-server-alist' @@ -466,8 +471,8 @@ If ARG is non-nil, instead prompt for connection parameters." (defvar rcirc-process nil) ;;;###autoload -(defun rcirc-connect (server &optional port nick user-name full-name - startup-channels password) +(defun rcirc-connect (server &optional port nick user-name + full-name startup-channels password) (save-excursion (message "Connecting to %s..." server) (let* ((inhibit-eol-conversion) @@ -520,8 +525,7 @@ If ARG is non-nil, instead prompt for connection parameters." (rcirc-send-string process (concat "PASS " password))) (rcirc-send-string process (concat "NICK " nick)) (rcirc-send-string process (concat "USER " user-name - " hostname servername :" - full-name)) + " 0 * :" full-name)) ;; setup ping timer if necessary (unless rcirc-keepalive-timer @@ -771,42 +775,64 @@ If SILENT is non-nil, do not print the message in any irc buffer." (setq rcirc-input-ring-index (1- rcirc-input-ring-index)) (insert (rcirc-prev-input-string -1)))) -(defvar rcirc-nick-completions nil) -(defvar rcirc-nick-completion-start-offset nil) - -(defun rcirc-complete-nick () - "Cycle through nick completions from list of nicks in channel." +(defvar rcirc-server-commands + '("/admin" "/away" "/connect" "/die" "/error" "/info" + "/invite" "/ison" "/join" "/kick" "/kill" "/links" + "/list" "/lusers" "/mode" "/motd" "/names" "/nick" + "/notice" "/oper" "/part" "/pass" "/ping" "/pong" + "/privmsg" "/quit" "/rehash" "/restart" "/service" "/servlist" + "/server" "/squery" "/squit" "/stats" "/summon" "/time" + "/topic" "/trace" "/user" "/userhost" "/users" "/version" + "/wallops" "/who" "/whois" "/whowas") + "A list of user commands by IRC server. +The value defaults to RFCs 1459 and 2812.") + +;; /me and /ctcp are not defined by `defun-rcirc-command'. +(defvar rcirc-client-commands '("/me" "/ctcp") + "A list of user commands defined by IRC client rcirc. +The list is updated automatically by `defun-rcirc-command'.") + +(defun rcirc-completion-at-point () + "Function used for `completion-at-point-functions' in `rcirc-mode'." + (let* ((beg (save-excursion + (if (re-search-backward " " rcirc-prompt-end-marker t) + (1+ (point)) + rcirc-prompt-end-marker))) + (table (if (and (= beg rcirc-prompt-end-marker) + (eq (char-after beg) ?/)) + (delete-dups + (nconc + (sort (copy-sequence rcirc-client-commands) 'string-lessp) + (sort (copy-sequence rcirc-server-commands) 'string-lessp))) + (rcirc-channel-nicks (rcirc-buffer-process) rcirc-target)))) + (list beg (point) table))) + +(defvar rcirc-completions nil) +(defvar rcirc-completion-start nil) + +(defun rcirc-complete () + "Cycle through completions from list of nicks in channel or IRC commands. +IRC command completion is performed only if '/' is the first input char." (interactive) (if (eq last-command this-command) - (setq rcirc-nick-completions - (append (cdr rcirc-nick-completions) - (list (car rcirc-nick-completions)))) - (setq rcirc-nick-completion-start-offset - (- (save-excursion - (if (re-search-backward " " rcirc-prompt-end-marker t) - (1+ (point)) - rcirc-prompt-end-marker)) - rcirc-prompt-end-marker)) - (setq rcirc-nick-completions - (let ((completion-ignore-case t)) - (all-completions - (buffer-substring - (+ rcirc-prompt-end-marker - rcirc-nick-completion-start-offset) - (point)) - (mapcar (lambda (x) (cons x nil)) - (rcirc-channel-nicks (rcirc-buffer-process) - rcirc-target)))))) - (let ((completion (car rcirc-nick-completions))) + (setq rcirc-completions + (append (cdr rcirc-completions) (list (car rcirc-completions)))) + (let ((completion-ignore-case t) + (table (rcirc-completion-at-point))) + (setq rcirc-completion-start (car table)) + (setq rcirc-completions + (all-completions (buffer-substring rcirc-completion-start + (cadr table)) + (nth 2 table))))) + (let ((completion (car rcirc-completions))) (when completion - (delete-region (+ rcirc-prompt-end-marker - rcirc-nick-completion-start-offset) - (point)) - (insert (concat completion - (if (= (+ rcirc-prompt-end-marker - rcirc-nick-completion-start-offset) - rcirc-prompt-end-marker) - ": ")))))) + (delete-region rcirc-completion-start (point)) + (insert + (concat completion + (cond + ((= (aref completion 0) ?/) " ") + ((= rcirc-completion-start rcirc-prompt-end-marker) ": ") + (t ""))))))) (defun set-rcirc-decode-coding-system (coding-system) "Set the decode coding system used in this channel." @@ -824,7 +850,7 @@ If SILENT is non-nil, do not print the message in any irc buffer." (define-key rcirc-mode-map (kbd "RET") 'rcirc-send-input) (define-key rcirc-mode-map (kbd "M-p") 'rcirc-insert-prev-input) (define-key rcirc-mode-map (kbd "M-n") 'rcirc-insert-next-input) -(define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete-nick) +(define-key rcirc-mode-map (kbd "TAB") 'rcirc-complete) (define-key rcirc-mode-map (kbd "C-c C-b") 'rcirc-browse-url) (define-key rcirc-mode-map (kbd "C-c C-c") 'rcirc-edit-multiline) (define-key rcirc-mode-map (kbd "C-c C-j") 'rcirc-cmd-join) @@ -870,6 +896,7 @@ Each element looks like (FILENAME . TEXT).") This number is independent of the number of lines in the buffer.") (defun rcirc-mode (process target) + ;; FIXME: Use define-derived-mode. "Major mode for IRC channel buffers. \\{rcirc-mode-map}" @@ -945,7 +972,10 @@ This number is independent of the number of lines in the buffer.") rcirc-buffer-alist)))) (rcirc-update-short-buffer-names)) - (run-hooks 'rcirc-mode-hook)) + (add-hook 'completion-at-point-functions + 'rcirc-completion-at-point nil 'local) + + (run-mode-hooks 'rcirc-mode-hook)) (defun rcirc-update-prompt (&optional all) "Reset the prompt string in the current buffer. @@ -1339,6 +1369,12 @@ Logfiles are kept in `rcirc-log-directory'." :type 'integer :group 'rcirc) +(defcustom rcirc-log-process-buffers nil + "Non-nil if rcirc process buffers should be logged to disk." + :group 'rcirc + :type 'boolean + :version "24.1") + (defun rcirc-last-quit-line (process nick target) "Return the line number where NICK left TARGET. Returns nil if the information is not recorded." @@ -1504,14 +1540,21 @@ record activity." (when (not (rcirc-channel-p rcirc-target)) 'nick))) - (when rcirc-log-flag + (when (and rcirc-log-flag + (or target + rcirc-log-process-buffers)) (rcirc-log process sender response target text)) (sit-for 0) ; displayed text before hook (run-hook-with-args 'rcirc-print-hooks process sender response target text))))) -(defcustom rcirc-log-filename-function 'rcirc-generate-new-buffer-name +(defun rcirc-generate-log-filename (process target) + (if target + (rcirc-generate-new-buffer-name process target) + (process-name process))) + +(defcustom rcirc-log-filename-function 'rcirc-generate-log-filename "A function to generate the filename used by rcirc's logging facility. It is called with two arguments, PROCESS and TARGET (see @@ -1648,6 +1691,31 @@ if NICK is also on `rcirc-ignore-list-automatic'." rcirc-ignore-list (delete nick rcirc-ignore-list)))) +(defun rcirc-nickname< (s1 s2) + "Return t if IRC nickname S1 is less than S2, and nil otherwise. +Operator nicknames (@) are considered less than voiced +nicknames (+). Any other nicknames are greater than voiced +nicknames. The comparison is case-insensitive." + (setq s1 (downcase s1) + s2 (downcase s2)) + (let* ((s1-op (eq ?@ (string-to-char s1))) + (s2-op (eq ?@ (string-to-char s2)))) + (if s1-op + (if s2-op + (string< (substring s1 1) (substring s2 1)) + t) + (if s2-op + nil + (string< s1 s2))))) + +(defun rcirc-sort-nicknames-join (input sep) + "Return a string of sorted nicknames. +INPUT is a string containing nicknames separated by SEP. +This function does not alter the INPUT string." + (let* ((parts (split-string input sep t)) + (sorted (sort parts 'rcirc-nickname<))) + (mapconcat 'identity sorted sep))) + ;;; activity tracking (defvar rcirc-track-minor-mode-map (make-sparse-keymap) "Keymap for rcirc track minor mode.") @@ -1963,16 +2031,18 @@ activity. Only run if the buffer is not visible and ;; containing the text following the /cmd. (defmacro defun-rcirc-command (command argument docstring interactive-form - &rest body) + &rest body) "Define a command." - `(defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) - (,@argument &optional process target) - ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" - "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") - ,interactive-form - (let ((process (or process (rcirc-buffer-process))) - (target (or target rcirc-target))) - ,@body))) + `(progn + (add-to-list 'rcirc-client-commands ,(concat "/" (symbol-name command))) + (defun ,(intern (concat "rcirc-cmd-" (symbol-name command))) + (,@argument &optional process target) + ,(concat docstring "\n\nNote: If PROCESS or TARGET are nil, the values given" + "\nby `rcirc-buffer-process' and `rcirc-target' will be used.") + ,interactive-form + (let ((process (or process (rcirc-buffer-process))) + (target (or target rcirc-target))) + ,@body)))) (defun-rcirc-command msg (message) "Send private MESSAGE to TARGET." @@ -2561,7 +2631,8 @@ keywords when no KEYWORD is given." (buffer (rcirc-get-temp-buffer-create process channel))) (with-current-buffer buffer (rcirc-print process sender "NAMES" channel - (buffer-substring (point-min) (point-max)))) + (let ((content (buffer-substring (point-min) (point-max)))) + (rcirc-sort-nicknames-join content " ")))) (kill-buffer buffer))) (defun rcirc-handler-433 (process sender args text) diff --git a/lisp/net/rcompile.el b/lisp/net/rcompile.el index 7408109922d..bd98ab6dd37 100644 --- a/lisp/net/rcompile.el +++ b/lisp/net/rcompile.el @@ -75,7 +75,7 @@ (defcustom remote-compile-host nil - "*Host for remote compilations." + "Host for remote compilations." :type '(choice string (const nil)) :group 'remote-compile) @@ -86,7 +86,7 @@ nil means use the value returned by \\[user-login-name]." :group 'remote-compile) (defcustom remote-compile-run-before nil - "*Command to run before compilation. + "Command to run before compilation. This can be used for setting up environment variables, since rsh does not invoke the shell as a login shell and files like .login \(tcsh\) and .bash_profile \(bash\) are not run. @@ -95,12 +95,12 @@ nil means run no commands." :group 'remote-compile) (defcustom remote-compile-prompt-for-host nil - "*Non-nil means prompt for host if not available from filename." + "Non-nil means prompt for host if not available from filename." :type 'boolean :group 'remote-compile) (defcustom remote-compile-prompt-for-user nil - "*Non-nil means prompt for user if not available from filename." + "Non-nil means prompt for user if not available from filename." :type 'boolean :group 'remote-compile) diff --git a/lisp/net/rlogin.el b/lisp/net/rlogin.el index c7f86ba09b4..42b671fac6e 100644 --- a/lisp/net/rlogin.el +++ b/lisp/net/rlogin.el @@ -45,17 +45,17 @@ :group 'unix) (defcustom rlogin-program "rlogin" - "*Name of program to invoke rlogin" + "Name of program to invoke rlogin" :type 'string :group 'rlogin) (defcustom rlogin-explicit-args nil - "*List of arguments to pass to rlogin on the command line." + "List of arguments to pass to rlogin on the command line." :type '(repeat (string :tag "Argument")) :group 'rlogin) (defcustom rlogin-mode-hook nil - "*Hooks to run after setting current buffer to rlogin-mode." + "Hooks to run after setting current buffer to rlogin-mode." :type 'hook :group 'rlogin) @@ -68,7 +68,7 @@ (string-match "-solaris2" system-configuration)) t) (t nil))) - "*If non-nil, use a pty for the local rlogin process. + "If non-nil, use a pty for the local rlogin process. If nil, use a pipe (if pipes are supported on the local system). Generally it is better not to waste ptys on systems which have a static @@ -79,7 +79,7 @@ a pty is being used, and errors will result from using a pipe instead." :group 'rlogin) (defcustom rlogin-directory-tracking-mode 'local - "*Control whether and how to do directory tracking in an rlogin buffer. + "Control whether and how to do directory tracking in an rlogin buffer. nil means don't do directory tracking. @@ -103,12 +103,12 @@ re-synching of directories." (make-variable-buffer-local 'rlogin-directory-tracking-mode) (defcustom rlogin-host nil - "*The name of the remote host. This variable is buffer-local." + "The name of the remote host. This variable is buffer-local." :type '(choice (const nil) string) :group 'rlogin) (defcustom rlogin-remote-user nil - "*The username used on the remote host. + "The username used on the remote host. This variable is buffer-local and defaults to your local user name. If rlogin is invoked with the `-l' option to specify the remote username, this variable is set from that." @@ -249,7 +249,7 @@ If called with a positive, numeric prefix argument, e.g. ``\\[universal-argument] 1 M-x rlogin-directory-tracking-mode\'', then do directory tracking but assume the remote filesystem is the same as the local system. This only works in general if the remote machine and the -local one share the same directories (through NFS)." +local one share the same directories (e.g. through NFS)." (interactive "P") (cond ((or (null prefix) diff --git a/lisp/net/sasl-cram.el b/lisp/net/sasl-cram.el index 4c6704ef3e4..892029c5f0f 100644 --- a/lisp/net/sasl-cram.el +++ b/lisp/net/sasl-cram.el @@ -5,6 +5,7 @@ ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Kenichi OKADA <okada@opaopa.org> ;; Keywords: SASL, CRAM-MD5 +;; Package: sasl ;; This file is part of GNU Emacs. @@ -46,5 +47,4 @@ (provide 'sasl-cram) -;; arch-tag: 46cb281b-975a-4fe0-a39f-3018691b1b05 ;;; sasl-cram.el ends here diff --git a/lisp/net/sasl-digest.el b/lisp/net/sasl-digest.el index 488f2320702..f77d922ef97 100644 --- a/lisp/net/sasl-digest.el +++ b/lisp/net/sasl-digest.el @@ -5,6 +5,7 @@ ;; Author: Daiki Ueno <ueno@unixuser.org> ;; Kenichi OKADA <okada@opaopa.org> ;; Keywords: SASL, DIGEST-MD5 +;; Package: sasl ;; This file is part of GNU Emacs. @@ -94,10 +95,10 @@ charset algorithm cipher-opts auth-param)." (md5-binary (concat (encode-hex-string - (md5-binary (concat (md5-binary + (md5-binary (concat (md5-binary (concat username ":" realm ":" passphrase)) ":" nonce ":" cnonce - (if authzid + (if authzid (concat ":" authzid))))) ":" nonce ":" (format "%08x" nonce-count) ":" cnonce ":" qop ":" @@ -153,5 +154,4 @@ charset algorithm cipher-opts auth-param)." (provide 'sasl-digest) -;; arch-tag: 786e02ed-1bc4-4b3c-bf34-96c27e31084d ;;; sasl-digest.el ends here diff --git a/lisp/net/sasl-ntlm.el b/lisp/net/sasl-ntlm.el index 2577a337b71..9e9d76c1977 100644 --- a/lisp/net/sasl-ntlm.el +++ b/lisp/net/sasl-ntlm.el @@ -6,6 +6,7 @@ ;; Keywords: SASL, NTLM ;; Version: 1.00 ;; Created: February 2001 +;; Package: sasl ;; This file is part of GNU Emacs. @@ -62,5 +63,4 @@ challenge stored in the 2nd element of STEP. Called from `sasl-next-step'." (provide 'sasl-ntlm) -;; arch-tag: 1d9164c1-1df0-418f-b7ab-360157fd05dc ;;; sasl-ntlm.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index e78064a0a04..366958a8ce9 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -267,5 +267,4 @@ It contain at least 64 bits of entropy." (provide 'sasl) -;; arch-tag: 8b3326fa-4978-4fda-93e2-cb2c6255f887 ;;; sasl.el ends here diff --git a/lisp/net/secrets.el b/lisp/net/secrets.el new file mode 100644 index 00000000000..33376418025 --- /dev/null +++ b/lisp/net/secrets.el @@ -0,0 +1,868 @@ +;;; secrets.el --- Client interface to gnome-keyring and kwallet. + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm password passphrase + +;; 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This package provides an implementation of the Secret Service API +;; <http://www.freedesktop.org/wiki/Specifications/secret-storage-spec>. +;; This API is meant to make GNOME-Keyring- and KWallet-like daemons +;; available under a common D-BUS interface and thus increase +;; interoperability between GNOME, KDE and other applications having +;; the need to securely store passwords and other confidential +;; information. + +;; In order to activate this package, you must add the following code +;; into your .emacs: +;; +;; (require 'secrets) +;; +;; Afterwards, the variable `secrets-enabled' is non-nil when there is +;; a daemon providing this interface. + +;; The atomic objects to be managed by the Secret Service API are +;; secret items, which are something an application wishes to store +;; securely. A good example is a password that an application needs +;; to save and use at a later date. + +;; Secret items are grouped in collections. A collection is similar +;; in concept to the terms 'keyring' or 'wallet'. A common collection +;; is called "login". A collection is stored permanently under the +;; user's permissions, and can be accessed in a user session context. + +;; A collection can have an alias name. The use case for this is to +;; set the alias "default" for a given collection, making it +;; transparent for clients, which collection is used. Other aliases +;; are not supported (yet). Since an alias is visible to all +;; applications, this setting shall be performed with care. + +;; A list of all available collections is available by +;; +;; (secrets-list-collections) +;; => ("session" "login" "ssh keys") + +;; The "default" alias could be set to the "login" collection by +;; +;; (secrets-set-alias "login" "default") + +;; An alias can also be dereferenced +;; +;; (secrets-get-alias "default") +;; => "login" + +;; Collections can be created and deleted. As already said, +;; collections are used by different applications. Therefore, those +;; operations shall also be performed with care. Common collections, +;; like "login", shall not be changed except adding or deleting secret +;; items. +;; +;; (secrets-delete-collection "my collection") +;; (secrets-create-collection "my collection") + +;; There exists a special collection called "session", which has the +;; lifetime of the corrresponding client session (aka Emacs' +;; lifetime). It is created automatically when Emacs uses the Secret +;; Service interface, and it is deleted when Emacs is killed. +;; Therefore, it can be used to store and retrieve secret items +;; temporarily. This shall be preferred over creation of a persistent +;; collection, when the information shall not live longer than Emacs. +;; The session collection can be addressed either by the string +;; "session", or by `nil', whenever a collection parameter is needed. + +;; As already said, a collection is a group of secret items. A secret +;; item has a label, the "secret" (which is a string), and a set of +;; lookup attributes. The attributes can be used to search and +;; retrieve a secret item at a later date. + +;; A list of all available secret items of a collection is available by +;; +;; (secrets-list-items "my collection") +;; => ("this item" "another item") + +;; Secret items can be added or deleted to a collection. In the +;; following examples, we use the special collection "session", which +;; is bound to Emacs' lifetime. +;; +;; (secrets-delete-item "session" "my item") +;; (secrets-create-item "session" "my item" "geheim" +;; :user "joe" :host "remote-host") + +;; The string "geheim" is the secret of the secret item "my item". +;; The secret string can be retrieved from items: +;; +;; (secrets-get-secret "session" "my item") +;; => "geheim" + +;; The lookup attributes, which are specified during creation of a +;; secret item, must be a key-value pair. Keys are keyword symbols, +;; starting with a colon; values are strings. They can be retrieved +;; from a given secret item: +;; +;; (secrets-get-attribute "session" "my item" :host) +;; => "remote-host" +;; +;; (secrets-get-attributes "session" "my item") +;; => ((:user . "joe") (:host ."remote-host")) + +;; The lookup attributes can be used for searching of items. If you, +;; for example, are looking for all secret items for the user "joe", +;; you would perform +;; +;; (secrets-search-items "session" :user "joe") +;; => ("my item" "another item") + +;; Interactively, collections, items and their attributes could be +;; inspected by the command `secrets-show-secrets'. + +;;; Code: + +;; It has been tested with GNOME Keyring 2.29.92. An implementation +;; for KWallet will be available at +;; svn://anonsvn.kde.org/home/kde/trunk/playground/base/ksecretservice; +;; not tested yet. + +;; Pacify byte-compiler. D-Bus support in the Emacs core can be +;; disabled with configuration option "--without-dbus". Declare used +;; subroutines and variables of `dbus' therefore. +(eval-when-compile + (require 'cl)) + +(declare-function dbus-call-method "dbusbind.c") +(declare-function dbus-register-signal "dbusbind.c") +(defvar dbus-debug) + +(require 'dbus) + +(autoload 'tree-widget-set-theme "tree-widget") +(autoload 'widget-create-child-and-convert "wid-edit") +(autoload 'widget-default-value-set "wid-edit") +(autoload 'widget-field-end "wid-edit") +(autoload 'widget-member "wid-edit") +(defvar tree-widget-after-toggle-functions) + +(defvar secrets-enabled nil + "Whether there is a daemon offering the Secret Service API.") + +(defvar secrets-debug t + "Write debug messages") + +(defconst secrets-service "org.freedesktop.secrets" + "The D-Bus name used to talk to Secret Service.") + +(defconst secrets-path "/org/freedesktop/secrets" + "The D-Bus root object path used to talk to Secret Service.") + +(defconst secrets-empty-path "/" + "The D-Bus object path representing an empty object.") + +(defsubst secrets-empty-path (path) + "Check, whether PATH is a valid object path. +It returns t if not." + (or (not (stringp path)) + (string-equal path secrets-empty-path))) + +(defconst secrets-interface-service "org.freedesktop.Secret.Service" + "The D-Bus interface managing sessions and collections.") + +;; <interface name="org.freedesktop.Secret.Service"> +;; <property name="Collections" type="ao" access="read"/> +;; <method name="OpenSession"> +;; <arg name="algorithm" type="s" direction="in"/> +;; <arg name="input" type="v" direction="in"/> +;; <arg name="output" type="v" direction="out"/> +;; <arg name="result" type="o" direction="out"/> +;; </method> +;; <method name="CreateCollection"> +;; <arg name="props" type="a{sv}" direction="in"/> +;; <arg name="collection" type="o" direction="out"/> +;; <arg name="prompt" type="o" direction="out"/> +;; </method> +;; <method name="SearchItems"> +;; <arg name="attributes" type="a{ss}" direction="in"/> +;; <arg name="unlocked" type="ao" direction="out"/> +;; <arg name="locked" type="ao" direction="out"/> +;; </method> +;; <method name="Unlock"> +;; <arg name="objects" type="ao" direction="in"/> +;; <arg name="unlocked" type="ao" direction="out"/> +;; <arg name="prompt" type="o" direction="out"/> +;; </method> +;; <method name="Lock"> +;; <arg name="objects" type="ao" direction="in"/> +;; <arg name="locked" type="ao" direction="out"/> +;; <arg name="Prompt" type="o" direction="out"/> +;; </method> +;; <method name="GetSecrets"> +;; <arg name="items" type="ao" direction="in"/> +;; <arg name="session" type="o" direction="in"/> +;; <arg name="secrets" type="a{o(oayay)}" direction="out"/> +;; </method> +;; <method name="ReadAlias"> +;; <arg name="name" type="s" direction="in"/> +;; <arg name="collection" type="o" direction="out"/> +;; </method> +;; <method name="SetAlias"> +;; <arg name="name" type="s" direction="in"/> +;; <arg name="collection" type="o" direction="in"/> +;; </method> +;; <signal name="CollectionCreated"> +;; <arg name="collection" type="o"/> +;; </signal> +;; <signal name="CollectionDeleted"> +;; <arg name="collection" type="o"/> +;; </signal> +;; </interface> + +(defconst secrets-interface-collection "org.freedesktop.Secret.Collection" + "A collection of items containing secrets.") + +;; <interface name="org.freedesktop.Secret.Collection"> +;; <property name="Items" type="ao" access="read"/> +;; <property name="Label" type="s" access="readwrite"/> +;; <property name="Locked" type="s" access="read"/> +;; <property name="Created" type="t" access="read"/> +;; <property name="Modified" type="t" access="read"/> +;; <method name="Delete"> +;; <arg name="prompt" type="o" direction="out"/> +;; </method> +;; <method name="SearchItems"> +;; <arg name="attributes" type="a{ss}" direction="in"/> +;; <arg name="results" type="ao" direction="out"/> +;; </method> +;; <method name="CreateItem"> +;; <arg name="props" type="a{sv}" direction="in"/> +;; <arg name="secret" type="(oayay)" direction="in"/> +;; <arg name="replace" type="b" direction="in"/> +;; <arg name="item" type="o" direction="out"/> +;; <arg name="prompt" type="o" direction="out"/> +;; </method> +;; <signal name="ItemCreated"> +;; <arg name="item" type="o"/> +;; </signal> +;; <signal name="ItemDeleted"> +;; <arg name="item" type="o"/> +;; </signal> +;; <signal name="ItemChanged"> +;; <arg name="item" type="o"/> +;; </signal> +;; </interface> + +(defconst secrets-session-collection-path + "/org/freedesktop/secrets/collection/session" + "The D-Bus temporary session collection object path.") + +(defconst secrets-interface-prompt "org.freedesktop.Secret.Prompt" + "A session tracks state between the service and a client application.") + +;; <interface name="org.freedesktop.Secret.Prompt"> +;; <method name="Prompt"> +;; <arg name="window-id" type="s" direction="in"/> +;; </method> +;; <method name="Dismiss"></method> +;; <signal name="Completed"> +;; <arg name="dismissed" type="b"/> +;; <arg name="result" type="v"/> +;; </signal> +;; </interface> + +(defconst secrets-interface-item "org.freedesktop.Secret.Item" + "A collection of items containing secrets.") + +;; <interface name="org.freedesktop.Secret.Item"> +;; <property name="Locked" type="b" access="read"/> +;; <property name="Attributes" type="a{ss}" access="readwrite"/> +;; <property name="Label" type="s" access="readwrite"/> +;; <property name="Created" type="t" access="read"/> +;; <property name="Modified" type="t" access="read"/> +;; <method name="Delete"> +;; <arg name="prompt" type="o" direction="out"/> +;; </method> +;; <method name="GetSecret"> +;; <arg name="session" type="o" direction="in"/> +;; <arg name="secret" type="(oayay)" direction="out"/> +;; </method> +;; <method name="SetSecret"> +;; <arg name="secret" type="(oayay)" direction="in"/> +;; </method> +;; </interface> +;; +;; STRUCT secret +;; OBJECT PATH session +;; ARRAY BYTE parameters +;; ARRAY BYTE value + +(defconst secrets-interface-item-type-generic "org.freedesktop.Secret.Generic" + "The default item type we are using.") + +(defconst secrets-interface-session "org.freedesktop.Secret.Session" + "A session tracks state between the service and a client application.") + +;; <interface name="org.freedesktop.Secret.Session"> +;; <method name="Close"></method> +;; </interface> + +;;; Sessions. + +(defvar secrets-session-path secrets-empty-path + "The D-Bus session path of the active session. +A session path `secrets-empty-path' indicates there is no open session.") + +(defun secrets-close-session () + "Close the secret service session, if any." + (dbus-ignore-errors + (dbus-call-method + :session secrets-service secrets-session-path + secrets-interface-session "Close")) + (setq secrets-session-path secrets-empty-path)) + +(defun secrets-open-session (&optional reopen) + "Open a new session with \"plain\" algorithm. +If there exists another active session, and REOPEN is nil, that +session will be used. The object path of the session will be +returned, and it will be stored in `secrets-session-path'." + (when reopen (secrets-close-session)) + (when (secrets-empty-path secrets-session-path) + (setq secrets-session-path + (cadr + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "OpenSession" "plain" '(:variant ""))))) + (when secrets-debug + (message "Secret Service session: %s" secrets-session-path)) + secrets-session-path) + +;;; Prompts. + +(defvar secrets-prompt-signal nil + "Internal variable to catch signals from `secrets-interface-prompt'.") + +(defun secrets-prompt (prompt) + "Handle the prompt identified by object path PROMPT." + (unless (secrets-empty-path prompt) + (let ((object + (dbus-register-signal + :session secrets-service prompt + secrets-interface-prompt "Completed" 'secrets-prompt-handler))) + (dbus-call-method + :session secrets-service prompt + secrets-interface-prompt "Prompt" (frame-parameter nil 'window-id)) + (unwind-protect + (progn + ;; Wait until the returned prompt signal has put the + ;; result into `secrets-prompt-signal'. + (while (null secrets-prompt-signal) + (read-event nil nil 0.1)) + ;; Return the object(s). It is a variant, so we must use a car. + (car secrets-prompt-signal)) + ;; Cleanup. + (setq secrets-prompt-signal nil) + (dbus-unregister-object object))))) + +(defun secrets-prompt-handler (&rest args) + "Handler for signals emitted by `secrets-interface-prompt'." + ;; An empty object path is always identified as `secrets-empty-path' + ;; or `nil'. Either we set it explicitely, or it is returned by the + ;; "Completed" signal. + (if (car args) ;; dismissed + (setq secrets-prompt-signal (list secrets-empty-path)) + (setq secrets-prompt-signal (cadr args)))) + +;;; Collections. + +(defvar secrets-collection-paths nil + "Cached D-Bus object paths of available collections.") + +(defun secrets-collection-handler (&rest args) + "Handler for signals emitted by `secrets-interface-service'." + (cond + ((string-equal (dbus-event-member-name last-input-event) "CollectionCreated") + (add-to-list 'secrets-collection-paths (car args))) + ((string-equal (dbus-event-member-name last-input-event) "CollectionDeleted") + (setq secrets-collection-paths + (delete (car args) secrets-collection-paths))))) + +(defun secrets-get-collections () + "Return the object paths of all available collections." + (setq secrets-collection-paths + (or secrets-collection-paths + (dbus-get-property + :session secrets-service secrets-path + secrets-interface-service "Collections")))) + +(defun secrets-get-collection-properties (collection-path) + "Return all properties of collection identified by COLLECTION-PATH." + (unless (secrets-empty-path collection-path) + (dbus-get-all-properties + :session secrets-service collection-path + secrets-interface-collection))) + +(defun secrets-get-collection-property (collection-path property) + "Return property PROPERTY of collection identified by COLLECTION-PATH." + (unless (or (secrets-empty-path collection-path) (not (stringp property))) + (dbus-get-property + :session secrets-service collection-path + secrets-interface-collection property))) + +(defun secrets-list-collections () + "Return a list of collection names." + (mapcar + (lambda (collection-path) + (if (string-equal collection-path secrets-session-collection-path) + "session" + (secrets-get-collection-property collection-path "Label"))) + (secrets-get-collections))) + +(defun secrets-collection-path (collection) + "Return the object path of collection labelled COLLECTION. +If COLLECTION is nil, return the session collection path. +If there is no such COLLECTION, return nil." + (or + ;; The "session" collection. + (if (or (null collection) (string-equal "session" collection)) + secrets-session-collection-path) + ;; Check for an alias. + (let ((collection-path + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "ReadAlias" collection))) + (unless (secrets-empty-path collection-path) + collection-path)) + ;; Check the collections. + (catch 'collection-found + (dolist (collection-path (secrets-get-collections) nil) + (when (string-equal + collection + (secrets-get-collection-property collection-path "Label")) + (throw 'collection-found collection-path)))))) + +(defun secrets-create-collection (collection) + "Create collection labelled COLLECTION if it doesn't exist. +Return the D-Bus object path for collection." + (let ((collection-path (secrets-collection-path collection))) + ;; Create the collection. + (when (secrets-empty-path collection-path) + (setq collection-path + (secrets-prompt + (cadr + ;; "CreateCollection" returns the prompt path as second arg. + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "CreateCollection" + `(:array (:dict-entry "Label" (:variant ,collection)))))))) + ;; Return object path of the collection. + collection-path)) + +(defun secrets-get-alias (alias) + "Return the collection name ALIAS is referencing to. +For the time being, only the alias \"default\" is supported." + (secrets-get-collection-property + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "ReadAlias" alias) + "Label")) + +(defun secrets-set-alias (collection alias) + "Set ALIAS as alias of collection labelled COLLECTION. +For the time being, only the alias \"default\" is supported." + (let ((collection-path (secrets-collection-path collection))) + (unless (secrets-empty-path collection-path) + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "SetAlias" + alias :object-path collection-path)))) + +(defun secrets-delete-alias (alias) + "Delete ALIAS, referencing to a collection." + (dbus-call-method + :session secrets-service secrets-path + secrets-interface-service "SetAlias" + alias :object-path secrets-empty-path)) + +(defun secrets-unlock-collection (collection) + "Unlock collection labelled COLLECTION. +If successful, return the object path of the collection." + (let ((collection-path (secrets-collection-path collection))) + (unless (secrets-empty-path collection-path) + (secrets-prompt + (cadr + (dbus-call-method + :session secrets-service secrets-path secrets-interface-service + "Unlock" `(:array :object-path ,collection-path))))) + collection-path)) + +(defun secrets-delete-collection (collection) + "Delete collection labelled COLLECTION." + (let ((collection-path (secrets-collection-path collection))) + (unless (secrets-empty-path collection-path) + (secrets-prompt + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "Delete"))))) + +;;; Items. + +(defun secrets-get-items (collection-path) + "Return the object paths of all available items in COLLECTION-PATH." + (unless (secrets-empty-path collection-path) + (secrets-open-session) + (dbus-get-property + :session secrets-service collection-path + secrets-interface-collection "Items"))) + +(defun secrets-get-item-properties (item-path) + "Return all properties of item identified by ITEM-PATH." + (unless (secrets-empty-path item-path) + (dbus-get-all-properties + :session secrets-service item-path + secrets-interface-item))) + +(defun secrets-get-item-property (item-path property) + "Return property PROPERTY of item identified by ITEM-PATH." + (unless (or (secrets-empty-path item-path) (not (stringp property))) + (dbus-get-property + :session secrets-service item-path + secrets-interface-item property))) + +(defun secrets-list-items (collection) + "Return a list of all item labels of COLLECTION." + (let ((collection-path (secrets-unlock-collection collection))) + (unless (secrets-empty-path collection-path) + (mapcar + (lambda (item-path) + (secrets-get-item-property item-path "Label")) + (secrets-get-items collection-path))))) + +(defun secrets-search-items (collection &rest attributes) + "Search items in COLLECTION with ATTRIBUTES. +ATTRIBUTES are key-value pairs. The keys are keyword symbols, +starting with a colon. Example: + + \(secrets-create-item \"Tramp collection\" \"item\" \"geheim\" + :method \"sudo\" :user \"joe\" :host \"remote-host\"\) + +The object paths of the found items are returned as list." + (let ((collection-path (secrets-unlock-collection collection)) + result props) + (unless (secrets-empty-path collection-path) + ;; Create attributes list. + (while (consp (cdr attributes)) + (unless (keywordp (car attributes)) + (error 'wrong-type-argument (car attributes))) + (setq props (add-to-list + 'props + (list :dict-entry + (substring (symbol-name (car attributes)) 1) + (cadr attributes)) + 'append) + attributes (cddr attributes))) + ;; Search. The result is a list of two lists, the object paths + ;; of the unlocked and the locked items. + (setq result + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "SearchItems" + (if props + (cons :array props) + '(:array :signature "{ss}")))) + ;; Return the found items. + (mapcar + (lambda (item-path) (secrets-get-item-property item-path "Label")) + (append (car result) (cadr result)))))) + +(defun secrets-create-item (collection item password &rest attributes) + "Create a new item in COLLECTION with label ITEM and password PASSWORD. +ATTRIBUTES are key-value pairs set for the created item. The +keys are keyword symbols, starting with a colon. Example: + + \(secrets-create-item \"Tramp collection\" \"item\" \"geheim\" + :method \"sudo\" :user \"joe\" :host \"remote-host\"\) + +The object path of the created item is returned." + (unless (member item (secrets-list-items collection)) + (let ((collection-path (secrets-unlock-collection collection)) + result props) + (unless (secrets-empty-path collection-path) + ;; Create attributes list. + (while (consp (cdr attributes)) + (unless (keywordp (car attributes)) + (error 'wrong-type-argument (car attributes))) + (setq props (add-to-list + 'props + (list :dict-entry + (substring (symbol-name (car attributes)) 1) + (cadr attributes)) + 'append) + attributes (cddr attributes))) + ;; Create the item. + (setq result + (dbus-call-method + :session secrets-service collection-path + secrets-interface-collection "CreateItem" + ;; Properties. + (append + `(:array + (:dict-entry "Label" (:variant ,item)) + (:dict-entry + "Type" (:variant ,secrets-interface-item-type-generic))) + (when props + `((:dict-entry + "Attributes" (:variant ,(append '(:array) props)))))) + ;; Secret. + `(:struct :object-path ,secrets-session-path + (:array :signature "y") ;; no parameters. + ,(dbus-string-to-byte-array password)) + ;; Do not replace. Replace does not seem to work. + nil)) + (secrets-prompt (cadr result)) + ;; Return the object path. + (car result))))) + +(defun secrets-item-path (collection item) + "Return the object path of item labelled ITEM in COLLECTION. +If there is no such item, return nil." + (let ((collection-path (secrets-unlock-collection collection))) + (catch 'item-found + (dolist (item-path (secrets-get-items collection-path)) + (when (string-equal item (secrets-get-item-property item-path "Label")) + (throw 'item-found item-path)))))) + +(defun secrets-get-secret (collection item) + "Return the secret of item labelled ITEM in COLLECTION. +If there is no such item, return nil." + (let ((item-path (secrets-item-path collection item))) + (unless (secrets-empty-path item-path) + (dbus-byte-array-to-string + (caddr + (dbus-call-method + :session secrets-service item-path secrets-interface-item + "GetSecret" :object-path secrets-session-path)))))) + +(defun secrets-get-attributes (collection item) + "Return the lookup attributes of item labelled ITEM in COLLECTION. +If there is no such item, or the item has no attributes, return nil." + (unless (stringp collection) (setq collection "default")) + (let ((item-path (secrets-item-path collection item))) + (unless (secrets-empty-path item-path) + (mapcar + (lambda (attribute) + (cons (intern (concat ":" (car attribute))) (cadr attribute))) + (dbus-get-property + :session secrets-service item-path + secrets-interface-item "Attributes"))))) + +(defun secrets-get-attribute (collection item attribute) + "Return the value of ATTRIBUTE of item labelled ITEM in COLLECTION. +If there is no such item, or the item doesn't own this attribute, return nil." + (cdr (assoc attribute (secrets-get-attributes collection item)))) + +(defun secrets-delete-item (collection item) + "Delete ITEM in COLLECTION." + (let ((item-path (secrets-item-path collection item))) + (unless (secrets-empty-path item-path) + (secrets-prompt + (dbus-call-method + :session secrets-service item-path + secrets-interface-item "Delete"))))) + +;;; Visualization. + +(define-derived-mode secrets-mode nil "Secrets" + "Major mode for presenting password entries retrieved by Security Service. +In this mode, widgets represent the search results. + +\\{secrets-mode-map}" + ;; Keymap. + (setq secrets-mode-map (copy-keymap special-mode-map)) + (set-keymap-parent secrets-mode-map widget-keymap) + (define-key secrets-mode-map "z" 'kill-this-buffer) + + ;; When we toggle, we must set temporary widgets. + (set (make-local-variable 'tree-widget-after-toggle-functions) + '(secrets-tree-widget-after-toggle-function)) + + (when (not (called-interactively-p 'interactive)) + ;; Initialize buffer. + (setq buffer-read-only t) + (let ((inhibit-read-only t)) + (erase-buffer)))) + +;; It doesn't make sense to call it interactively. +(put 'secrets-mode 'disabled t) + +;; The very first buffer created with `secrets-mode' does not have the +;; keymap etc. So we create a dummy buffer. Stupid. +(with-temp-buffer (secrets-mode)) + +;; We autoload `secrets-show-secrets' only on systems with D-Bus support. +;;;###autoload(when (featurep 'dbusbind) +;;;###autoload (autoload 'secrets-show-secrets "secrets" nil t)) + +(defun secrets-show-secrets () + "Display a list of collections from the Secret Service API. +The collections are in tree view, that means they can be expanded +to the corresponding secret items, which could also be expanded +to their attributes." + (interactive) + + ;; Check, whether the Secret Service API is enabled. + (if (null secrets-enabled) + (message "Secret Service not available") + + ;; Create the search buffer. + (with-current-buffer (get-buffer-create "*Secrets*") + (switch-to-buffer-other-window (current-buffer)) + ;; Inialize buffer with `secrets-mode'. + (secrets-mode) + (secrets-show-collections)))) + +(defun secrets-show-collections () + "Show all available collections." + (let ((inhibit-read-only t) + (alias (secrets-get-alias "default"))) + (erase-buffer) + (tree-widget-set-theme "folder") + (dolist (coll (secrets-list-collections)) + (widget-create + `(tree-widget + :tag ,coll + :collection ,coll + :open nil + :sample-face bold + :expander secrets-expand-collection))))) + +(defun secrets-expand-collection (widget) + "Expand items of collection shown as WIDGET." + (let ((coll (widget-get widget :collection))) + (mapcar + (lambda (item) + `(tree-widget + :tag ,item + :collection ,coll + :item ,item + :open nil + :sample-face bold + :expander secrets-expand-item)) + (secrets-list-items coll)))) + +(defun secrets-expand-item (widget) + "Expand password and attributes of item shown as WIDGET." + (let* ((coll (widget-get widget :collection)) + (item (widget-get widget :item)) + (attributes (secrets-get-attributes coll item)) + ;; padding is needed to format attribute names. + (padding + (apply + 'max + (cons + (1+ (length "password")) + (mapcar + ;; Atribute names have a leading ":", which will be suppressed. + (lambda (attribute) (length (symbol-name (car attribute)))) + attributes))))) + (cons + ;; The password widget. + `(editable-field :tag "password" + :secret ?* + :value ,(secrets-get-secret coll item) + :sample-face widget-button-pressed + ;; We specify :size in order to limit the field. + :size 0 + :format ,(concat + "%{%t%}:" + (make-string (- padding (length "password")) ? ) + "%v\n")) + (mapcar + (lambda (attribute) + (let ((name (substring (symbol-name (car attribute)) 1)) + (value (cdr attribute))) + ;; The attribute widget. + `(editable-field :tag ,name + :value ,value + :sample-face widget-documentation + ;; We specify :size in order to limit the field. + :size 0 + :format ,(concat + "%{%t%}:" + (make-string (- padding (length name)) ? ) + "%v\n")))) + attributes)))) + +(defun secrets-tree-widget-after-toggle-function (widget &rest ignore) + "Add a temporary widget to show the password." + (dolist (child (widget-get widget :children)) + (when (widget-member child :secret) + (goto-char (widget-field-end child)) + (widget-insert " ") + (widget-create-child-and-convert + child 'push-button + :notify 'secrets-tree-widget-show-password + "Show password"))) + (widget-setup)) + +(defun secrets-tree-widget-show-password (widget &rest ignore) + "Show password, and remove temporary widget." + (let ((parent (widget-get widget :parent))) + (widget-put parent :secret nil) + (widget-default-value-set parent (widget-get parent :value)) + (widget-setup))) + +;;; Initialization. + +(when (dbus-ping :session secrets-service 100) + + ;; We must reset all variables, when there is a new instance of the + ;; "org.freedesktop.secrets" service. + (dbus-register-signal + :session dbus-service-dbus dbus-path-dbus + dbus-interface-dbus "NameOwnerChanged" + (lambda (&rest args) + (when secrets-debug (message "Secret Service has changed: %S" args)) + (setq secrets-session-path secrets-empty-path + secrets-prompt-signal nil + secrets-collection-paths nil)) + secrets-service) + + ;; We want to refresh our cache, when there is a change in + ;; collections. + (dbus-register-signal + :session secrets-service secrets-path + secrets-interface-service "CollectionCreated" + 'secrets-collection-handler) + + (dbus-register-signal + :session secrets-service secrets-path + secrets-interface-service "CollectionDeleted" + 'secrets-collection-handler) + + ;; We shall inform, whether the secret service is enabled on this + ;; machine. + (setq secrets-enabled t)) + +(provide 'secrets) + +;;; TODO: + +;; * secrets-debug should be structured like auth-source-debug to +;; prevent leaking sensitive information. Right now I don't see +;; anything sensitive though. +;; * Check, whether the dh-ietf1024-aes128-cbc-pkcs7 algorithm can be +;; used for the transfer of the secrets. Currently, we use the +;; plain algorithm. diff --git a/lisp/net/telnet.el b/lisp/net/telnet.el index a9c997c4341..5403e3b3350 100644 --- a/lisp/net/telnet.el +++ b/lisp/net/telnet.el @@ -61,7 +61,15 @@ PROGRAM says which program to run, to talk to that machine. LOGIN-NAME, which is optional, says what to log in as on that machine.") (defvar telnet-new-line "\r") -(defvar telnet-mode-map nil) +(defvar telnet-mode-map + (let ((map (nconc (make-sparse-keymap) comint-mode-map))) + (define-key map "\C-m" 'telnet-send-input) + ;; (define-key map "\C-j" 'telnet-send-input) + (define-key map "\C-c\C-q" 'send-process-next-char) + (define-key map "\C-c\C-c" 'telnet-interrupt-subjob) + (define-key map "\C-c\C-z" 'telnet-c-z) + map)) + (defvar telnet-prompt-pattern "^[^#$%>\n]*[#$%>] *") (defvar telnet-replace-c-g nil) (make-variable-buffer-local @@ -104,16 +112,6 @@ rejecting one login and prompting again for a username and password.") (prog1 (read-char) (setq quit-flag nil)))))) -; initialization on first load. -(if telnet-mode-map - nil - (setq telnet-mode-map (nconc (make-sparse-keymap) comint-mode-map)) - (define-key telnet-mode-map "\C-m" 'telnet-send-input) -; (define-key telnet-mode-map "\C-j" 'telnet-send-input) - (define-key telnet-mode-map "\C-c\C-q" 'send-process-next-char) - (define-key telnet-mode-map "\C-c\C-c" 'telnet-interrupt-subjob) - (define-key telnet-mode-map "\C-c\C-z" 'telnet-c-z)) - ;;maybe should have a flag for when have found type (defun telnet-check-software-type-initialize (string) "Tries to put correct initializations in. Needs work." diff --git a/lisp/net/tls.el b/lisp/net/tls.el index 57c295b3672..a19797398d1 100644 --- a/lisp/net/tls.el +++ b/lisp/net/tls.el @@ -75,8 +75,8 @@ and `gnutls-cli' (version 2.0.1) output." :type 'regexp :group 'tls) -(defcustom tls-program '("gnutls-cli -p %p %h" - "gnutls-cli -p %p %h --protocols ssl3" +(defcustom tls-program '("gnutls-cli --insecure -p %p %h" + "gnutls-cli --insecure -p %p %h --protocols ssl3" "openssl s_client -connect %h:%p -no_ssl2 -ign_eof") "List of strings containing commands to start TLS stream to a host. Each entry in the list is tried until a connection is successful. @@ -238,6 +238,10 @@ Fourth arg PORT is an integer specifying a port to connect to." (setq process (start-process name buffer shell-file-name shell-command-switch formatted-cmd)) + (funcall (if (fboundp 'set-process-query-on-exit-flag) + 'set-process-query-on-exit-flag + 'process-kill-without-query) + process nil) (while (and process (memq (process-status process) '(open run)) (progn @@ -298,5 +302,4 @@ match `%s'. Connect anyway? " host)))))) (provide 'tls) -;; arch-tag: 5596d1c4-facc-4bc4-94a9-9863b928d7ac ;;; tls.el ends here diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 3b0e93e5c92..bea8c315fb9 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -6,6 +6,7 @@ ;; Author: Daniel Pittman <daniel@inanna.danann.net> ;; Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -49,37 +50,20 @@ ;;; 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 'tramp-run-real-handler "tramp") - (autoload 'tramp-time-less-p "tramp") - (autoload 'time-stamp-string "time-stamp")) +(require 'tramp) +(autoload 'time-stamp-string "time-stamp") ;;; -- Cache -- +;;;###tramp-autoload (defvar tramp-cache-data (make-hash-table :test 'equal) "Hash table for remote files properties.") -(defvar tramp-cache-inhibit-cache nil - "Inhibit cache read access, when `t'. -`nil' means to accept cache entries unconditionally. If the -value is a timestamp (as returned by `current-time'), cache -entries are not used when they have been written before this -time.") - (defcustom tramp-persistency-file-name (cond ;; GNU Emacs. + ((and (fboundp 'locate-user-emacs-file)) + (expand-file-name (tramp-compat-funcall 'locate-user-emacs-file "tramp"))) ((and (boundp 'user-emacs-directory) (stringp (symbol-value 'user-emacs-directory)) (file-directory-p (symbol-value 'user-emacs-directory))) @@ -102,6 +86,7 @@ time.") (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload (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." @@ -114,21 +99,28 @@ Returns DEFAULT if not set." (value (when (hash-table-p hash) (gethash property hash)))) (if ;; We take the value only if there is any, and - ;; `tramp-cache-inhibit-cache' indicates that it is still + ;; `remote-file-name-inhibit-cache' indicates that it is still ;; valid. Otherwise, DEFAULT is set. (and (consp value) - (or (null tramp-cache-inhibit-cache) - (and (consp tramp-cache-inhibit-cache) + (or (null remote-file-name-inhibit-cache) + (and (integerp remote-file-name-inhibit-cache) + (<= + (tramp-time-diff (current-time) (car value)) + remote-file-name-inhibit-cache)) + (and (consp remote-file-name-inhibit-cache) (tramp-time-less-p - tramp-cache-inhibit-cache (car value))))) + remote-file-name-inhibit-cache (car value))))) (setq value (cdr value)) (setq value default)) - (if (consp tramp-cache-inhibit-cache) - (tramp-message vec 1 "%s %s %s" file property value)) (tramp-message vec 8 "%s %s %s" file property value) + (when (>= tramp-verbose 10) + (let* ((var (intern (concat "tramp-cache-get-count-" property))) + (val (or (ignore-errors (symbol-value var)) 0))) + (set var (1+ val)))) value)) +;;;###tramp-autoload (defun tramp-set-file-property (vec file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of VEC. Returns VALUE." @@ -141,8 +133,34 @@ Returns VALUE." ;; We put the timestamp there. (puthash property (cons (current-time) value) hash) (tramp-message vec 8 "%s %s %s" file property value) + (when (>= tramp-verbose 10) + (let* ((var (intern (concat "tramp-cache-set-count-" property))) + (val (or (ignore-errors (symbol-value var)) 0))) + (set var (1+ val)))) value)) +;;;###tramp-autoload +(defmacro with-file-property (vec file property &rest body) + "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. +FILE must be a local file name on a connection identified via VEC." + `(if (file-name-absolute-p ,file) + (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) + (when (eq value 'undef) + ;; We cannot pass @body as parameter to + ;; `tramp-set-file-property' because it mangles our + ;; debug messages. + (setq value (progn ,@body)) + (tramp-set-file-property ,vec ,file ,property value)) + value) + ,@body)) + +;;;###tramp-autoload +(put 'with-file-property 'lisp-indent-function 3) +(put 'with-file-property 'edebug-form-spec t) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-file-property\\>")) + +;;;###tramp-autoload (defun tramp-flush-file-property (vec file) "Remove all properties of FILE in the cache context of VEC." ;; Unify localname. @@ -151,6 +169,7 @@ Returns VALUE." (tramp-message vec 8 "%s" file) (remhash vec tramp-cache-data)) +;;;###tramp-autoload (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." @@ -174,8 +193,7 @@ Remove also properties of all files in subdirectories." (buffer-file-name) default-directory))) (when (tramp-tramp-file-p bfn) - (let* ((v (tramp-dissect-file-name bfn)) - (localname (tramp-file-name-localname v))) + (with-parsed-tramp-file-name bfn nil (tramp-flush-file-property v localname))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) @@ -192,6 +210,7 @@ Remove also properties of all files in subdirectories." ;;; -- Properties -- +;;;###tramp-autoload (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. @@ -208,6 +227,7 @@ If the value is not set for the connection, returns DEFAULT." (tramp-message key 7 "%s %s" property value) value)) +;;;###tramp-autoload (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. @@ -222,14 +242,28 @@ PROPERTY is set persistent when KEY is a vector." tramp-cache-data)))) (puthash property value hash) (setq tramp-cache-data-changed t) - ;; 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)) + (tramp-message key 7 "%s %s" property value) + value)) + +;;;###tramp-autoload +(defmacro with-connection-property (key property &rest body) + "Check in Tramp for property PROPERTY, otherwise executes BODY and set." + `(let ((value (tramp-get-connection-property ,key ,property 'undef))) + (when (eq value 'undef) + ;; We cannot pass ,@body as parameter to + ;; `tramp-set-connection-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-connection-property ,key ,property value)) value)) +;;;###tramp-autoload +(put 'with-connection-property 'lisp-indent-function 2) +(put 'with-connection-property 'edebug-form-spec t) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-connection-property\\>")) + +;;;###tramp-autoload (defun tramp-flush-connection-property (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a vector." @@ -250,6 +284,7 @@ KEY identifies the connection, it is either a process or a vector." (setq tramp-cache-data-changed t) (remhash key tramp-cache-data)) +;;;###tramp-autoload (defun tramp-cache-print (table) "Print hash table TABLE." (when (hash-table-p table) @@ -270,6 +305,7 @@ KEY identifies the connection, it is either a process or a vector." table) result))) +;;;###tramp-autoload (defun tramp-list-connections () "Return a list of all known connection vectors according to `tramp-cache'." (let (result) @@ -283,41 +319,40 @@ KEY identifies the connection, it is either a process or a vector." (defun tramp-dump-connection-properties () "Write 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))) - tramp-cache-data-changed - (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 "first-password-request" 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))) + (ignore-errors + (when (and (hash-table-p tramp-cache-data) + (not (zerop (hash-table-count tramp-cache-data))) + tramp-cache-data-changed + (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 "first-password-request" 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)))))) (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties) (add-hook 'tramp-cache-unload-hook @@ -325,6 +360,7 @@ KEY identifies the connection, it is either a process or a vector." (remove-hook 'kill-emacs-hook 'tramp-dump-connection-properties))) +;;;###tramp-autoload (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' @@ -363,7 +399,10 @@ for all methods. Resulting data are derived from connection history." tramp-persistency-file-name (error-message-string err)) (clrhash tramp-cache-data)))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-cache 'force))) + (provide 'tramp-cache) -;; arch-tag: ee1739b7-7628-408c-9b96-d11a74b05d26 ;;; tramp-cache.el ends here diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 97f875f2cff..46f8d655544 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -4,6 +4,7 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -49,6 +50,7 @@ x))) (buffer-list)))) +;;;###tramp-autoload (defun tramp-cleanup-connection (vec) "Flush all connection related objects. This includes password cache, file cache, connection cache, buffers. @@ -97,6 +99,7 @@ When called interactively, a Tramp connection has to be selected." (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))))) +;;;###tramp-autoload (defun tramp-cleanup-all-connections () "Flush all Tramp internal objects. This includes password cache, file cache, connection cache, buffers." @@ -115,6 +118,7 @@ This includes password cache, file cache, connection cache, buffers." (dolist (name (tramp-list-tramp-buffers)) (when (bufferp (get-buffer name)) (kill-buffer name)))) +;;;###tramp-autoload (defun tramp-cleanup-all-buffers () "Kill all remote buffers." (interactive) @@ -128,6 +132,7 @@ This includes password cache, file cache, connection cache, buffers." ;; Tramp version is useful in a number of situations. +;;;###tramp-autoload (defun tramp-version (arg) "Print version number of tramp.el in minibuffer or current buffer." (interactive "P") @@ -138,6 +143,7 @@ This includes password cache, file cache, connection cache, buffers." (autoload 'reporter-submit-bug-report "reporter") +;;;###tramp-autoload (defun tramp-bug () "Submit a bug report to the Tramp developers." (interactive) @@ -147,65 +153,25 @@ This includes password cache, file cache, connection cache, buffers." (reporter-submit-bug-report tramp-bug-report-address ; to-address (format "tramp (%s)" tramp-version) ; package name and version - (delq nil - `(;; Current state - tramp-current-method - tramp-current-user - tramp-current-host - - ;; System defaults - tramp-auto-save-directory ; vars to dump - tramp-default-method - tramp-default-method-alist - tramp-default-host - tramp-default-proxies-alist - tramp-default-user - tramp-default-user-alist - tramp-rsh-end-of-line - tramp-default-password-end-of-line - tramp-login-prompt-regexp - ;; Mask non-7bit characters - (tramp-password-prompt-regexp . tramp-reporter-dump-variable) - tramp-wrong-passwd-regexp - tramp-yesno-prompt-regexp - tramp-yn-prompt-regexp - tramp-terminal-prompt-regexp - tramp-temp-name-prefix - tramp-file-name-structure - tramp-file-name-regexp - tramp-methods - tramp-end-of-output - tramp-local-coding-commands - tramp-remote-coding-commands - tramp-actions-before-shell - tramp-actions-copy-out-of-band - tramp-terminal-type - ;; Mask non-7bit characters - (tramp-shell-prompt-pattern . tramp-reporter-dump-variable) - ,(when (boundp 'tramp-backup-directory-alist) - 'tramp-backup-directory-alist) - ,(when (boundp 'tramp-bkup-backup-directory-info) - 'tramp-bkup-backup-directory-info) - ;; Dump cache. - (tramp-cache-data . tramp-reporter-dump-variable) - - ;; Non-tramp variables of interest - ;; Mask non-7bit characters - (shell-prompt-pattern . tramp-reporter-dump-variable) - backup-by-copying - backup-by-copying-when-linked - backup-by-copying-when-mismatch - ,(when (boundp 'backup-by-copying-when-privileged-mismatch) - 'backup-by-copying-when-privileged-mismatch) - ,(when (boundp 'password-cache) - 'password-cache) - ,(when (boundp 'password-cache-expiry) - 'password-cache-expiry) - ,(when (boundp 'backup-directory-alist) - 'backup-directory-alist) - ,(when (boundp 'bkup-backup-directory-info) - 'bkup-backup-directory-info) - file-name-handler-alist)) + (sort + (delq nil (mapcar + (lambda (x) + (and x (boundp x) (cons x 'tramp-reporter-dump-variable))) + (append + (mapcar 'intern (all-completions "tramp-" obarray 'boundp)) + ;; Non-tramp variables of interest. + '(shell-prompt-pattern + backup-by-copying + backup-by-copying-when-linked + backup-by-copying-when-mismatch + backup-by-copying-when-privileged-mismatch + backup-directory-alist + bkup-backup-directory-info + password-cache + password-cache-expiry + remote-file-name-inhibit-cache + file-name-handler-alist)))) + (lambda (x y) (string< (symbol-name (car x)) (symbol-name (car y))))) 'tramp-load-report-modules ; pre-hook 'tramp-append-tramp-buffers ; post-hook @@ -235,8 +201,7 @@ buffer in your bug report. ")))) (defun tramp-reporter-dump-variable (varsym mailbuf) - "Pretty-print the value of the variable in symbol VARSYM. -Used for non-7bit chars in strings." + "Pretty-print the value of the variable in symbol VARSYM." (let* ((reporter-eval-buffer (symbol-value 'reporter-eval-buffer)) (val (with-current-buffer reporter-eval-buffer (symbol-value varsym)))) @@ -244,12 +209,13 @@ Used for non-7bit chars in strings." (if (hash-table-p val) ;; Pretty print the cache. (set varsym (read (format "(%s)" (tramp-cache-print val)))) - ;; There are characters to be masked. + ;; There are non-7bit characters to be masked. (when (and (boundp 'mm-7bit-chars) + (stringp val) (string-match (concat "[^" (symbol-value 'mm-7bit-chars) "]") val)) (with-current-buffer reporter-eval-buffer - (set varsym (format "(base64-decode-string \"%s\"" + (set varsym (format "(base64-decode-string \"%s\")" (base64-encode-string val)))))) ;; Dump variable. @@ -265,7 +231,7 @@ Used for non-7bit chars in strings." "\\(\")\\)" "\"$")) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) - (insert " ;; variable encoded due to non-printable characters\n")) + (insert " ;; Variable encoded due to non-printable characters.\n")) (forward-line 1)) ;; Reset VARSYM to old value. @@ -274,7 +240,6 @@ Used for non-7bit chars in strings." (defun tramp-load-report-modules () "Load needed modules for reporting." - ;; We load message.el and mml.el from Gnus. (if (featurep 'xemacs) (progn @@ -287,7 +252,6 @@ Used for non-7bit chars in strings." (defun tramp-append-tramp-buffers () "Append Tramp buffers and buffer local variables into the bug report." - (goto-char (point-max)) ;; Dump buffer local variables. @@ -334,8 +298,7 @@ Used for non-7bit chars in strings." (setq buffer-read-only nil) (goto-char (point-min)) (while (not (eobp)) - (if (re-search-forward - tramp-buf-regexp (tramp-compat-line-end-position) t) + (if (re-search-forward tramp-buf-regexp (point-at-eol) t) (forward-line 1) (forward-line 0) (let ((start (point))) @@ -386,6 +349,9 @@ please ensure that the buffers are attached to your email.\n\n") (defalias 'tramp-submit-bug 'tramp-bug) +(add-hook 'tramp-unload-hook + (lambda () (unload-feature 'tramp-cmds 'force))) + (provide 'tramp-cmds) ;;; TODO: @@ -394,16 +360,8 @@ please ensure that the buffers are attached to your email.\n\n") ;; * WIBNI there was an interactive command prompting for Tramp ;; method, hostname, username and filename and translates the user ;; input into the correct filename syntax (depending on the Emacs -;; flavor) (Reiner Steib) +;; flavor) (Reiner Steib) ;; * Let the user edit the connection properties interactively. ;; Something like `gnus-server-edit-server' in Gnus' *Server* buffer. -;; * It's just that when I come to Customize `tramp-default-user-alist' -;; I'm presented with a mismatch and raw lisp for a value. It is my -;; understanding that a variable declared with defcustom is a User -;; Option and should not be modified by the code. add-to-list is -;; called in several places. One way to handle that is to have a new -;; ordinary variable that gets its initial value from -;; tramp-default-user-alist and then is added to. (Pete Forman) - -;; arch-tag: 190d4c33-76bb-4e99-8b6f-71741f23d98c + ;;; tramp-cmds.el ends here diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 3170e5aba06..65c705a9f40 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -4,6 +4,7 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -28,6 +29,8 @@ ;;; Code: +(require 'tramp-loaddefs) + (eval-when-compile ;; Pacify byte-compiler. @@ -35,40 +38,41 @@ (eval-and-compile + (require 'advice) (require 'custom) + (require 'format-spec) + + ;; As long as password.el is not part of (X)Emacs, it shouldn't be + ;; mandatory. + (if (featurep 'xemacs) + (load "password" 'noerror) + (or (require 'password-cache nil 'noerror) + (require 'password nil 'noerror))) ; Part of contrib. + + ;; auth-source is relatively new. + (if (featurep 'xemacs) + (load "auth-source" 'noerror) + (require 'auth-source nil 'noerror)) ;; Load the appropriate timer package. (if (featurep 'xemacs) (require 'timer-funcs) (require 'timer)) - (autoload 'tramp-tramp-file-p "tramp") - (autoload 'tramp-file-name-handler "tramp") - ;; We check whether `start-file-process' is bound. (unless (fboundp 'start-file-process) ;; tramp-util offers integration into other (X)Emacs packages like ;; compile.el, gud.el etc. Not necessary in Emacs 23. (eval-after-load "tramp" - '(progn - (require 'tramp-util) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-util) - (unload-feature 'tramp-util 'force)))))) + '(require 'tramp-util)) ;; Make sure that we get integration with the VC package. When it ;; is loaded, we need to pull in the integration module. Not ;; necessary in Emacs 23. (eval-after-load "vc" (eval-after-load "tramp" - '(progn - (require 'tramp-vc) - (add-hook 'tramp-unload-hook - '(lambda () - (when (featurep 'tramp-vc) - (unload-feature 'tramp-vc 'force)))))))) + '(require 'tramp-vc)))) ;; Avoid byte-compiler warnings if the byte-compiler supports this. ;; Currently, XEmacs supports this. @@ -84,18 +88,18 @@ ;; `directory-sep-char' is an obsolete variable in Emacs. But it is ;; used in XEmacs, so we set it here and there. The following is ;; needed to pacify Emacs byte-compiler. - (unless (boundp 'byte-compile-not-obsolete-var) - (defvar byte-compile-not-obsolete-var nil)) - (setq byte-compile-not-obsolete-var 'directory-sep-char) - ;; Emacs 23.2. - (unless (boundp 'byte-compile-not-obsolete-vars) - (defvar byte-compile-not-obsolete-vars nil)) - (setq byte-compile-not-obsolete-vars '(directory-sep-char)) - - ;; `with-temp-message' does not exists in XEmacs. - (condition-case nil - (with-temp-message (current-message) nil) - (error (defmacro with-temp-message (message &rest body) `(progn ,@body)))) + ;; Note that it was removed altogether in Emacs 24.1. + (when (boundp 'directory-sep-char) + (defvar byte-compile-not-obsolete-var nil) + (setq byte-compile-not-obsolete-var 'directory-sep-char) + ;; Emacs 23.2. + (defvar byte-compile-not-obsolete-vars nil) + (setq byte-compile-not-obsolete-vars '(directory-sep-char))) + + ;; `remote-file-name-inhibit-cache' has been introduced with Emacs 24.1. + ;; Besides `t', `nil', and integer, we use also timestamps (as + ;; returned by `current-time') internally. + (defvar remote-file-name-inhibit-cache nil) ;; For not existing functions, or functions with a changed argument ;; list, there are compiler warnings. We want to avoid them in @@ -110,10 +114,6 @@ (unless (fboundp 'set-buffer-multibyte) (defalias 'set-buffer-multibyte 'ignore)) - ;; `font-lock-add-keywords' does not exist in XEmacs. - (unless (fboundp 'font-lock-add-keywords) - (defalias 'font-lock-add-keywords 'ignore)) - ;; The following functions cannot be aliases of the corresponding ;; `tramp-handle-*' functions, because this would bypass the locking ;; mechanism. @@ -186,24 +186,18 @@ 'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards) (ad-activate 'file-expand-wildcards))))) -(defsubst tramp-compat-line-beginning-position () - "Return point at beginning of line (compat function). -Calls `line-beginning-position' or `point-at-bol' if defined, else -own implementation." - (cond - ((fboundp 'line-beginning-position) - (tramp-compat-funcall 'line-beginning-position)) - ((fboundp 'point-at-bol) (tramp-compat-funcall 'point-at-bol)) - (t (save-excursion (beginning-of-line) (point))))) - -(defsubst tramp-compat-line-end-position () - "Return point at end of line (compat function). -Calls `line-end-position' or `point-at-eol' if defined, else -own implementation." - (cond - ((fboundp 'line-end-position) (tramp-compat-funcall 'line-end-position)) - ((fboundp 'point-at-eol) (tramp-compat-funcall 'point-at-eol)) - (t (save-excursion (end-of-line) (point))))) +;; `with-temp-message' does not exists in XEmacs. +(if (fboundp 'with-temp-message) + (defalias 'tramp-compat-with-temp-message 'with-temp-message) + (defmacro tramp-compat-with-temp-message (message &rest body) + "Display MESSAGE temporarily if non-nil while BODY is evaluated." + `(progn ,@body))) + +;; `font-lock-add-keywords' does not exist in XEmacs. +(defun tramp-compat-font-lock-add-keywords (mode keywords &optional how) + "Add highlighting KEYWORDS for MODE." + (ignore-errors + (tramp-compat-funcall 'font-lock-add-keywords mode keywords how))) (defsubst tramp-compat-temporary-file-directory () "Return name of directory for temporary files (compat function). @@ -262,6 +256,24 @@ Add the extension of FILENAME, if existing." ;; Default value in XEmacs. (t 134217727))) +(defun tramp-compat-decimal-to-octal (i) + "Return a string consisting of the octal digits of I. +Not actually used. Use `(format \"%o\" i)' instead?" + (cond ((< i 0) (error "Cannot convert negative number to octal")) + ((not (integerp i)) (error "Cannot convert non-integer to octal")) + ((zerop i) "0") + (t (concat (tramp-compat-decimal-to-octal (/ i 8)) + (number-to-string (% i 8)))))) + +;; Kudos to Gerd Moellmann for this suggestion. +(defun tramp-compat-octal-to-decimal (ostr) + "Given a string of octal digits, return a decimal number." + (let ((x (or ostr ""))) + ;; `save-match' is in `tramp-mode-string-to-int' which calls this. + (unless (string-match "\\`[0-7]*\\'" x) + (error "Non-octal junk in string `%s'" x)) + (string-to-number ostr 8))) + ;; ID-FORMAT does not exists in XEmacs. (defun tramp-compat-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files (compat function)." @@ -396,6 +408,20 @@ This is, the first, empty, element is omitted. In XEmacs, the first element is not omitted." (delete "" (split-string string pattern))) +(defun tramp-compat-call-process + (program &optional infile destination display &rest args) + "Calls `call-process' on the local host. +This is needed because for some Emacs flavors Tramp has +defadviced `call-process' to behave like `process-file'. The +Lisp error raised when PROGRAM is nil is trapped also, returning 1." + (let ((default-directory + (if (file-remote-p default-directory) + (tramp-compat-temporary-file-directory) + default-directory))) + (if (executable-find program) + (apply 'call-process program infile destination display args) + 1))) + (defun tramp-compat-process-running-p (process-name) "Returns `t' if system process PROCESS-NAME is running for `user-login-name'." (when (stringp process-name) @@ -438,9 +464,50 @@ element is not omitted." (setenv "UNIX95" unix95) result))))) +;; The following functions do not exist in XEmacs. We ignore this; +;; they are used for checking a remote tty. +(defun tramp-compat-process-get (process propname) + "Return the value of PROCESS' PROPNAME property. +This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'." + (ignore-errors (tramp-compat-funcall 'process-get process propname))) + +(defun tramp-compat-process-put (process propname value) + "Change PROCESS' PROPNAME property to VALUE. +It can be retrieved with `(process-get PROCESS PROPNAME)'." + (ignore-errors (tramp-compat-funcall 'process-put process propname value))) + +(defun tramp-compat-set-process-query-on-exit-flag (process flag) + "Specify if query is needed for process when Emacs is exited. +If the second argument flag is non-nil, Emacs will query the user before +exiting if process is running." + (if (fboundp 'set-process-query-on-exit-flag) + (tramp-compat-funcall 'set-process-query-on-exit-flag process flag) + (tramp-compat-funcall 'process-kill-without-query process flag))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-compat 'force))) + +(defun tramp-compat-coding-system-change-eol-conversion (coding-system eol-type) + "Return a coding system like CODING-SYSTEM but with given EOL-TYPE. +EOL-TYPE can be one of `dos', `unix', or `mac'." + (cond ((fboundp 'coding-system-change-eol-conversion) + (tramp-compat-funcall + 'coding-system-change-eol-conversion coding-system eol-type)) + ((fboundp 'subsidiary-coding-system) + (tramp-compat-funcall + 'subsidiary-coding-system coding-system + (cond ((eq eol-type 'dos) 'crlf) + ((eq eol-type 'unix) 'lf) + ((eq eol-type 'mac) 'cr) + (t + (error "Unknown EOL-TYPE `%s', must be %s" + eol-type + "`dos', `unix', or `mac'"))))) + (t (error "Can't change EOL conversion -- is MULE missing?")))) + (provide 'tramp-compat) ;;; TODO: -;; arch-tag: 0e724b18-6699-4f87-ad96-640b272e5c85 ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-fish.el b/lisp/net/tramp-fish.el deleted file mode 100644 index ea0548a8174..00000000000 --- a/lisp/net/tramp-fish.el +++ /dev/null @@ -1,1180 +0,0 @@ -;;; tramp-fish.el --- Tramp access functions for FISH protocol - -;; Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 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. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Access functions for FIles transferred over SHell protocol from Tramp. - -;; FISH is a protocol developped for the GNU Midnight Commander -;; <https://savannah.gnu.org/projects/mc>. A client connects to a -;; remote host via ssh (or rsh, shall be configurable), and starts -;; there a fish server via the command "start_fish_server". All -;; commands from the client have the form "#FISH_COMMAND\n" (always -;; one line), followed by equivalent shell commands in case there is -;; no fish server running. - -;; The fish server (or the equivalent shell commands) must return the -;; response, which is finished by a line "### xxx <optional text>\n". -;; "xxx" stands for 3 digits, representing a return code. Return -;; codes "# 000" and "# 001" are reserved for fallback implementation -;; with native shell commands; they are not used inside the server. See -;; <http://cvs.savannah.gnu.org/viewvc/mc/vfs/README.fish?root=mc&view=markup> -;; for details of original specification. - -;; The GNU Midnight Commander implements the original fish protocol -;; version 0.0.2. The KDE Konqueror has its own implementation, which -;; can be found at -;; <http://websvn.kde.org/branches/KDE/3.5/kdebase/kioslave/fish>. It -;; implements an extended protocol version 0.0.3. Additionally, it -;; provides a fish server implementation in Perl (which is the only -;; implementation I've heard of). The following command reference is -;; based on that implementation. - -;; All commands return either "### 2xx\n" (OK) or "### 5xx <optional text>\n" -;; (NOK). Return codes are mentioned only if they are different from this. -;; Spaces in any parameter must be escaped by "\ ". - -;; Command/Return Code Comment -;; -;; #FISH initial connection, not used -;; in .fishsrv.pl -;; ### 100 transfer fish server missing server, or wrong checksum -;; version 0.0.3 only - -;; #VER a.b.c <commands requested> -;; VER x.y.z <commands offered> .fishsrv.pl response is not uptodate - -;; #PWD -;; /path/to/file - -;; #CWD /some/path - -;; #COPY /path/a /path/b version 0.0.3 only - -;; #RENAME /path/a /path/b - -;; #SYMLINK /path/a /path/b - -;; #LINK /path/a /path/b - -;; #DELE /some/path - -;; #MKD /some/path - -;; #RMD /some/path - -;; #CHOWN user /file/name - -;; #CHGRP group /file/name - -;; #CHMOD 1234 file - -;; #READ <offset> <size> /path/and/filename -;; ### 291 successful exit when reading -;; ended at eof -;; ### 292 successful exit when reading -;; did not end at eof - -;; #WRITE <offset> <size> /path/and/filename - -;; #APPEND <size> /path/and/filename version 0.0.3 only - -;; #LIST /directory -;; <number of entries> version 0.0.3 only -;; ### 100 version 0.0.3 only -;; P<unix permissions> <owner>.<group> -;; S<size> -;; d<3-letters month name> <day> <year or HH:MM> -;; D<year> <month> <day> <hour> <minute> <second>[.1234] -;; E<major-of-device>,<minor> -;; :<filename> -;; L<filename symlink points to> -;; M<mimetype> version 0.0.3 only -;; <blank line to separate items> - -;; #STAT /file version 0.0.3 only -;; like #LIST except for directories -;; <number of entries> -;; ### 100 -;; P<unix permissions> <owner>.<group> -;; S<size> -;; d<3-letters month name> <day> <year or HH:MM> -;; D<year> <month> <day> <hour> <minute> <second>[.1234] -;; E<major-of-device>,<minor> -;; :<filename> -;; L<filename symlink points to> -;; <blank line to separate items> - -;; #RETR /some/name -;; <filesize> -;; ### 100 -;; <binary data> exactly filesize bytes -;; ### 200 with no preceding newline - -;; #STOR <size> /file/name -;; ### 100 -;; <data> exactly size bytes -;; ### 001 partial success - -;; #EXEC <command> <tmpfile> version 0.0.3 only -;; <tmpfile> must not exists. It contains the output of <command>. -;; It can be retrieved afterwards. Last line is -;; ###RESULT: <returncode> - -;; This implementation is meant as proof of the concept, whether there -;; is a better performance compared with the native ssh method. It -;; looks like the file information retrieval is slower, especially the -;; #LIST command. On the other hand, the file contents transmission -;; seems to perform better than other inline methods, because there is -;; no need for data encoding/decoding, and it supports the APPEND -;; parameter of `write-region'. Transfer of binary data fails due to -;; Emacs' process input/output handling. - -;;; Code: - -(eval-when-compile - ;; Pacify byte-compiler. - (require 'cl)) - -(require 'tramp) -(require 'tramp-cache) -(require 'tramp-compat) - -;; Define FISH method ... -(defcustom tramp-fish-method "fish" - "*Method to connect via FISH protocol." - :group 'tramp - :type 'string) - -;; ... and add it to the method list. -(add-to-list 'tramp-methods (cons tramp-fish-method nil)) - -;; Add a default for `tramp-default-user-alist'. Default is the local user. -(add-to-list 'tramp-default-user-alist - `(,tramp-fish-method nil ,(user-login-name))) - -;; Add completion function for FISH method. -(tramp-set-completion-function - tramp-fish-method tramp-completion-function-alist-ssh) - -(defconst tramp-fish-continue-prompt-regexp "^### 100.*\n" - "FISH return code OK.") - -;; It cannot be a defconst, occasionally we bind it locally. -(defvar tramp-fish-ok-prompt-regexp "^### 200\n" - "FISH return code OK.") - -(defconst tramp-fish-error-prompt-regexp "^### \\(4\\|5\\)[0-9]+.*\n" - "Regexp for possible error strings of FISH servers. -Used instead of analyzing error codes of commands.") - -(defcustom tramp-fish-start-fish-server-command - (concat "stty intr \"\" quit \"\" erase \"\" kill \"\" eof \"\" eol \"\" eol2 \"\" swtch \"\" start \"\" stop \"\" susp \"\" rprnt \"\" werase \"\" lnext \"\" flush \"\"; " - "perl .fishsrv.pl " - "`grep 'ARGV\\[0\\]' .fishsrv.pl | " - "sed -e 's/^[^\"]*\"//' -e 's/\"[^\"]*$//'`; " - "exit") - "*Command to connect via FISH protocol." - :group 'tramp - :type 'string) - -;; New handlers should be added here. -(defconst tramp-fish-file-name-handler-alist - '( - ;; `access-file' performed by default handler - (add-name-to-file . tramp-fish-handle-add-name-to-file) - ;; `byte-compiler-base-file-name' performed by default handler - (copy-file . tramp-fish-handle-copy-file) - (delete-directory . tramp-fish-handle-delete-directory) - (delete-file . tramp-fish-handle-delete-file) - ;; `diff-latest-backup-file' performed by default handler - (directory-file-name . tramp-handle-directory-file-name) - (directory-files . tramp-handle-directory-files) - (directory-files-and-attributes . tramp-fish-handle-directory-files-and-attributes) - ;; `dired-call-process' performed by default handler - ;; `dired-compress-file' performed by default handler - (dired-uncache . tramp-handle-dired-uncache) - (expand-file-name . tramp-fish-handle-expand-file-name) - ;; `file-accessible-directory-p' performed by default handler - (file-attributes . tramp-fish-handle-file-attributes) - (file-directory-p . tramp-fish-handle-file-directory-p) - (file-executable-p . tramp-fish-handle-file-executable-p) - (file-exists-p . tramp-fish-handle-file-exists-p) - (file-local-copy . tramp-fish-handle-file-local-copy) - (file-modes . tramp-handle-file-modes) - (file-name-all-completions . tramp-fish-handle-file-name-all-completions) - (file-name-as-directory . tramp-handle-file-name-as-directory) - (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-newer-than-file-p . tramp-fish-handle-file-newer-than-file-p) - (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-fish-handle-file-readable-p) - (file-regular-p . tramp-handle-file-regular-p) - (file-remote-p . tramp-handle-file-remote-p) - ;; `file-selinux-context' performed by default handler. - (file-symlink-p . tramp-handle-file-symlink-p) - ;; `file-truename' performed by default handler - (file-writable-p . tramp-fish-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 - (insert-directory . tramp-fish-handle-insert-directory) - (insert-file-contents . tramp-fish-handle-insert-file-contents) - (load . tramp-handle-load) - (make-directory . tramp-fish-handle-make-directory) - (make-directory-internal . tramp-fish-handle-make-directory-internal) - (make-symbolic-link . tramp-fish-handle-make-symbolic-link) - (rename-file . tramp-fish-handle-rename-file) - (set-file-modes . tramp-fish-handle-set-file-modes) - ;; `set-file-selinux-context' performed by default handler. - (set-file-times . tramp-fish-handle-set-file-times) - (set-visited-file-modtime . ignore) - (shell-command . tramp-handle-shell-command) - (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) - (vc-registered . ignore) - (verify-visited-file-modtime . ignore) - (write-region . tramp-fish-handle-write-region) - (executable-find . tramp-fish-handle-executable-find) - (start-file-process . ignore) - (process-file . tramp-fish-handle-process-file) -) - "Alist of handler functions for Tramp FISH method. -Operations not mentioned here will be handled by the default Emacs primitives.") - -(defun tramp-fish-file-name-p (filename) - "Check if it's a filename for FISH protocol." - (let ((v (tramp-dissect-file-name filename))) - (string= (tramp-file-name-method v) tramp-fish-method))) - -(defun tramp-fish-file-name-handler (operation &rest args) - "Invoke the FISH related OPERATION. -First arg specifies the OPERATION, second arg is a list of arguments to -pass to the OPERATION." - (let ((fn (assoc operation tramp-fish-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) - -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-fish-file-name-p 'tramp-fish-file-name-handler)) - - -;; File name primitives - -(defun tramp-fish-handle-add-name-to-file - (filename newname &optional ok-if-already-exists) - "Like `add-name-to-file' for Tramp files." - (unless (tramp-equal-remote filename newname) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p filename) filename newname) nil - (tramp-error - v 'file-error - "add-name-to-file: %s" - "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (when (and (not ok-if-already-exists) - (file-exists-p newname) - (not (numberp ok-if-already-exists)) - (y-or-n-p - (format - "File %s already exists; make it a new name anyway? " - newname))) - (tramp-error - v2 'file-error - "add-name-to-file: file %s already exists" newname)) - (tramp-flush-file-property v2 v2-localname) - (unless (tramp-fish-send-command-and-check - v1 (format "#LINK %s %s" v1-localname v2-localname)) - (tramp-error - v1 'file-error "Error with add-name-to-file %s" newname))))) - -(defun tramp-fish-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Like `copy-file' for Tramp files." - (tramp-fish-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date preserve-uid-gid)) - -(defun tramp-fish-handle-delete-directory (directory &optional recursive) - "Like `delete-directory' for Tramp files." - (when (file-exists-p directory) - (if recursive - (mapc - (lambda (file) - (if (file-directory-p file) - (tramp-compat-delete-directory file recursive) - (delete-file file))) - ;; We do not want to delete "." and "..". - (directory-files - directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))) - (with-parsed-tramp-file-name - (directory-file-name (expand-file-name directory)) nil - (tramp-flush-directory-property v localname) - (tramp-fish-send-command-and-check v (format "#RMD %s" localname))))) - -(defun tramp-fish-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (when (file-exists-p filename) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (tramp-flush-file-property v localname) - (tramp-fish-send-command-and-check v (format "#DELE %s" localname))))) - -(defun tramp-fish-handle-directory-files-and-attributes - (directory &optional full match nosort id-format) - "Like `directory-files-and-attributes' for Tramp files." - (mapcar - (lambda (x) - (cons x - (tramp-compat-file-attributes - (if full x (expand-file-name x directory)) - id-format))) - (directory-files directory full match nosort))) - -(defun tramp-fish-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 (or (tramp-completion-mode-p) (not (tramp-tramp-file-p name))) - (tramp-drop-volume-letter - (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. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - ;; We cannot apply "~user/", because this is not supported - ;; by the FISH protocol. - (unless (string-equal uname "~") - (tramp-error - v 'file-error "Tilde expansion not supported for %s" name)) - (setq uname - (with-connection-property v uname - (tramp-fish-send-command-and-check v "#PWD") - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring (point) (tramp-compat-line-end-position))))) - (setq localname (concat uname fname)))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; No tilde characters in file name, do normal - ;; expand-file-name (this does "/./" and "/../"). We bind - ;; `directory-sep-char' here for XEmacs on Windows, which - ;; would otherwise use backslash. `default-directory' is - ;; bound, because on Windows there would be problems with UNC - ;; shares or Cygwin mounts. - (let ((directory-sep-char ?/) - (default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user host - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) - -(defun tramp-fish-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname (format "file-attributes-%s" id-format) - (cdr (car (tramp-fish-get-file-entries v localname nil)))))) - -(defun tramp-fish-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - (let ((attributes (file-attributes filename))) - (and attributes - (or (string-match "d" (nth 8 attributes)) - (and (file-symlink-p filename) - (with-parsed-tramp-file-name filename nil - (file-directory-p - (tramp-make-tramp-file-name - method user host (nth 0 attributes)))))) - t))) - -(defun tramp-fish-handle-file-exists-p (filename) - "Like `file-exists-p' for Tramp files." - (and (file-attributes filename) t)) - -(defun tramp-fish-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-executable-p" - (when (file-exists-p filename) - (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename)))) - (home-directory - (tramp-make-tramp-file-name - method user host - (tramp-get-connection-property v "home-directory" nil)))) - (or (and (char-equal (aref mode-chars 3) ?x) - (equal (nth 2 (file-attributes filename)) - (nth 2 (file-attributes home-directory)))) - (and (char-equal (aref mode-chars 6) ?x) - (equal (nth 3 (file-attributes filename)) - (nth 3 (file-attributes home-directory)))) - (char-equal (aref mode-chars 9) ?x))))))) - -(defun tramp-fish-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-readable-p" - (when (file-exists-p filename) - (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename)))) - (home-directory - (tramp-make-tramp-file-name - method user host - (tramp-get-connection-property v "home-directory" nil)))) - (or (and (char-equal (aref mode-chars 1) ?r) - (equal (nth 2 (file-attributes filename)) - (nth 2 (file-attributes home-directory)))) - (and (char-equal (aref mode-chars 4) ?r) - (equal (nth 3 (file-attributes filename)) - (nth 3 (file-attributes home-directory)))) - (char-equal (aref mode-chars 7) ?r))))))) - -(defun tramp-fish-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-writable-p" - (if (not (file-exists-p filename)) - ;; If file doesn't exist, check if directory is writable. - (and (file-directory-p (file-name-directory filename)) - (file-writable-p (file-name-directory filename))) - ;; Existing files must be writable. - (let ((mode-chars (string-to-vector (nth 8 (file-attributes filename)))) - (home-directory - (tramp-make-tramp-file-name - method user host - (tramp-get-connection-property v "home-directory" nil)))) - (or (and (char-equal (aref mode-chars 2) ?w) - (equal (nth 2 (file-attributes filename)) - (nth 2 (file-attributes home-directory)))) - (and (char-equal (aref mode-chars 5) ?w) - (equal (nth 3 (file-attributes filename)) - (nth 3 (file-attributes home-directory)))) - (char-equal (aref mode-chars 8) ?w))))))) - -(defun tramp-fish-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (unless (file-exists-p filename) - (tramp-error - v 'file-error - "Cannot make local copy of non-existing file `%s'" filename)) - (let ((tmpfile (tramp-compat-make-temp-file filename))) - (with-progress-reporter - v 3 (format "Fetching %s to tmp file %s" filename tmpfile) - (when (tramp-fish-retrieve-data v) - ;; Save file - (with-current-buffer (tramp-get-buffer v) - (write-region (point-min) (point-max) tmpfile)) - tmpfile))))) - -;; This function should return "foo/" for directories and "bar" for -;; files. -(defun tramp-fish-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (all-completions - filename - (with-parsed-tramp-file-name (expand-file-name directory) nil - (with-file-property v localname "file-name-all-completions" - (save-match-data - (let ((entries - (with-file-property v localname "file-entries" - (tramp-fish-get-file-entries v localname t)))) - (mapcar - (lambda (x) - (list - (if (string-match "d" (nth 9 x)) - (file-name-as-directory (nth 0 x)) - (nth 0 x)))) - entries))))))) - -(defun tramp-fish-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond - ((not (file-exists-p file1)) nil) - ((not (file-exists-p file2)) t) - (t (tramp-time-less-p (nth 5 (file-attributes file2)) - (nth 5 (file-attributes file1)))))) - -(defun tramp-fish-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files. -WILDCARD and FULL-DIRECTORY-P are not handled." - (setq filename (expand-file-name filename)) - (when (file-directory-p filename) - ;; This check is a little bit strange, but in `dired-add-entry' - ;; this function is called with a non-directory ... - (setq filename (file-name-as-directory filename))) - - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (save-match-data - (let ((entries - (with-file-property v localname "file-entries" - (tramp-fish-get-file-entries v localname t)))) - - ;; Sort entries - (setq entries - (sort - entries - (lambda (x y) - (if (string-match "t" switches) - ;; Sort by date. - (tramp-time-less-p (nth 6 y) (nth 6 x)) - ;; Sort by name. - (string-lessp (nth 0 x) (nth 0 y)))))) - - ;; Print entries. - (mapcar - (lambda (x) - (insert - (format - "%10s %3d %-8s %-8s %8s %s %s%s\n" - (nth 9 x) ; mode - 1 ; hardlinks - (nth 3 x) ; uid - (nth 4 x) ; gid - (nth 8 x) ; size - (format-time-string - (if (tramp-time-less-p - (tramp-time-subtract (current-time) (nth 6 x)) - tramp-half-a-year) - "%b %e %R" - "%b %e %Y") - (nth 6 x)) ; date - (nth 0 x) ; file name - (if (stringp (nth 1 x)) (format " -> %s" (nth 1 x)) ""))) - (forward-line) - (beginning-of-line)) - entries))))) - -(defun tramp-fish-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (when visit - (setq buffer-file-name (expand-file-name filename)) - (set-visited-file-modtime) - (set-buffer-modified-p nil)) - - (with-parsed-tramp-file-name filename nil - (if (not (file-exists-p filename)) - (tramp-error - v 'file-error "File %s not found on remote host" filename) - - (let ((point (point)) - size) - (with-progress-reporter v 3 (format "Fetching file %s" filename) - (when (tramp-fish-retrieve-data v) - ;; Insert file - (insert - (with-current-buffer (tramp-get-buffer v) - (let ((beg (or beg (point-min))) - (end (min (or end (point-max)) (point-max)))) - (setq size (- end beg)) - (buffer-substring beg end)))) - (goto-char point))) - - (list (expand-file-name filename) size))))) - -(defun tramp-fish-handle-make-directory (dir &optional parents) - "Like `make-directory' for Tramp files." - (setq dir (directory-file-name (expand-file-name dir))) - (unless (file-name-absolute-p dir) - (setq dir (expand-file-name dir default-directory))) - (with-parsed-tramp-file-name dir nil - (save-match-data - (let ((ldir (file-name-directory dir))) - ;; Make missing directory parts - (when (and parents (not (file-directory-p ldir))) - (make-directory ldir parents)) - ;; Just do it - (when (file-directory-p ldir) - (make-directory-internal dir)) - (unless (file-directory-p dir) - (tramp-error v 'file-error "Couldn't make directory %s" dir)))))) - -(defun tramp-fish-handle-make-directory-internal (directory) - "Like `make-directory-internal' for Tramp files." - (setq directory (directory-file-name (expand-file-name directory))) - (unless (file-name-absolute-p directory) - (setq directory (expand-file-name directory default-directory))) - (when (file-directory-p (file-name-directory directory)) - (with-parsed-tramp-file-name directory nil - (save-match-data - (unless - (tramp-fish-send-command-and-check v (format "#MKD %s" localname)) - (tramp-error - v 'file-error "Couldn't make directory %s" directory)))))) - -(defun tramp-fish-handle-make-symbolic-link - (filename linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If LINKNAME is a non-Tramp file, it is used verbatim as the target of -the symlink. If LINKNAME is a Tramp file, only the localname component is -used as the target of the symlink. - -If LINKNAME is a Tramp file and the localname component is relative, then -it is expanded first, before the localname component is taken. Note that -this can give surprising results if the user/host for the source and -target of the symlink differ." - (with-parsed-tramp-file-name linkname nil - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - localname))))) - (tramp-error - v 'file-already-exists "File %s already exists" localname) - (delete-file linkname))) - - ;; If FILENAME is a Tramp name, use just the localname component. - (when (tramp-tramp-file-p filename) - (setq filename (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name filename))))) - - ;; Right, they are on the same host, regardless of user, method, etc. - ;; We now make the link on the remote machine. This will occur as the user - ;; that FILENAME belongs to. - (unless - (tramp-fish-send-command-and-check - v (format "#SYMLINK %s %s" filename localname)) - (tramp-error v 'file-error "Error creating symbolic link %s" linkname)))) - -(defun tramp-fish-handle-rename-file - (filename newname &optional ok-if-already-exists) - "Like `rename-file' for Tramp files." - (tramp-fish-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t)) - -(defun tramp-fish-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-fish-send-command-and-check - v (format "#CHMOD %s %s" - (tramp-decimal-to-octal mode) - (tramp-shell-quote-argument localname))) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) - -(defun tramp-fish-handle-set-file-times (filename &optional time) - "Like `set-file-times' for Tramp files." - (with-parsed-tramp-file-name filename nil - (let ((time (if (or (null time) (equal time '(0 0))) (current-time) time))) - (zerop (process-file - "touch" nil nil nil "-t" - (format-time-string "%Y%m%d%H%M.%S" time) - (tramp-shell-quote-argument localname)))))) - -(defun tramp-fish-handle-write-region - (start end filename &optional append visit lockname confirm) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - ;; XEmacs takes a coding system as the seventh argument, not `confirm' - (when (and (not (featurep 'xemacs)) - confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " - filename)) - (tramp-error v 'file-error "File not overwritten"))) - - (tramp-flush-file-property v localname) - - ;; Send command - (let ((tramp-fish-ok-prompt-regexp - (concat - tramp-fish-ok-prompt-regexp "\\|" - tramp-fish-continue-prompt-regexp))) - (tramp-fish-send-command - v (format "%s %d %s\n### 100" - (if append "#APPEND" "#STOR") (- end start) localname))) - - ;; Send data, if there are any. - (when (> end start) - (tramp-fish-send-command v (buffer-substring-no-properties start end))) - - (when (eq visit t) - (set-visited-file-modtime)))) - -(defun tramp-fish-handle-executable-find (command) - "Like `executable-find' for Tramp files." - (with-temp-buffer - (if (zerop (process-file "which" nil t nil command)) - (progn - (goto-char (point-min)) - (buffer-substring (point-min) (tramp-compat-line-end-position)))))) - -(defun tramp-fish-handle-process-file - (program &optional infile destination display &rest args) - "Like `process-file' for Tramp files." - ;; The implementation is not complete yet. - (when (and (numberp destination) (zerop destination)) - (error "Implementation does not handle immediate return")) - - (with-parsed-tramp-file-name default-directory nil - (let (command input tmpinput output tmpoutput stderr tmpstderr - outbuf tmpfile ret) - ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument - (cons program args) " ")) - ;; Determine input. - (if (null infile) - (setq input "/dev/null") - (setq infile (expand-file-name infile)) - (if (tramp-equal-remote default-directory infile) - ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) - ;; INFILE must be copied to remote host. - (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name method user host input)) - (copy-file infile tmpinput t))) - (when input (setq command (format "%s <%s" command input))) - - ;; Determine output. - (setq output (tramp-make-tramp-temp-file v) - tmpoutput (tramp-make-tramp-file-name method user host output)) - (cond - ;; Just a buffer - ((bufferp destination) - (setq outbuf destination)) - ;; A buffer name - ((stringp destination) - (setq outbuf (get-buffer-create destination))) - ;; (REAL-DESTINATION ERROR-DESTINATION) - ((consp destination) - ;; output - (cond - ((bufferp (car destination)) - (setq outbuf (car destination))) - ((stringp (car destination)) - (setq outbuf (get-buffer-create (car destination))))) - ;; stderr - (cond - ((stringp (cadr destination)) - (setcar (cdr destination) (expand-file-name (cadr destination))) - (if (tramp-equal-remote default-directory (cadr destination)) - ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) - ;; stderr must be copied to remote host. The temporary - ;; file must be deleted after execution. - (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user host stderr)))) - ;; stderr to be discarded - ((null (cadr destination)) - (setq stderr "/dev/null")))) - ;; 't - (destination - (setq outbuf (current-buffer)))) - (when stderr (setq command (format "%s 2>%s" command stderr))) - - ;; Goto working directory. - (unless - (tramp-fish-send-command-and-check - v (format "#CWD %s" (tramp-shell-quote-argument localname))) - (tramp-error v 'file-error "No such directory: %s" default-directory)) - ;; Send the command. It might not return in time, so we protect it. - (condition-case nil - (unwind-protect - (unless (tramp-fish-send-command-and-check - v (format - "#EXEC %s %s" - (tramp-shell-quote-argument command) output)) - (error nil)) - ;; Check return code. - (setq tmpfile - (file-local-copy - (tramp-make-tramp-file-name method user host output))) - (with-temp-buffer - (insert-file-contents tmpfile) - (goto-char (point-max)) - (forward-line -1) - (looking-at "^###RESULT: \\([0-9]+\\)") - (setq ret (string-to-number (match-string 1))) - (delete-region (point) (point-max)) - (write-region (point-min) (point-max) tmpfile)) - ;; We should show the output anyway. - (when outbuf - (with-current-buffer outbuf (insert-file-contents tmpfile)) - (when display (display-buffer outbuf)))) - ;; When the user did interrupt, we should do it also. - (error (setq ret 1))) - - ;; Provide error file. - (when tmpstderr (rename-file tmpstderr (cadr destination) t)) - ;; Cleanup. - (when tmpinput (delete-file tmpinput)) - (when tmpoutput (delete-file tmpoutput)) - ;; Return exit status. - ret))) - - -;; Internal file name functions - -(defun tramp-fish-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date preserve-uid-gid) - "Copy or rename a remote file. -OP must be `copy' or `rename' and indicates the operation to -perform. FILENAME specifies the file to copy or rename, NEWNAME -is the name of the new file (for copy) or the new name of the -file (for rename). OK-IF-ALREADY-EXISTS means don't barf if -NEWNAME exists already. KEEP-DATE means to make sure that -NEWNAME has the same timestamp as FILENAME. - -This function is invoked by `tramp-fish-handle-copy-file' and -`tramp-fish-handle-rename-file'. It is an error if OP is neither -of `copy' and `rename'. FILENAME and NEWNAME must be absolute -file names." - (unless (memq op '(copy rename)) - (error "Unknown operation `%s', must be `copy' or `rename'" op)) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname))) - - (unless ok-if-already-exists - (when (and t2 (file-exists-p newname)) - (with-parsed-tramp-file-name newname nil - (tramp-error - v 'file-already-exists "File %s already exists" newname)))) - - (prog1 - (cond - ;; Both are Tramp files. - ((and t1 t2) - (cond - ;; Shortcut: if method, host, user are the same for both - ;; files, we invoke `cp' or `mv' on the remote host - ;; directly. - ((tramp-equal-remote filename newname) - (tramp-fish-do-copy-or-rename-file-directly - op filename newname keep-date preserve-uid-gid)) - ;; No shortcut was possible. So we copy the - ;; file first. If the operation was `rename', we go - ;; back and delete the original file (if the copy was - ;; successful). The approach is simple-minded: we - ;; create a new buffer, insert the contents of the - ;; source file into it, then write out the buffer to - ;; the target file. The advantage is that it doesn't - ;; matter which filename handlers are used for the - ;; source and target file. - (t - (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) - - ;; One file is a Tramp file, the other one is local. - ((or t1 t2) - ;; Use the generic method via a Tramp buffer. - (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)) - - (t - ;; One of them must be a Tramp file. - (error "Tramp implementation says this cannot happen"))) - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v localname) - (tramp-flush-file-property v (file-name-directory localname))))))) - -(defun tramp-fish-do-copy-or-rename-file-directly - (op filename newname keep-date preserve-uid-gid) - "Invokes `COPY' or `RENAME' on the remote system. -OP must be one of `copy' or `rename', indicating `cp' or `mv', -respectively. VEC specifies the connection. LOCALNAME1 and -LOCALNAME2 specify the two arguments of `cp' or `mv'. If -KEEP-DATE is non-nil, preserve the time stamp when copying. -PRESERVE-UID-GID is completely ignored." - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (tramp-fish-send-command - v1 - (format "%s %s %s" - (if (eq op 'copy) "#COPY" "#RENAME") - (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname))))) - ;; KEEP-DATE handling. - (when (and keep-date (functionp 'set-file-times)) - (set-file-times newname (nth 5 (file-attributes filename)))) - ;; Set the mode. - (set-file-modes newname (tramp-default-file-modes filename))) - -(defun tramp-fish-get-file-entries (vec localname list) - "Read entries returned by FISH server. -When LIST is true, a #LIST command will be sent, including all entries -of a directory. Otherwise, #STAT is sent for just one entry. -Result is a list of (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME -SIZE MODE WEIRD INODE DEVICE)." - (block nil - (with-current-buffer (tramp-get-buffer vec) - ;; #LIST does not work properly with trailing "/", at least in - ;; .fishsrv.pl. - (when (string-match "/$" localname) - (setq localname (concat localname "."))) - - (let ((command (format "%s %s" (if list "#LIST" "#STAT") localname)) - buffer-read-only num res) - - ;; Send command - (tramp-fish-send-command vec command) - - ;; Read number of entries - (goto-char (point-min)) - (condition-case nil - (unless (integerp (setq num (read (current-buffer)))) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; Read return code - (goto-char (point-min)) - (condition-case nil - (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; Loop the listing - (dotimes (i num) - (let ((item (tramp-fish-read-file-entry))) - ;; Add inode and device. - (add-to-list - 'res (append item - (list (tramp-get-inode vec) - (tramp-get-device vec)))))) - - ;; Read return code - (goto-char (point-min)) - (condition-case nil - (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil)) - (error (tramp-error - vec 'file-error - "`%s' does not return a valid Lisp expression: `%s'" - command (buffer-string)))) - (forward-line) - (delete-region (point-min) (point)) - - res)))) - -(defun tramp-fish-read-file-entry () - "Parse entry in output buffer. -Result is the list (LOCALNAME LINK COUNT UID GID ATIME MTIME CTIME -SIZE MODE WEIRD)." - ;; We are called from `tramp-fish-get-file-entries', which sets the - ;; current buffer. - (let (buffer-read-only localname link uid gid mtime size mode) - (block nil - (while t - (cond - ;; P<unix permissions> <owner>.<group> - ((looking-at "^P\\(.+\\)\\s-\\(.+\\)\\.\\(.+\\)$") - (setq mode (match-string 1)) - (setq uid (match-string 2)) - (setq gid (match-string 3)) - (when (string-match "^d" mode) (setq link t))) - ;; S<size> - ((looking-at "^S\\([0-9]+\\)$") - (setq size (string-to-number (match-string 1)))) - ;; D<year> <month> <day> <hour> <minute> <second>[.1234] - ((looking-at - "^D\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\([0-9]+\\)\\s-\\(\\S-+\\)$") - (setq mtime - (encode-time - (string-to-number (match-string 6)) - (string-to-number (match-string 5)) - (string-to-number (match-string 4)) - (string-to-number (match-string 3)) - (string-to-number (match-string 2)) - (string-to-number (match-string 1))))) - ;; d<3-letters month name> <day> <year or HH:MM> - ((looking-at "^d") nil) - ;; E<major-of-device>,<minor> - ((looking-at "^E") nil) - ;; :<filename> - ((looking-at "^:\\(.+\\)$") - (setq localname (match-string 1))) - ;; L<filename symlink points to> - ((looking-at "^L\\(.+\\)$") - (setq link (match-string 1))) - ;; M<mimetype> - ((looking-at "^M\\(.+\\)$") nil) - ;; last line - ((looking-at "^$") - (return))) - ;; Delete line. - (forward-line) - (delete-region (point-min) (point)))) - - ;; Delete trailing empty line. - (forward-line) - (delete-region (point-min) (point)) - - ;; Return entry in `file-attributes' format. - (list localname link -1 uid gid '(0 0) mtime '(0 0) size mode nil))) - -(defun tramp-fish-retrieve-data (vec) - "Reads remote data for FISH protocol. -The data are left in the connection buffer of VEC for further processing. -Returns the size of the data." - (block nil - (with-current-buffer (tramp-get-buffer vec) - ;; The retrieved data might be in binary format, without - ;; trailing newline. Therefore, the OK prompt might not start - ;; at the beginning of a line. - (let ((tramp-fish-ok-prompt-regexp "### 200\n") - size) - - ;; Send command - (tramp-fish-send-command - vec (format "#RETR %s" (tramp-file-name-localname vec))) - - ;; Read filesize - (goto-char (point-min)) - (condition-case nil - (unless (integerp (setq size (read (current-buffer)))) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; Read return code - (goto-char (point-min)) - (condition-case nil - (unless (looking-at tramp-fish-continue-prompt-regexp) (error nil)) - (error (return nil))) - (forward-line) - (delete-region (point-min) (point)) - - ;; The received data might contain the OK prompt already, so - ;; there might be outstanding data. - (while (/= (+ size (length tramp-fish-ok-prompt-regexp)) - (- (point-max) (point-min))) - (tramp-wait-for-regexp - (tramp-get-connection-process vec) nil - (concat tramp-fish-ok-prompt-regexp "$"))) - - ;; Read return code - (goto-char (+ (point-min) size)) - (condition-case nil - (unless (looking-at tramp-fish-ok-prompt-regexp) (error nil)) - (error (return nil))) - (delete-region (+ (point-min) size) (point-max)) - size)))) - - -;; Connection functions - -(defun tramp-fish-maybe-open-connection (vec) - "Maybe open a connection VEC. -Does not do anything if a connection is already open, but re-opens the -connection if a previous connection has died for some reason." - (let ((process-connection-type tramp-process-connection-type) - (p (get-buffer-process (tramp-get-buffer vec)))) - - ;; New connection must be opened. - (unless (and p (processp p) (memq (process-status p) '(run open))) - - ;; Set variables for computing the prompt for reading password. - (setq tramp-current-method (tramp-file-name-method vec) - tramp-current-user (tramp-file-name-user vec) - tramp-current-host (tramp-file-name-host vec)) - - ;; Start new process. - (when (and p (processp p)) - (delete-process p)) - (setenv "TERM" tramp-terminal-type) - (setenv "PS1" tramp-initial-end-of-output) - (with-progress-reporter - vec 3 - (format "Opening connection for %s@%s using %s" - tramp-current-user tramp-current-host tramp-current-method) - - (let* ((process-connection-type tramp-process-connection-type) - (inhibit-eol-conversion nil) - (coding-system-for-read 'binary) - (coding-system-for-write 'binary) - ;; This must be done in order to avoid our file name handler. - (p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (start-process - (or (tramp-get-connection-property vec "process-name" nil) - (tramp-buffer-name vec)) - (tramp-get-connection-buffer vec) - "ssh" "-l" - (tramp-file-name-user vec) - (tramp-file-name-host vec))))) - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - - ;; Check whether process is alive. - (tramp-set-process-query-on-exit-flag p nil) - - (tramp-process-actions p vec tramp-actions-before-shell 60) - (tramp-fish-send-command vec tramp-fish-start-fish-server-command) - (tramp-message - vec 3 - "Found remote shell prompt on `%s'" (tramp-file-name-host vec))))))) - -(defun tramp-fish-send-command (vec command) - "Send the COMMAND to connection VEC." - (tramp-fish-maybe-open-connection vec) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (tramp-wait-for-regexp - (tramp-get-connection-process vec) nil - (concat tramp-fish-ok-prompt-regexp "\\|" tramp-fish-error-prompt-regexp))) - -(defun tramp-fish-send-command-and-check (vec command) - "Send the COMMAND to connection VEC. -Returns nil if there has been an error message." - - ;; Send command. - (tramp-fish-send-command vec command) - - ;; Read return code. - (with-current-buffer (tramp-get-buffer vec) - (goto-char (point-min)) - (looking-at tramp-fish-ok-prompt-regexp))) - -(provide 'tramp-fish) -; -;;;; TODO: -; -;; * Evaluate the MIME information with #LIST or #STAT. -; - -;; arch-tag: a66df7df-5f29-42a7-a921-643ceb29db49 -;;;; tramp-fish.el ends here diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index e8e06bb38f8..91eb27e89ee 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -5,6 +5,7 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -29,7 +30,6 @@ ;;; Code: (require 'tramp) -(autoload 'tramp-set-connection-property "tramp-cache") (eval-when-compile @@ -98,19 +98,20 @@ present for backward compatibility." (add-hook 'tramp-ftp-unload-hook 'tramp-ftp-enable-ange-ftp) ;; Define FTP method ... -(defcustom tramp-ftp-method "ftp" - "*When this method name is used, forward all calls to Ange-FTP." - :group 'tramp - :type 'string) +;;;###tramp-autoload +(defconst tramp-ftp-method "ftp" + "*When this method name is used, forward all calls to Ange-FTP.") ;; ... and add it to the method list. -(add-to-list 'tramp-methods (cons tramp-ftp-method nil)) +;;;###tramp-autoload +(unless (featurep 'xemacs) + (add-to-list 'tramp-methods (cons tramp-ftp-method nil)) -;; Add some defaults for `tramp-default-method-alist' -(add-to-list 'tramp-default-method-alist - (list "\\`ftp\\." "" tramp-ftp-method)) -(add-to-list 'tramp-default-method-alist - (list "" "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method)) + ;; Add some defaults for `tramp-default-method-alist'. + (add-to-list 'tramp-default-method-alist + (list "\\`ftp\\." nil tramp-ftp-method)) + (add-to-list 'tramp-default-method-alist + (list nil "\\`\\(anonymous\\|ftp\\)\\'" tramp-ftp-method))) ;; Add completion function for FTP method. (tramp-set-completion-function @@ -128,6 +129,7 @@ present for backward compatibility." (symbol-plist 'substitute-in-file-name)))))) +;;;###tramp-autoload (defun tramp-ftp-file-name-handler (operation &rest args) "Invoke the Ange-FTP handler for OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -198,23 +200,25 @@ pass to the OPERATION." (inhibit-file-name-operation operation)) (apply 'ange-ftp-hook-function operation args))))))) -(defun tramp-ftp-file-name-p (filename) +;;;###tramp-autoload +(defsubst 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-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)) +;;;###tramp-autoload +(unless (featurep 'xemacs) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-ftp-file-name-p 'tramp-ftp-file-name-handler))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-ftp 'force))) (provide 'tramp-ftp) ;;; TODO: -;; * In case of "/ftp:host:file" this works only for functions which -;; are defined in `tramp-file-name-handler-alist'. Call has to be -;; pretended in `tramp-file-name-handler' otherwise. -;; Furthermore, there are no backup files on FTP hosts. -;; Worth further investigations. +;; * There are no backup files on FTP hosts. -;; arch-tag: 759fb338-5c63-4b99-bd36-b4d59db91cff ;;; tramp-ftp.el ends here diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 479eaae0aef..054875f4dbc 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -4,6 +4,7 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -102,11 +103,13 @@ (require 'custom)) (require 'tramp) + (require 'dbus) (require 'url-parse) (require 'url-util) (require 'zeroconf) +;;;###tramp-autoload (defcustom tramp-gvfs-methods '("dav" "davs" "obex" "synce") "*List of methods for remote files, accessed with GVFS." :group 'tramp @@ -121,8 +124,8 @@ ;; Add a default for `tramp-default-user-alist'. Rule: For the SYNCE ;; method, no user is chosen. -(add-to-list 'tramp-default-user-alist - '("synce" nil nil)) +;;;###tramp-autoload +(add-to-list 'tramp-default-user-alist '("\\`synce\\'" nil nil)) (defcustom tramp-gvfs-zeroconf-domain "local" "*Zeroconf domain to be used for discovering services, like host names." @@ -132,11 +135,11 @@ ;; Add the methods to `tramp-methods', in order to allow minibuffer ;; completion. -(eval-after-load "tramp-gvfs" - '(when (featurep 'tramp-gvfs) - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil)))))) +;;;###tramp-autoload +(when (featurep 'dbusbind) + (dolist (elt tramp-gvfs-methods) + (unless (assoc elt tramp-methods) + (add-to-list 'tramp-methods (cons elt nil))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceeding object path for own objects.") @@ -144,9 +147,12 @@ (defconst tramp-gvfs-service-daemon "org.gtk.vfs.Daemon" "The well known name of the GVFS daemon.") -;; Check that GVFS is available. -(unless (dbus-ping :session tramp-gvfs-service-daemon 100) - (throw 'tramp-loading nil)) +;; Check that GVFS is available. D-Bus integration is available since +;; Emacs 23 on some system types. We don't call `dbus-ping', because +;; this would load dbus.el. +(unless (and (tramp-compat-funcall 'dbus-get-unique-name :session) + (tramp-compat-process-running-p "gvfs-fuse-daemon")) + (error "Package `tramp-gvfs' not supported")) (defconst tramp-gvfs-path-mounttracker "/org/gtk/vfs/mounttracker" "The object path of the GVFS daemon.") @@ -384,7 +390,7 @@ Every entry is a list (NAME ADDRESS).") (expand-file-name . tramp-gvfs-handle-expand-file-name) ;; `file-accessible-directory-p' performed by default handler. (file-attributes . tramp-gvfs-handle-file-attributes) - (file-directory-p . tramp-smb-handle-file-directory-p) + (file-directory-p . tramp-gvfs-handle-file-directory-p) (file-executable-p . tramp-gvfs-handle-file-executable-p) (file-exists-p . tramp-gvfs-handle-file-exists-p) (file-local-copy . tramp-gvfs-handle-file-local-copy) @@ -430,13 +436,15 @@ Every entry is a list (NAME ADDRESS).") "Alist of handler functions for Tramp GVFS method. Operations not mentioned here will be handled by the default Emacs primitives.") -(defun tramp-gvfs-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-gvfs-file-name-p (filename) "Check if it's a filename handled by the GVFS daemon." (and (tramp-tramp-file-p filename) (let ((method (tramp-file-name-method (tramp-dissect-file-name filename)))) (and (stringp method) (member method tramp-gvfs-methods))))) +;;;###tramp-autoload (defun tramp-gvfs-file-name-handler (operation &rest args) "Invoke the GVFS related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -448,8 +456,10 @@ pass to the OPERATION." ;; This might be moved to tramp.el. It shall be the first file name ;; handler. -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler)) +;;;###tramp-autoload +(when (featurep 'dbusbind) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-gvfs-file-name-p 'tramp-gvfs-file-name-handler))) (defun tramp-gvfs-stringify-dbus-message (message) "Convert a D-Bus message into readable UTF8 strings, used for traces." @@ -484,7 +494,8 @@ will be traced by Tramp with trace level 6." (put 'with-tramp-dbus-call-method 'lisp-indent-function 2) (put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) (defmacro with-tramp-gvfs-error-message (filename handler &rest args) "Apply a Tramp GVFS `handler'. @@ -493,7 +504,7 @@ In case of an error, modify the error message by replacing `(let ((fuse-file-name (regexp-quote (tramp-gvfs-fuse-file-name ,filename))) elt) (condition-case err - (funcall ,handler ,@args) + (tramp-compat-funcall ,handler ,@args) (error (setq elt (cdr err)) (while elt @@ -505,7 +516,8 @@ In case of an error, modify the error message by replacing (put 'with-tramp-gvfs-error-message 'lisp-indent-function 2) (put 'with-tramp-gvfs-error-message 'edebug-form-spec '(form symbolp body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-tramp-gvfs-error-message\\>")) (defvar tramp-gvfs-dbus-event-vector nil "Current Tramp file name to be used, as vector. @@ -515,7 +527,6 @@ is no information where to trace the message.") (defun tramp-gvfs-dbus-event-error (event err) "Called when a D-Bus error message arrives, see `dbus-event-error-hooks'." (when tramp-gvfs-dbus-event-vector - ;(tramp-cleanup-connection tramp-gvfs-dbus-event-vector) (tramp-message tramp-gvfs-dbus-event-vector 10 "%S" event) (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) @@ -646,6 +657,10 @@ is no information where to trace the message.") "Like `file-attributes' for Tramp files." (file-attributes (tramp-gvfs-fuse-file-name filename) id-format)) +(defun tramp-gvfs-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + (file-directory-p (tramp-gvfs-fuse-file-name filename))) + (defun tramp-gvfs-handle-file-executable-p (filename) "Like `file-executable-p' for Tramp files." (file-executable-p (tramp-gvfs-fuse-file-name filename))) @@ -955,7 +970,7 @@ ADDRESS can have the form \"xx:xx:xx:xx:xx:xx\" or \"[xx:xx:xx:xx:xx:xx]\"." ;; host signature. (with-temp-buffer ;; Preserve message for `progress-reporter'. - (with-temp-message "" + (tramp-compat-with-temp-message "" (insert message) (pop-to-buffer (current-buffer)) (setq choice (if (yes-or-no-p (concat (car choices) " ")) 0 1)) @@ -1178,7 +1193,7 @@ connection if a previous connection has died for some reason." :name (tramp-buffer-name vec) :buffer (tramp-get-buffer vec) :server t :host 'local :service t))) - (tramp-set-process-query-on-exit-flag p nil))) + (tramp-compat-set-process-query-on-exit-flag p nil))) (unless (tramp-gvfs-connection-mounted-p vec) (let* ((method (tramp-file-name-method vec)) @@ -1402,6 +1417,10 @@ They are retrieved from the hal daemon." (tramp-set-completion-function "synce" '((tramp-synce-parse-device-names ""))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-gvfs 'force))) + (provide 'tramp-gvfs) ;;; TODO: @@ -1413,5 +1432,4 @@ They are retrieved from the hal daemon." ;; capability. ;; * Implement obex for other serial communication but bluetooth. -;; arch-tag: f7f660ce-77f4-4132-9663-f5c25a47f7ed ;;; tramp-gvfs.el ends here diff --git a/lisp/net/tramp-gw.el b/lisp/net/tramp-gw.el index 2b01b91e9ac..14968580b1b 100644 --- a/lisp/net/tramp-gw.el +++ b/lisp/net/tramp-gw.el @@ -4,6 +4,7 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -37,38 +38,47 @@ (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))))) +;; We don't add the following methods to `tramp-methods', in order to +;; exclude them from file name completion. + ;; Define HTTP tunnel method ... -(defvar tramp-gw-tunnel-method "tunnel" +;;;###tramp-autoload +(defconst tramp-gw-tunnel-method "tunnel" "*Method to connect HTTP gateways.") ;; ... and port. -(defvar tramp-gw-default-tunnel-port 8080 +(defconst tramp-gw-default-tunnel-port 8080 "*Default port for HTTP gateways.") ;; Define SOCKS method ... -(defvar tramp-gw-socks-method "socks" +;;;###tramp-autoload +(defconst tramp-gw-socks-method "socks" "*Method to connect SOCKS servers.") ;; ... and port. -(defvar tramp-gw-default-socks-port 1080 +(defconst tramp-gw-default-socks-port 1080 "*Default port for SOCKS servers.") +;; 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" tramp-gw-default-socks-port 5)) + ;; 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))) +;;;###tramp-autoload +(add-to-list + 'tramp-default-user-alist + (list (concat "\\`" + (regexp-opt (list tramp-gw-tunnel-method tramp-gw-socks-method)) + "\\'") + nil (user-login-name))) ;; Internal file name functions and variables. @@ -103,7 +113,7 @@ 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) + (tramp-compat-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) @@ -124,6 +134,7 @@ (process-send-string (tramp-get-connection-property proc "process" nil) string))) +;;;###tramp-autoload (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 @@ -149,7 +160,7 @@ instead of the host name declared in TARGET-VEC." :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-compat-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)))) @@ -189,12 +200,12 @@ instead of the host name declared in TARGET-VEC." (setq tramp-gw-gw-proc (funcall socks-function - (tramp-buffer-name gw-vec) - (tramp-get-buffer gw-vec) + (tramp-get-connection-name gw-vec) + (tramp-get-connection-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-compat-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")) @@ -225,7 +236,7 @@ authentication is requested from proxy server, provide it." (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) + (tramp-compat-set-process-query-on-exit-flag proc nil) ;; Send CONNECT command. (process-send-string proc (format "%s%s\r\n" command authentication)) (tramp-message @@ -238,10 +249,9 @@ authentication is requested from proxy server, provide it." ;; 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)) + (ignore-errors + (let (tramp-verbose) + (tramp-wait-for-regexp proc 65 "\r?\n\r?\n"))) ;; Check return code. (goto-char (point-min)) (narrow-to-region @@ -309,6 +319,9 @@ password in password cache. This is done for the first try only." (format "Password for %s@[%s]: " socks-username (read (current-buffer))))))))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-gw 'force))) (provide 'tramp-gw) @@ -317,5 +330,4 @@ password in password cache. This is done for the first try only." ;; * Provide descriptive Commentary. ;; * Enable it for several gateway processes in parallel. -;; arch-tag: 277e3a81-fdee-40cf-9e6b-59626292a5e0 ;;; tramp-gw.el ends here diff --git a/lisp/net/tramp-imap.el b/lisp/net/tramp-imap.el index a5ca8a7bb54..c339df1a9ec 100644 --- a/lisp/net/tramp-imap.el +++ b/lisp/net/tramp-imap.el @@ -4,6 +4,7 @@ ;; Author: Teodor Zlatanov <tzz@lifelogs.com> ;; Keywords: mail, comm +;; Package: tramp ;; This file is part of GNU Emacs. @@ -54,7 +55,6 @@ (require 'assoc) (require 'tramp) -(require 'tramp-compat) (autoload 'auth-source-user-or-password "auth-source") (autoload 'epg-context-operation "epg") @@ -75,25 +75,34 @@ '(add-to-list 'imap-hash-headers 'X-Size 'append)) ;; Define Tramp IMAP method ... +;;;###tramp-autoload (defconst tramp-imap-method "imap" "*Method to connect via IMAP protocol.") -(add-to-list 'tramp-methods (list tramp-imap-method '(tramp-default-port 143))) - -;; Add a default for `tramp-default-user-alist'. Default is the local user. -(add-to-list 'tramp-default-user-alist - `(,tramp-imap-method nil ,(user-login-name))) +;;;###tramp-autoload +(when (and (locate-library "epa") (locate-library "imap-hash")) + (add-to-list 'tramp-methods + (list tramp-imap-method '(tramp-default-port 143)))) ;; Define Tramp IMAPS method ... +;;;###tramp-autoload (defconst tramp-imaps-method "imaps" "*Method to connect via secure IMAP protocol.") ;; ... and add it to the method list. -(add-to-list 'tramp-methods (list tramp-imaps-method '(tramp-default-port 993))) +;;;###tramp-autoload +(when (and (locate-library "epa") (locate-library "imap-hash")) + (add-to-list 'tramp-methods + (list tramp-imaps-method '(tramp-default-port 993)))) ;; Add a default for `tramp-default-user-alist'. Default is the local user. -(add-to-list 'tramp-default-user-alist - `(,tramp-imaps-method nil ,(user-login-name))) +;;;###tramp-autoload +(add-to-list + 'tramp-default-user-alist + (list (concat "\\`" + (regexp-opt (list tramp-imap-method tramp-imaps-method)) + "\\'") + nil (user-login-name))) ;; Add completion function for IMAP method. ;; (tramp-set-completion-function @@ -114,7 +123,7 @@ (directory-file-name . tramp-handle-directory-file-name) (directory-files . tramp-handle-directory-files) (directory-files-and-attributes - . tramp-imap-handle-directory-files-and-attributes) + . tramp-handle-directory-files-and-attributes) (dired-call-process . ignore) ;; `dired-compress-file' performed by default handler ;; `dired-uncache' performed by default handler @@ -122,8 +131,8 @@ ;; `file-accessible-directory-p' performed by default handler (file-attributes . tramp-imap-handle-file-attributes) (file-directory-p . tramp-imap-handle-file-directory-p) - (file-executable-p . tramp-imap-handle-file-executable-p) - (file-exists-p . tramp-imap-handle-file-exists-p) + (file-executable-p . ignore) + (file-exists-p . tramp-handle-file-exists-p) (file-local-copy . tramp-imap-handle-file-local-copy) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-imap-handle-file-name-all-completions) @@ -132,9 +141,9 @@ (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-newer-than-file-p . tramp-imap-handle-file-newer-than-file-p) + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-imap-handle-file-readable-p) + (file-readable-p . tramp-handle-file-exists-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) ;; `file-selinux-context' performed by default handler. @@ -183,13 +192,15 @@ Operations not mentioned here will be handled by the default Emacs primitives.") (defvar tramp-imap-passphrase-cache nil) ;; can be t or 'never (defvar tramp-imap-passphrase nil) -(defun tramp-imap-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-imap-file-name-p (filename) "Check if it's a filename for IMAP protocol." (let ((v (tramp-dissect-file-name filename))) (or (string= (tramp-file-name-method v) tramp-imap-method) (string= (tramp-file-name-method v) tramp-imaps-method)))) +;;;###tramp-autoload (defun tramp-imap-file-name-handler (operation &rest args) "Invoke the IMAP related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -199,8 +210,10 @@ pass to the OPERATION." (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args)))) -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler)) +;;;###tramp-autoload +(when (and (locate-library "epa") (locate-library "imap-hash")) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-imap-file-name-p 'tramp-imap-file-name-handler))) (defun tramp-imap-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -514,10 +527,6 @@ SIZE MODE WEIRD INODE DEVICE)." (goto-char point) (list (expand-file-name filename) size)))))) -(defun tramp-imap-handle-file-exists-p (filename) - "Like `file-exists-p' for Tramp files." - (and (file-attributes filename) t)) - (defun tramp-imap-handle-file-directory-p (filename) "Like `file-directory-p' for Tramp-IMAP files." ;; We allow only mailboxes to be a directory. @@ -537,14 +546,6 @@ SIZE MODE WEIRD INODE DEVICE)." "Get inode equivalent \(actually the UID) for Tramp-IMAP FILENAME." (nth 10 (tramp-compat-file-attributes filename id-format))) -(defun tramp-imap-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files. False for IMAP." - nil) - -(defun tramp-imap-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files. True for IMAP." - (file-exists-p filename)) - (defun tramp-imap-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files. True for IMAP." ;; `file-exists-p' does not work yet for directories. @@ -559,24 +560,6 @@ SIZE MODE WEIRD INODE DEVICE)." (let ((iht (tramp-imap-make-iht v))) (imap-hash-rem (tramp-imap-get-file-inode filename) iht)))))) -(defun tramp-imap-handle-directory-files-and-attributes - (directory &optional full match nosort id-format) - "Like `directory-files-and-attributes' for Tramp files." - (mapcar - (lambda (x) - (cons x (tramp-compat-file-attributes - (if full x (expand-file-name x directory)) id-format))) - (directory-files directory full match nosort))) - -;; TODO: fix this in tramp-imap-get-file-entries. -(defun tramp-imap-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond - ((not (file-exists-p file1)) nil) - ((not (file-exists-p file2)) t) - (t (tramp-time-less-p (nth 5 (file-attributes file2)) - (nth 5 (file-attributes file1)))))) - (defun tramp-imap-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name (expand-file-name filename) nil @@ -764,8 +747,7 @@ With NEEDED-SUBJECT, alters the imap-hash test accordingly." (method (tramp-file-name-method vec)) (user (tramp-file-name-user vec)) (ssl (string-equal method tramp-imaps-method)) - (port (or (tramp-file-name-port vec) - (tramp-get-method-parameter method 'tramp-default-port))) + (port (tramp-file-name-port vec)) (result (imap-hash-make server port mbox user nil ssl))) ;; Return the IHT with a test override to look for the subject ;; marker. @@ -775,6 +757,10 @@ With NEEDED-SUBJECT, alters the imap-hash test accordingly." tramp-imap-subject-marker (if needed-subject needed-subject ""))))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-imap 'force))) + ;;; TODO: ;; * Implement `tramp-imap-handle-delete-directory', @@ -856,5 +842,3 @@ With NEEDED-SUBJECT, alters the imap-hash test accordingly." ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/test/welcommen")) ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4")) ;;; (tramp-imap-make-iht (tramp-dissect-file-name "/imap:yourhosthere.com:/INBOX.test/4") "extra") - -;; arch-tag: f2723749-58fb-4f29-894e-39708096e850 diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el new file mode 100644 index 00000000000..ae7deeeb953 --- /dev/null +++ b/lisp/net/tramp-sh.el @@ -0,0 +1,5061 @@ +;;; tramp-sh.el --- Tramp access functions for (s)sh-like connections + +;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, +;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. + +;; (copyright statements below in code to be updated with the above notice) + +;; Author: Kai Großjohann <kai.grossjohann@gmx.net> +;; Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; 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. If not, see <http://www.gnu.org/licenses/>. + +;;; Code: + +(eval-when-compile (require 'cl)) ; ignore-errors +(require 'tramp) +(require 'shell) + +;; Pacify byte-compiler. The function is needed on XEmacs only. I'm +;; not sure at all that this is the right way to do it, but let's hope +;; it works for now, and wait for a guru to point out the Right Way to +;; achieve this. +;;(eval-when-compile +;; (unless (fboundp 'dired-insert-set-properties) +;; (fset 'dired-insert-set-properties 'ignore))) +;; Gerd suggests this: +(eval-when-compile (require 'dired)) +;; Note that dired is required at run-time, too, when it is needed. +;; It is only needed on XEmacs for the function +;; `dired-insert-set-properties'. + +(defcustom tramp-inline-compress-start-size 4096 + "*The minimum size of compressing where inline transfer. +When inline transfer, compress transfered data of file +whose size is this value or above (up to `tramp-copy-size-limit'). +If it is nil, no compression at all will be applied." + :group 'tramp + :type '(choice (const nil) integer)) + +(defcustom tramp-copy-size-limit 10240 + "*The maximum file size where inline copying is preferred over an out-of-the-band copy. +If it is nil, inline out-of-the-band copy will be used without a check." + :group 'tramp + :type '(choice (const nil) integer)) + +;;;###tramp-autoload +(defcustom tramp-terminal-type "dumb" + "*Value of TERM environment variable for logging in to remote host. +Because Tramp wants to parse the output of the remote shell, it is easily +confused by ANSI color escape sequences and suchlike. Often, shell init +files conditionalize this setup based on the TERM environment variable." + :group 'tramp + :type 'string) + +;; ksh on OpenBSD 4.5 requires, that $PS1 contains a `#' character for +;; root users. It uses the `$' character for other users. In order +;; to guarantee a proper prompt, we use "#$" for the prompt. + +(defvar tramp-end-of-output + (format + "///%s#$" + (md5 (concat (prin1-to-string process-environment) (current-time-string)))) + "String used to recognize end of output. +The '$' character at the end is quoted; the string cannot be +detected as prompt when being sent on echoing hosts, therefore.") + +;;;###tramp-autoload +(defconst tramp-initial-end-of-output "#$ " + "Prompt when establishing a connection.") + +;; Initialize `tramp-methods' with the supported methods. +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("rcp" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rcp") + (tramp-copy-args (("%k" "-p") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("remcp" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rcp") + (tramp-copy-args (("%k" "-p"))) + (tramp-copy-keep-date t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scp" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scp1" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-1") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-1") ("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scp2" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-2") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-2") ("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scpc" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-o" "ControlPath=%t.%%r@%%h:%%p") + ("-o" "ControlMaster=yes") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r") + ("-o" "ControlPath=%t.%%r@%%h:%%p") + ("-o" "ControlMaster=auto"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("scpx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-e" "none") ("-t" "-t") + ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "scp") + (tramp-copy-args (("-P" "%p") ("%k" "-p") ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("sftp" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "sftp"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("rsync" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rsync") + (tramp-copy-args (("-e" "ssh") ("%k" "-t") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-keep-tmpfile t) + (tramp-copy-recursive t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + `("rsyncc" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-o" "ControlPath=%t.%%r@%%h:%%p") + ("-o" "ControlMaster=yes") + ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "rsync") + (tramp-copy-args (("%k" "-t") ("-r"))) + (tramp-copy-env (("RSYNC_RSH") + (,(concat + "ssh" + " -o ControlPath=%t.%%r@%%h:%%p" + " -o ControlMaster=auto")))) + (tramp-copy-keep-date t) + (tramp-copy-keep-tmpfile t) + (tramp-copy-recursive t))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("rsh" + (tramp-login-program "rsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("remsh" + (tramp-login-program "remsh") + (tramp-login-args (("%h") ("-l" "%u"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ssh" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ssh1" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-1") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ssh2" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-2") ("-e" "none") ("%h"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("sshx" + (tramp-login-program "ssh") + (tramp-login-args (("-l" "%u") ("-p" "%p") + ("-e" "none") ("-t" "-t") + ("%h") ("/bin/sh"))) + (tramp-async-args (("-q"))) + (tramp-remote-sh "/bin/sh") + (tramp-gw-args (("-o" "GlobalKnownHostsFile=/dev/null") + ("-o" "UserKnownHostsFile=/dev/null") + ("-o" "StrictHostKeyChecking=no"))) + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("telnet" + (tramp-login-program "telnet") + (tramp-login-args (("%h") ("%p"))) + (tramp-remote-sh "/bin/sh") + (tramp-default-port 23))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("su" + (tramp-login-program "su") + (tramp-login-args (("-") ("%u"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("sudo" + (tramp-login-program "sudo") + (tramp-login-args (("-u" "%u") ("-s") ("-H") ("-p" "Password:"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("ksu" + (tramp-login-program "ksu") + (tramp-login-args (("%u") ("-q"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("krlogin" + (tramp-login-program "krlogin") + (tramp-login-args (("%h") ("-l" "%u") ("-x"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("plink" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-password-end-of-line "xy") ;see docstring for "xy" + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("plink1" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-1" "-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-password-end-of-line "xy") ;see docstring for "xy" + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + `("plinkx" + (tramp-login-program "plink") + ;; ("%h") must be a single element, see + ;; `tramp-compute-multi-hops'. + (tramp-login-args (("-load") ("%h") ("-t") + (,(format + "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" + tramp-terminal-type + tramp-initial-end-of-output)) + ("/bin/sh"))) + (tramp-remote-sh "/bin/sh"))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("pscp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "pscp") + (tramp-copy-args (("-P" "%p") ("-scp") ("%k" "-p") + ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-password-end-of-line "xy") ;see docstring for "xy" + (tramp-default-port 22))) +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("psftp" + (tramp-login-program "plink") + (tramp-login-args (("-l" "%u") ("-P" "%p") ("-ssh") ("%h"))) + (tramp-remote-sh "/bin/sh") + (tramp-copy-program "pscp") + (tramp-copy-args (("-P" "%p") ("-sftp") ("%k" "-p") + ("-q") ("-r"))) + (tramp-copy-keep-date t) + (tramp-copy-recursive t) + (tramp-password-end-of-line "xy"))) ;see docstring for "xy" +;;;###tramp-autoload +(add-to-list 'tramp-methods + '("fcp" + (tramp-login-program "fsh") + (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) + (tramp-remote-sh "/bin/sh -i") + (tramp-copy-program "fcp") + (tramp-copy-args (("%k" "-p"))) + (tramp-copy-keep-date t))) + +;;;###tramp-autoload +(add-to-list 'tramp-default-method-alist + `(,tramp-local-host-regexp "\\`root\\'" "su")) + +;;;###tramp-autoload +(add-to-list 'tramp-default-user-alist + `(,(concat "\\`" (regexp-opt '("su" "sudo" "ksu")) "\\'") + nil "root")) +;; Do not add "ssh" based methods, otherwise ~/.ssh/config would be ignored. +;;;###tramp-autoload +(add-to-list 'tramp-default-user-alist + `(,(concat + "\\`" + (regexp-opt + '("rcp" "remcp" "rsh" "telnet" "krlogin" + "plink" "plink1" "pscp" "psftp" "fcp")) + "\\'") + nil ,(user-login-name))) + +(defconst tramp-completion-function-alist-rsh + '((tramp-parse-rhosts "/etc/hosts.equiv") + (tramp-parse-rhosts "~/.rhosts")) + "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.") + +(defconst tramp-completion-function-alist-ssh + '((tramp-parse-rhosts "/etc/hosts.equiv") + (tramp-parse-rhosts "/etc/shosts.equiv") + (tramp-parse-shosts "/etc/ssh_known_hosts") + (tramp-parse-sconfig "/etc/ssh_config") + (tramp-parse-shostkeys "/etc/ssh2/hostkeys") + (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") + (tramp-parse-rhosts "~/.rhosts") + (tramp-parse-rhosts "~/.shosts") + (tramp-parse-shosts "~/.ssh/known_hosts") + (tramp-parse-sconfig "~/.ssh/config") + (tramp-parse-shostkeys "~/.ssh2/hostkeys") + (tramp-parse-sknownhosts "~/.ssh2/knownhosts")) + "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") + +(defconst tramp-completion-function-alist-telnet + '((tramp-parse-hosts "/etc/hosts")) + "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.") + +(defconst tramp-completion-function-alist-su + '((tramp-parse-passwd "/etc/passwd")) + "Default list of (FUNCTION FILE) pairs to be examined for su methods.") + +(defconst tramp-completion-function-alist-putty + '((tramp-parse-putty + "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions")) + "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.") + +(tramp-set-completion-function "rcp" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "remcp" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "scp" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scp1" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scp2" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scpc" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "scpx" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "sftp" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "rsync" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "rsyncc" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "rsh" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "remsh" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "ssh" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh1" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh2" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh1_old" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "ssh2_old" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "sshx" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "telnet" tramp-completion-function-alist-telnet) +(tramp-set-completion-function "su" tramp-completion-function-alist-su) +(tramp-set-completion-function "sudo" tramp-completion-function-alist-su) +(tramp-set-completion-function "ksu" tramp-completion-function-alist-su) +(tramp-set-completion-function "krlogin" tramp-completion-function-alist-rsh) +(tramp-set-completion-function "plink" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "plink1" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "plinkx" tramp-completion-function-alist-putty) +(tramp-set-completion-function "pscp" tramp-completion-function-alist-ssh) +(tramp-set-completion-function "fcp" tramp-completion-function-alist-ssh) + +;; "getconf PATH" yields: +;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin +;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin +;; GNU/Linux (Debian, Suse): /bin:/usr/bin +;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! +;; IRIX64: /usr/bin +(defcustom tramp-remote-path + '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin" + "/local/bin" "/local/freeware/bin" "/local/gnu/bin" + "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin") + "*List of directories to search for executables on remote host. +For every remote host, this variable will be set buffer local, +keeping the list of existing directories on that host. + +You can use `~' in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with `~' will be ignored. + +`Default Directories' represent the list of directories given by +the command \"getconf PATH\". It is recommended to use this +entry on top of this list, because these are the default +directories for POSIX compatible commands. + +`Private Directories' are the settings of the $PATH environment, +as given in your `~/.profile'." + :group 'tramp + :type '(repeat (choice + (const :tag "Default Directories" tramp-default-remote-path) + (const :tag "Private Directories" tramp-own-remote-path) + (string :tag "Directory")))) + +(defcustom tramp-remote-process-environment + `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C" + ,(format "TERM=%s" tramp-terminal-type) + "EMACS=t" ;; Deprecated. + ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) + "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" + "autocorrect=" "correct=") + + "*List of environment variables to be set on the remote host. + +Each element should be a string of the form ENVVARNAME=VALUE. An +entry ENVVARNAME= diables the corresponding environment variable, +which might have been set in the init files like ~/.profile. + +Special handling is applied to the PATH environment, which should +not be set here. Instead of, it should be set via `tramp-remote-path'." + :group 'tramp + :type '(repeat string)) + +(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile")) + "*Alist specifying extra arguments to pass to the remote shell. +Entries are (REGEXP . ARGS) where REGEXP is a regular expression +matching the shell file name and ARGS is a string specifying the +arguments. + +This variable is only used when Tramp needs to start up another shell +for tilde expansion. The extra arguments should typically prevent the +shell from reading its init file." + :group 'tramp + ;; This might be the wrong way to test whether the widget type + ;; `alist' is available. Who knows the right way to test it? + :type (if (get 'alist 'widget-type) + '(alist :key-type string :value-type string) + '(repeat (cons string string)))) + +(defconst tramp-actions-before-shell + '((tramp-login-prompt-regexp tramp-action-login) + (tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (shell-prompt-pattern tramp-action-succeed) + (tramp-shell-prompt-pattern tramp-action-succeed) + (tramp-yesno-prompt-regexp tramp-action-yesno) + (tramp-yn-prompt-regexp tramp-action-yn) + (tramp-terminal-prompt-regexp tramp-action-terminal) + (tramp-process-alive-regexp tramp-action-process-alive)) + "List of pattern/action pairs. +Whenever a pattern matches, the corresponding action is performed. +Each item looks like (PATTERN ACTION). + +The PATTERN should be a symbol, a variable. The value of this +variable gives the regular expression to search for. Note that the +regexp must match at the end of the buffer, \"\\'\" is implicitly +appended to it. + +The ACTION should also be a symbol, but a function. When the +corresponding PATTERN matches, the ACTION function is called.") + +(defconst tramp-actions-copy-out-of-band + '((tramp-password-prompt-regexp tramp-action-password) + (tramp-wrong-passwd-regexp tramp-action-permission-denied) + (tramp-copy-failed-regexp tramp-action-permission-denied) + (tramp-process-alive-regexp tramp-action-out-of-band)) + "List of pattern/action pairs. +This list is used for copying/renaming with out-of-band methods. + +See `tramp-actions-before-shell' for more info.") + +(defconst tramp-uudecode + "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode +cat /tmp/tramp.$$ +rm -f /tmp/tramp.$$" + "Shell function to implement `uudecode' to standard output. +Many systems support `uudecode -o /dev/stdout' or `uudecode -o -' +for this or `uudecode -p', but some systems don't, and for them +we have this shell function.") + +(defconst tramp-perl-file-truename + "%s -e ' +use File::Spec; +use Cwd \"realpath\"; + +sub recursive { + my ($volume, @dirs) = @_; + my $real = realpath(File::Spec->catpath( + $volume, File::Spec->catdir(@dirs), \"\")); + if ($real) { + my ($vol, $dir) = File::Spec->splitpath($real, 1); + return ($vol, File::Spec->splitdir($dir)); + } + else { + my $last = pop(@dirs); + ($volume, @dirs) = recursive($volume, @dirs); + push(@dirs, $last); + return ($volume, @dirs); + } +} + +$result = realpath($ARGV[0]); +if (!$result) { + my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1); + ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir)); + + $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\"); +} + +if ($ARGV[0] =~ /\\/$/) { + $result = $result . \"/\"; +} + +print \"\\\"$result\\\"\\n\"; +' \"$1\" 2>/dev/null" + "Perl script to produce output suitable for use with `file-truename' +on the remote file system. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-perl-file-name-all-completions + "%s -e 'sub case { + my $str = shift; + if ($ARGV[2]) { + return lc($str); + } + else { + return $str; + } +} +opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\"); +@files = readdir(d); closedir(d); +foreach $f (@files) { + if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) { + if (-d \"$ARGV[0]/$f\") { + print \"$f/\\n\"; + } + else { + print \"$f\\n\"; + } + } +} +print \"ok\\n\" +' \"$1\" \"$2\" \"$3\" 2>/dev/null" + "Perl script to produce output suitable for use with +`file-name-all-completions' on the remote file system. Escape +sequence %s is replaced with name of Perl binary. This string is +passed to `format', so percent characters need to be doubled.") + +;; Perl script to implement `file-attributes' in a Lisp `read'able +;; output. If you are hacking on this, note that you get *no* output +;; unless this spits out a complete line, including the '\n' at the +;; end. +;; The device number is returned as "-1", because there will be a virtual +;; device number set in `tramp-sh-handle-file-attributes'. +(defconst tramp-perl-file-attributes + "%s -e ' +@stat = lstat($ARGV[0]); +if (!@stat) { + print \"nil\\n\"; + exit 0; +} +if (($stat[2] & 0170000) == 0120000) +{ + $type = readlink($ARGV[0]); + $type = \"\\\"$type\\\"\"; +} +elsif (($stat[2] & 0170000) == 040000) +{ + $type = \"t\"; +} +else +{ + $type = \"nil\" +}; +$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; +$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; +printf( + \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", + $type, + $stat[3], + $uid, + $gid, + $stat[8] >> 16 & 0xffff, + $stat[8] & 0xffff, + $stat[9] >> 16 & 0xffff, + $stat[9] & 0xffff, + $stat[10] >> 16 & 0xffff, + $stat[10] & 0xffff, + $stat[7], + $stat[2], + $stat[1] >> 16 & 0xffff, + $stat[1] & 0xffff +);' \"$1\" \"$2\" 2>/dev/null" + "Perl script to produce output suitable for use with `file-attributes' +on the remote file system. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-perl-directory-files-and-attributes + "%s -e ' +chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); +opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit(); +@list = readdir(DIR); +closedir(DIR); +$n = scalar(@list); +printf(\"(\\n\"); +for($i = 0; $i < $n; $i++) +{ + $filename = $list[$i]; + @stat = lstat($filename); + if (($stat[2] & 0170000) == 0120000) + { + $type = readlink($filename); + $type = \"\\\"$type\\\"\"; + } + elsif (($stat[2] & 0170000) == 040000) + { + $type = \"t\"; + } + else + { + $type = \"nil\" + }; + $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; + $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; + printf( + \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\", + $filename, + $type, + $stat[3], + $uid, + $gid, + $stat[8] >> 16 & 0xffff, + $stat[8] & 0xffff, + $stat[9] >> 16 & 0xffff, + $stat[9] & 0xffff, + $stat[10] >> 16 & 0xffff, + $stat[10] & 0xffff, + $stat[7], + $stat[2], + $stat[1] >> 16 & 0xffff, + $stat[1] & 0xffff, + $stat[0] >> 16 & 0xffff, + $stat[0] & 0xffff); +} +printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null" + "Perl script implementing `directory-files-attributes' as Lisp `read'able +output. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +;; These two use base64 encoding. +(defconst tramp-perl-encode-with-module + "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null" + "Perl program to use for encoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled. +This implementation requires the MIME::Base64 Perl module to be installed +on the remote host.") + +(defconst tramp-perl-decode-with-module + "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null" + "Perl program to use for decoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled. +This implementation requires the MIME::Base64 Perl module to be installed +on the remote host.") + +(defconst tramp-perl-encode + "%s -e ' +# This script contributed by Juanma Barranquero <lektu@terra.es>. +# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 +# Free Software Foundation, Inc. +use strict; + +my %%trans = do { + my $i = 0; + map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)} + split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/); +}; + +binmode(\\*STDIN); + +# We read in chunks of 54 bytes, to generate output lines +# of 72 chars (plus end of line) +$/ = \\54; + +while (my $data = <STDIN>) { + my $pad = q(); + + # Only for the last chunk, and only if did not fill the last three-byte packet + if (eof) { + my $mod = length($data) %% 3; + $pad = q(=) x (3 - $mod) if $mod; + } + + # Not the fastest method, but it is simple: unpack to binary string, split + # by groups of 6 bits and convert back from binary to byte; then map into + # the translation table + print + join q(), + map($trans{$_}, + (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)), + $pad, + qq(\\n); +}' 2>/dev/null" + "Perl program to use for encoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-perl-decode + "%s -e ' +# This script contributed by Juanma Barranquero <lektu@terra.es>. +# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 +# Free Software Foundation, Inc. +use strict; + +my %%trans = do { + my $i = 0; + map {($_, substr(unpack(q(B8), chr $i++), 2, 6))} + split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/) +}; + +my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255; + +binmode(\\*STDOUT); + +# We are going to accumulate into $pending to accept any line length +# (we do not check they are <= 76 chars as the RFC says) +my $pending = q(); + +while (my $data = <STDIN>) { + chomp $data; + + # If we find one or two =, we have reached the end and + # any following data is to be discarded + my $finished = $data =~ s/(==?).*/$1/; + $pending .= $data; + + my $len = length($pending); + my $chunk = substr($pending, 0, $len & ~3); + $pending = substr($pending, $len & ~3 + 1); + + # Easy method: translate from chars to (pregenerated) six-bit packets, join, + # split in 8-bit chunks and convert back to char. + print join q(), + map $bytes{$_}, + ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g); + + last if $finished; +}' 2>/dev/null" + "Perl program to use for decoding a file. +Escape sequence %s is replaced with name of Perl binary. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-vc-registered-read-file-names + "echo \"(\" +while read file; do + if %s \"$file\"; then + echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" + else + echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" + fi + if %s \"$file\"; then + echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" + else + echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" + fi +done +echo \")\"" + "Script to check existence of VC related files. +It must be send formatted with two strings; the tests for file +existence, and file readability. Input shall be read via +here-document, otherwise the command could exceed maximum length +of command line.") + +(defconst tramp-file-mode-type-map + '((0 . "-") ; Normal file (SVID-v2 and XPG2) + (1 . "p") ; fifo + (2 . "c") ; character device + (3 . "m") ; multiplexed character device (v7) + (4 . "d") ; directory + (5 . "?") ; Named special file (XENIX) + (6 . "b") ; block device + (7 . "?") ; multiplexed block device (v7) + (8 . "-") ; regular file + (9 . "n") ; network special file (HP-UX) + (10 . "l") ; symlink + (11 . "?") ; ACL shadow inode (Solaris, not userspace) + (12 . "s") ; socket + (13 . "D") ; door special (Solaris) + (14 . "w")) ; whiteout (BSD) + "A list of file types returned from the `stat' system call. +This is used to map a mode number to a permission string.") + +;; New handlers should be added here. The following operations can be +;; handled using the normal primitives: file-name-sans-versions, +;; get-file-buffer. +(defconst tramp-sh-file-name-handler-alist + '((load . tramp-handle-load) + (make-symbolic-link . tramp-sh-handle-make-symbolic-link) + (file-name-as-directory . tramp-handle-file-name-as-directory) + (file-name-directory . tramp-handle-file-name-directory) + (file-name-nondirectory . tramp-handle-file-name-nondirectory) + (file-truename . tramp-sh-handle-file-truename) + (file-exists-p . tramp-sh-handle-file-exists-p) + (file-directory-p . tramp-sh-handle-file-directory-p) + (file-executable-p . tramp-sh-handle-file-executable-p) + (file-readable-p . tramp-sh-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-writable-p . tramp-sh-handle-file-writable-p) + (file-ownership-preserved-p . tramp-sh-handle-file-ownership-preserved-p) + (file-newer-than-file-p . tramp-sh-handle-file-newer-than-file-p) + (file-attributes . tramp-sh-handle-file-attributes) + (file-modes . tramp-handle-file-modes) + (directory-files . tramp-handle-directory-files) + (directory-files-and-attributes + . tramp-sh-handle-directory-files-and-attributes) + (file-name-all-completions . tramp-sh-handle-file-name-all-completions) + (file-name-completion . tramp-handle-file-name-completion) + (add-name-to-file . tramp-sh-handle-add-name-to-file) + (copy-file . tramp-sh-handle-copy-file) + (copy-directory . tramp-sh-handle-copy-directory) + (rename-file . tramp-sh-handle-rename-file) + (set-file-modes . tramp-sh-handle-set-file-modes) + (set-file-times . tramp-sh-handle-set-file-times) + (make-directory . tramp-sh-handle-make-directory) + (delete-directory . tramp-sh-handle-delete-directory) + (delete-file . tramp-sh-handle-delete-file) + (directory-file-name . tramp-handle-directory-file-name) + ;; `executable-find' is not official yet. + (executable-find . tramp-sh-handle-executable-find) + (start-file-process . tramp-sh-handle-start-file-process) + (process-file . tramp-sh-handle-process-file) + (shell-command . tramp-sh-handle-shell-command) + (insert-directory . tramp-sh-handle-insert-directory) + (expand-file-name . tramp-sh-handle-expand-file-name) + (substitute-in-file-name . tramp-handle-substitute-in-file-name) + (file-local-copy . tramp-sh-handle-file-local-copy) + (file-remote-p . tramp-handle-file-remote-p) + (insert-file-contents . tramp-handle-insert-file-contents) + (insert-file-contents-literally + . tramp-sh-handle-insert-file-contents-literally) + (write-region . tramp-sh-handle-write-region) + (find-backup-file-name . tramp-handle-find-backup-file-name) + (make-auto-save-file-name . tramp-sh-handle-make-auto-save-file-name) + (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) + (dired-compress-file . tramp-sh-handle-dired-compress-file) + (dired-recursive-delete-directory + . tramp-sh-handle-dired-recursive-delete-directory) + (dired-uncache . tramp-handle-dired-uncache) + (set-visited-file-modtime . tramp-sh-handle-set-visited-file-modtime) + (verify-visited-file-modtime . tramp-sh-handle-verify-visited-file-modtime) + (file-selinux-context . tramp-sh-handle-file-selinux-context) + (set-file-selinux-context . tramp-sh-handle-set-file-selinux-context) + (vc-registered . tramp-sh-handle-vc-registered)) + "Alist of handler functions. +Operations not mentioned here will be handled by the normal Emacs functions.") + +;; This must be the last entry, because `identity' always matches. +;;;###tramp-autoload +(add-to-list 'tramp-foreign-file-name-handler-alist + '(identity . tramp-sh-file-name-handler) 'append) + +;;; File Name Handler Functions: + +(defun tramp-sh-handle-make-symbolic-link + (filename linkname &optional ok-if-already-exists) + "Like `make-symbolic-link' for Tramp files. +If LINKNAME is a non-Tramp file, it is used verbatim as the target of +the symlink. If LINKNAME is a Tramp file, only the localname component is +used as the target of the symlink. + +If LINKNAME is a Tramp file and the localname component is relative, then +it is expanded first, before the localname component is taken. Note that +this can give surprising results if the user/host for the source and +target of the symlink differ." + (with-parsed-tramp-file-name linkname l + (let ((ln (tramp-get-remote-ln l)) + (cwd (tramp-run-real-handler + 'file-name-directory (list l-localname)))) + (unless ln + (tramp-error + l 'file-error + "Making a symbolic link. ln(1) does not exist on the remote host.")) + + ;; Do the 'confirm if exists' thing. + (when (file-exists-p linkname) + ;; What to do? + (if (or (null ok-if-already-exists) ; not allowed to exist + (and (numberp ok-if-already-exists) + (not (yes-or-no-p + (format + "File %s already exists; make it a link anyway? " + l-localname))))) + (tramp-error + l 'file-already-exists "File %s already exists" l-localname) + (delete-file linkname))) + + ;; If FILENAME is a Tramp name, use just the localname component. + (when (tramp-tramp-file-p filename) + (setq filename + (tramp-file-name-localname + (tramp-dissect-file-name (expand-file-name filename))))) + + (tramp-flush-file-property l (file-name-directory l-localname)) + (tramp-flush-file-property l l-localname) + + ;; Right, they are on the same host, regardless of user, method, etc. + ;; We now make the link on the remote machine. This will occur as the user + ;; that FILENAME belongs to. + (tramp-send-command-and-check + l + (format + "cd %s && %s -sf %s %s" + (tramp-shell-quote-argument cwd) + ln + (tramp-shell-quote-argument filename) + (tramp-shell-quote-argument l-localname)) + t)))) + +(defun tramp-sh-handle-file-truename (filename &optional counter prev-dirs) + "Like `file-truename' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-file-property v localname "file-truename" + (let ((result nil)) ; result steps in reverse order + (tramp-message v 4 "Finding true name for `%s'" filename) + (cond + ;; Use GNU readlink --canonicalize-missing where available. + ((tramp-get-remote-readlink v) + (setq result + (tramp-send-command-and-read + v + (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\"" + (tramp-get-remote-readlink v) + (tramp-shell-quote-argument localname))))) + + ;; Use Perl implementation. + ((and (tramp-get-remote-perl v) + (tramp-get-connection-property v "perl-file-spec" nil) + (tramp-get-connection-property v "perl-cwd-realpath" nil)) + (tramp-maybe-send-script + v tramp-perl-file-truename "tramp_perl_file_truename") + (setq result + (tramp-send-command-and-read + v + (format "tramp_perl_file_truename %s" + (tramp-shell-quote-argument localname))))) + + ;; Do it yourself. We bind `directory-sep-char' here for + ;; XEmacs on Windows, which would otherwise use backslash. + (t (let* ((directory-sep-char ?/) + (steps (tramp-compat-split-string localname "/")) + (localnamedir (tramp-run-real-handler + 'file-name-as-directory (list localname))) + (is-dir (string= localname localnamedir)) + (thisstep nil) + (numchase 0) + ;; Don't make the following value larger than + ;; necessary. People expect an error message in a + ;; timely fashion when something is wrong; + ;; otherwise they might think that Emacs is hung. + ;; Of course, correctness has to come first. + (numchase-limit 20) + symlink-target) + (while (and steps (< numchase numchase-limit)) + (setq thisstep (pop steps)) + (tramp-message + v 5 "Check %s" + (mapconcat 'identity + (append '("") (reverse result) (list thisstep)) + "/")) + (setq symlink-target + (nth 0 (file-attributes + (tramp-make-tramp-file-name + method user host + (mapconcat 'identity + (append '("") + (reverse result) + (list thisstep)) + "/"))))) + (cond ((string= "." thisstep) + (tramp-message v 5 "Ignoring step `.'")) + ((string= ".." thisstep) + (tramp-message v 5 "Processing step `..'") + (pop result)) + ((stringp symlink-target) + ;; It's a symlink, follow it. + (tramp-message v 5 "Follow symlink to %s" symlink-target) + (setq numchase (1+ numchase)) + (when (file-name-absolute-p symlink-target) + (setq result nil)) + ;; If the symlink was absolute, we'll get a string like + ;; "/user@host:/some/target"; extract the + ;; "/some/target" part from it. + (when (tramp-tramp-file-p symlink-target) + (unless (tramp-equal-remote filename symlink-target) + (tramp-error + v 'file-error + "Symlink target `%s' on wrong host" symlink-target)) + (setq symlink-target localname)) + (setq steps + (append (tramp-compat-split-string + symlink-target "/") + steps))) + (t + ;; It's a file. + (setq result (cons thisstep result))))) + (when (>= numchase numchase-limit) + (tramp-error + v 'file-error + "Maximum number (%d) of symlinks exceeded" numchase-limit)) + (setq result (reverse result)) + ;; Combine list to form string. + (setq result + (if result + (mapconcat 'identity (cons "" result) "/") + "/")) + (when (and is-dir (or (string= "" result) + (not (string= (substring result -1) "/")))) + (setq result (concat result "/")))))) + + (tramp-message v 4 "True name of `%s' is `%s'" filename result) + (tramp-make-tramp-file-name method user host result))))) + +;; Basic functions. + +(defun tramp-sh-handle-file-exists-p (filename) + "Like `file-exists-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-exists-p" + (or (not (null (tramp-get-file-property + v localname "file-attributes-integer" nil))) + (not (null (tramp-get-file-property + v localname "file-attributes-string" nil))) + (tramp-send-command-and-check + v + (format + "%s %s" + (tramp-get-file-exists-command v) + (tramp-shell-quote-argument localname))))))) + +;; CCC: This should check for an error condition and signal failure +;; when something goes wrong. +;; Daniel Pittman <daniel@danann.net> +(defun tramp-sh-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (unless id-format (setq id-format 'integer)) + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (with-parsed-tramp-file-name (expand-file-name filename) nil + (with-file-property v localname (format "file-attributes-%s" id-format) + (save-excursion + (tramp-convert-file-attributes + v + (cond + ((tramp-get-remote-stat v) + (tramp-do-file-attributes-with-stat v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-file-attributes-with-perl v localname id-format)) + (t + (tramp-do-file-attributes-with-ls v localname id-format))))))))) + +(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) + "Implement `file-attributes' for Tramp files using the ls(1) command." + (let (symlinkp dirp + res-inode res-filemodes res-numlinks + res-uid res-gid res-size res-symlink-target) + (tramp-message vec 5 "file attributes with ls: %s" localname) + (tramp-send-command + vec + (format "(%s %s || %s -h %s) && %s %s %s" + (tramp-get-file-exists-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-test-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-ls-command vec) + (if (eq id-format 'integer) "-ildn" "-ild") + (tramp-shell-quote-argument localname))) + ;; parse `ls -l' output ... + (with-current-buffer (tramp-get-buffer vec) + (when (> (buffer-size) 0) + (goto-char (point-min)) + ;; ... inode + (setq res-inode + (condition-case err + (read (current-buffer)) + (invalid-read-syntax + (when (and (equal (cadr err) + "Integer constant overflow in reader") + (string-match + "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'" + (car (cddr err)))) + (let* ((big (read (substring (car (cddr err)) 0 + (match-beginning 1)))) + (small (read (match-string 1 (car (cddr err))))) + (twiddle (/ small 65536))) + (cons (+ big twiddle) + (- small (* twiddle 65536)))))))) + ;; ... file mode flags + (setq res-filemodes (symbol-name (read (current-buffer)))) + ;; ... number links + (setq res-numlinks (read (current-buffer))) + ;; ... uid and gid + (setq res-uid (read (current-buffer))) + (setq res-gid (read (current-buffer))) + (if (eq id-format 'integer) + (progn + (unless (numberp res-uid) (setq res-uid -1)) + (unless (numberp res-gid) (setq res-gid -1))) + (progn + (unless (stringp res-uid) (setq res-uid (symbol-name res-uid))) + (unless (stringp res-gid) (setq res-gid (symbol-name res-gid))))) + ;; ... size + (setq res-size (read (current-buffer))) + ;; From the file modes, figure out other stuff. + (setq symlinkp (eq ?l (aref res-filemodes 0))) + (setq dirp (eq ?d (aref res-filemodes 0))) + ;; if symlink, find out file name pointed to + (when symlinkp + (search-forward "-> ") + (setq res-symlink-target (buffer-substring (point) (point-at-eol)))) + ;; return data gathered + (list + ;; 0. t for directory, string (name linked to) for symbolic + ;; link, or nil. + (or dirp res-symlink-target) + ;; 1. Number of links to file. + res-numlinks + ;; 2. File uid. + res-uid + ;; 3. File gid. + res-gid + ;; 4. Last access time, as a list of two integers. First + ;; integer has high-order 16 bits of time, second has low 16 + ;; bits. + ;; 5. Last modification time, likewise. + ;; 6. Last status change time, likewise. + '(0 0) '(0 0) '(0 0) ;CCC how to find out? + ;; 7. Size in bytes (-1, if number is out of range). + res-size + ;; 8. File modes, as a string of ten letters or dashes as in ls -l. + res-filemodes + ;; 9. t if file's gid would change if file were deleted and + ;; recreated. Will be set in `tramp-convert-file-attributes' + t + ;; 10. inode number. + res-inode + ;; 11. Device number. Will be replaced by a virtual device number. + -1 + ))))) + +(defun tramp-do-file-attributes-with-perl + (vec localname &optional id-format) + "Implement `file-attributes' for Tramp files using a Perl script." + (tramp-message vec 5 "file attributes with perl: %s" localname) + (tramp-maybe-send-script + vec tramp-perl-file-attributes "tramp_perl_file_attributes") + (tramp-send-command-and-read + vec + (format "tramp_perl_file_attributes %s %s" + (tramp-shell-quote-argument localname) id-format))) + +(defun tramp-do-file-attributes-with-stat + (vec localname &optional id-format) + "Implement `file-attributes' for Tramp files using stat(1) command." + (tramp-message vec 5 "file attributes with stat: %s" localname) + (tramp-send-command-and-read + vec + (format + ;; On Opsware, pdksh (which is the true name of ksh there) doesn't + ;; parse correctly the sequence "((". Therefore, we add a space. + "( (%s %s || %s -h %s) && %s -c '((\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)' %s || echo nil)" + (tramp-get-file-exists-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-test-command vec) + (tramp-shell-quote-argument localname) + (tramp-get-remote-stat vec) + (if (eq id-format 'integer) "%u" "\"%U\"") + (if (eq id-format 'integer) "%g" "\"%G\"") + (tramp-shell-quote-argument localname)))) + +(defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) + "Like `set-visited-file-modtime' for Tramp files." + (unless (buffer-file-name) + (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" + (buffer-name))) + (if time-list + (tramp-run-real-handler 'set-visited-file-modtime (list time-list)) + (let ((f (buffer-file-name)) + coding-system-used) + (with-parsed-tramp-file-name f nil + (let* ((attr (file-attributes f)) + ;; '(-1 65535) means file doesn't exists yet. + (modtime (or (nth 5 attr) '(-1 65535)))) + (when (boundp 'last-coding-system-used) + (setq coding-system-used (symbol-value 'last-coding-system-used))) + ;; We use '(0 0) as a don't-know value. See also + ;; `tramp-do-file-attributes-with-ls'. + (if (not (equal modtime '(0 0))) + (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) + (progn + (tramp-send-command + v + (format "%s -ild %s" + (tramp-get-ls-command v) + (tramp-shell-quote-argument localname))) + (setq attr (buffer-substring (point) + (progn (end-of-line) (point))))) + (tramp-set-file-property + v localname "visited-file-modtime-ild" attr)) + (when (boundp 'last-coding-system-used) + (set 'last-coding-system-used coding-system-used)) + nil))))) + +;; This function makes the same assumption as +;; `tramp-sh-handle-set-visited-file-modtime'. +(defun tramp-sh-handle-verify-visited-file-modtime (buf) + "Like `verify-visited-file-modtime' for Tramp files. +At the time `verify-visited-file-modtime' calls this function, we +already know that the buffer is visiting a file and that +`visited-file-modtime' does not return 0. Do not call this +function directly, unless those two cases are already taken care +of." + (with-current-buffer buf + (let ((f (buffer-file-name))) + ;; There is no file visiting the buffer, or the buffer has no + ;; recorded last modification time, or there is no established + ;; connection. + (if (or (not f) + (eq (visited-file-modtime) 0) + (not (tramp-file-name-handler 'file-remote-p f nil 'connected))) + t + (with-parsed-tramp-file-name f nil + (let* ((remote-file-name-inhibit-cache t) + (attr (file-attributes f)) + (modtime (nth 5 attr)) + (mt (visited-file-modtime))) + + (cond + ;; File exists, and has a known modtime. + ((and attr (not (equal modtime '(0 0)))) + (< (abs (tramp-time-diff + modtime + ;; For compatibility, deal with both the old + ;; (HIGH . LOW) and the new (HIGH LOW) return + ;; values of `visited-file-modtime'. + (if (atom (cdr mt)) + (list (car mt) (cdr mt)) + mt))) + 2)) + ;; Modtime has the don't know value. + (attr + (tramp-send-command + v + (format "%s -ild %s" + (tramp-get-ls-command v) + (tramp-shell-quote-argument localname))) + (with-current-buffer (tramp-get-buffer v) + (setq attr (buffer-substring + (point) (progn (end-of-line) (point))))) + (equal + attr + (tramp-get-file-property + v localname "visited-file-modtime-ild" ""))) + ;; If file does not exist, say it is not modified if and + ;; only if that agrees with the buffer's record. + (t (equal mt '(-1 65535)))))))))) + +(defun tramp-sh-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) + ;; FIXME: extract the proper text from chmod's stderr. + (tramp-barf-unless-okay + v + (format "chmod %s %s" + (tramp-compat-decimal-to-octal mode) + (tramp-shell-quote-argument localname)) + "Error while changing file's mode %s" filename))) + +(defun tramp-sh-handle-set-file-times (filename &optional time) + "Like `set-file-times' for Tramp files." + (if (file-remote-p filename) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v localname) + (let ((time (if (or (null time) (equal time '(0 0))) + (current-time) + time)) + ;; With GNU Emacs, `format-time-string' has an optional + ;; parameter UNIVERSAL. This is preferred, because we + ;; could handle the case when the remote host is located + ;; in a different time zone as the local host. + (utc (not (featurep 'xemacs)))) + (tramp-send-command-and-check + v (format "%s touch -t %s %s" + (if utc "TZ=UTC; export TZ;" "") + (if utc + (format-time-string "%Y%m%d%H%M.%S" time t) + (format-time-string "%Y%m%d%H%M.%S" time)) + (tramp-shell-quote-argument localname))))) + + ;; We handle also the local part, because in older Emacsen, + ;; without `set-file-times', this function is an alias for this. + ;; We are local, so we don't need the UTC settings. + (zerop + (tramp-compat-call-process + "touch" nil nil nil "-t" + (format-time-string "%Y%m%d%H%M.%S" time) + (tramp-shell-quote-argument filename))))) + +(defun tramp-set-file-uid-gid (filename &optional uid gid) + "Set the ownership for FILENAME. +If UID and GID are provided, these values are used; otherwise uid +and gid of the corresponding user is taken. Both parameters must be integers." + ;; Modern Unices allow chown only for root. So we might need + ;; another implementation, see `dired-do-chown'. OTOH, it is mostly + ;; working with su(do)? when it is needed, so it shall succeed in + ;; the majority of cases. + ;; Don't modify `last-coding-system-used' by accident. + (let ((last-coding-system-used last-coding-system-used)) + (if (file-remote-p filename) + (with-parsed-tramp-file-name filename nil + (if (and (zerop (user-uid)) (tramp-local-host-p v)) + ;; If we are root on the local host, we can do it directly. + (tramp-set-file-uid-gid localname uid gid) + (let ((uid (or (and (integerp uid) uid) + (tramp-get-remote-uid v 'integer))) + (gid (or (and (integerp gid) gid) + (tramp-get-remote-gid v 'integer)))) + (tramp-send-command + v (format + "chown %d:%d %s" uid gid + (tramp-shell-quote-argument localname)))))) + + ;; We handle also the local part, because there doesn't exist + ;; `set-file-uid-gid'. On W32 "chown" might not work. + (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-compat-call-process + "chown" nil nil nil + (format "%d:%d" uid gid) (tramp-shell-quote-argument filename)))))) + +(defun tramp-remote-selinux-p (vec) + "Check, whether SELINUX is enabled on the remote host." + (with-connection-property (tramp-get-connection-process vec) "selinux-p" + (let ((result (tramp-find-executable + vec "getenforce" (tramp-get-remote-path vec) t t))) + (and result + (string-equal + (tramp-send-command-and-read + vec (format "echo \\\"`%S`\\\"" result)) + "Enforcing"))))) + +(defun tramp-sh-handle-file-selinux-context (filename) + "Like `file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-selinux-context" + (let ((context '(nil nil nil nil)) + (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" + "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) + (when (and (tramp-remote-selinux-p v) + (tramp-send-command-and-check + v (format + "%s -d -Z %s" + (tramp-get-ls-command v) + (tramp-shell-quote-argument localname)))) + (with-current-buffer (tramp-get-connection-buffer v) + (goto-char (point-min)) + (when (re-search-forward regexp (point-at-eol) t) + (setq context (list (match-string 1) (match-string 2) + (match-string 3) (match-string 4)))))) + ;; Return the context. + context)))) + +(defun tramp-sh-handle-set-file-selinux-context (filename context) + "Like `set-file-selinux-context' for Tramp files." + (with-parsed-tramp-file-name filename nil + (if (and (consp context) + (tramp-remote-selinux-p v) + (tramp-send-command-and-check + v (format "chcon %s %s %s %s %s" + (if (stringp (nth 0 context)) + (format "--user=%s" (nth 0 context)) "") + (if (stringp (nth 1 context)) + (format "--role=%s" (nth 1 context)) "") + (if (stringp (nth 2 context)) + (format "--type=%s" (nth 2 context)) "") + (if (stringp (nth 3 context)) + (format "--range=%s" (nth 3 context)) "") + (tramp-shell-quote-argument localname)))) + (tramp-set-file-property v localname "file-selinux-context" context) + (tramp-set-file-property v localname "file-selinux-context" 'undef))) + ;; We always return nil. + nil) + +;; Simple functions using the `test' command. + +(defun tramp-sh-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-executable-p" + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (or (tramp-check-cached-permissions v ?x) + (tramp-run-test "-x" filename))))) + +(defun tramp-sh-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-readable-p" + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (or (tramp-check-cached-permissions v ?r) + (tramp-run-test "-r" filename))))) + +;; When the remote shell is started, it looks for a shell which groks +;; tilde expansion. Here, we assume that all shells which grok tilde +;; expansion will also provide a `test' command which groks `-nt' (for +;; newer than). If this breaks, tell me about it and I'll try to do +;; something smarter about it. +(defun tramp-sh-handle-file-newer-than-file-p (file1 file2) + "Like `file-newer-than-file-p' for Tramp files." + (cond ((not (file-exists-p file1)) + nil) + ((not (file-exists-p file2)) + t) + ;; We are sure both files exist at this point. + (t + (save-excursion + ;; We try to get the mtime of both files. If they are not + ;; equal to the "dont-know" value, then we subtract the times + ;; and obtain the result. + (let ((fa1 (file-attributes file1)) + (fa2 (file-attributes file2))) + (if (and (not (equal (nth 5 fa1) '(0 0))) + (not (equal (nth 5 fa2) '(0 0)))) + (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1))) + ;; If one of them is the dont-know value, then we can + ;; still try to run a shell command on the remote host. + ;; However, this only works if both files are Tramp + ;; files and both have the same method, same user, same + ;; host. + (unless (tramp-equal-remote file1 file2) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p file1) file1 file2) nil + (tramp-error + v 'file-error + "Files %s and %s must have same method, user, host" + file1 file2))) + (with-parsed-tramp-file-name file1 nil + (tramp-run-test2 + (tramp-get-test-nt-command v) file1 file2)))))))) + +;; Functions implemented using the basic functions above. + +(defun tramp-sh-handle-file-directory-p (filename) + "Like `file-directory-p' for Tramp files." + ;; Care must be taken that this function returns `t' for symlinks + ;; pointing to directories. Surely the most obvious implementation + ;; would be `test -d', but that returns false for such symlinks. + ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And + ;; I now think he's right. So we could be using `test -d', couldn't + ;; we? + ;; + ;; Alternatives: `cd %s', `test -d %s' + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-directory-p" + (tramp-run-test "-d" filename)))) + +(defun tramp-sh-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-writable-p" + (if (file-exists-p filename) + ;; Examine `file-attributes' cache to see if request can be + ;; satisfied without remote operation. + (or (tramp-check-cached-permissions v ?w) + (tramp-run-test "-w" filename)) + ;; If file doesn't exist, check if directory is writable. + (and (tramp-run-test "-d" (file-name-directory filename)) + (tramp-run-test "-w" (file-name-directory filename))))))) + +(defun tramp-sh-handle-file-ownership-preserved-p (filename) + "Like `file-ownership-preserved-p' for Tramp files." + (with-parsed-tramp-file-name filename nil + (with-file-property v localname "file-ownership-preserved-p" + (let ((attributes (file-attributes filename))) + ;; Return t if the file doesn't exist, since it's true that no + ;; information would be lost by an (attempted) delete and create. + (or (null attributes) + (= (nth 2 attributes) (tramp-get-remote-uid v 'integer))))))) + +;; Directory listings. + +(defun tramp-sh-handle-directory-files-and-attributes + (directory &optional full match nosort id-format) + "Like `directory-files-and-attributes' for Tramp files." + (unless id-format (setq id-format 'integer)) + (when (file-directory-p directory) + (setq directory (expand-file-name directory)) + (let* ((temp + (copy-tree + (with-parsed-tramp-file-name directory nil + (with-file-property + v localname + (format "directory-files-and-attributes-%s" id-format) + (save-excursion + (mapcar + (lambda (x) + (cons (car x) + (tramp-convert-file-attributes v (cdr x)))) + (cond + ((tramp-get-remote-stat v) + (tramp-do-directory-files-and-attributes-with-stat + v localname id-format)) + ((tramp-get-remote-perl v) + (tramp-do-directory-files-and-attributes-with-perl + v localname id-format))))))))) + result item) + + (while temp + (setq item (pop temp)) + (when (or (null match) (string-match match (car item))) + (when full + (setcar item (expand-file-name (car item) directory))) + (push item result))) + + (if nosort + result + (sort result (lambda (x y) (string< (car x) (car y)))))))) + +(defun tramp-do-directory-files-and-attributes-with-perl + (vec localname &optional id-format) + "Implement `directory-files-and-attributes' for Tramp files using a Perl script." + (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname) + (tramp-maybe-send-script + vec tramp-perl-directory-files-and-attributes + "tramp_perl_directory_files_and_attributes") + (let ((object + (tramp-send-command-and-read + vec + (format "tramp_perl_directory_files_and_attributes %s %s" + (tramp-shell-quote-argument localname) id-format)))) + (when (stringp object) (tramp-error vec 'file-error object)) + object)) + +(defun tramp-do-directory-files-and-attributes-with-stat + (vec localname &optional id-format) + "Implement `directory-files-and-attributes' for Tramp files using stat(1) command." + (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) + (tramp-send-command-and-read + vec + (format + (concat + ;; We must care about filenames with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we + ;; quote the filenames via sed. + "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs " + "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)'); " + "echo \")\"") + (tramp-shell-quote-argument localname) + (tramp-get-ls-command vec) + (tramp-get-remote-stat vec) + (if (eq id-format 'integer) "%u" "\"%U\"") + (if (eq id-format 'integer) "%g" "\"%G\"")))) + +;; This function should return "foo/" for directories and "bar" for +;; files. +(defun tramp-sh-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (unless (save-match-data (string-match "/" filename)) + (with-parsed-tramp-file-name (expand-file-name directory) nil + + (all-completions + filename + (mapcar + 'list + (or + ;; Try cache entries for filename, filename with last + ;; character removed, filename with last two characters + ;; removed, ..., and finally the empty string - all + ;; concatenated to the local directory name. + (let ((remote-file-name-inhibit-cache + (or remote-file-name-inhibit-cache + tramp-completion-reread-directory-timeout))) + + ;; This is inefficient for very long filenames, pity + ;; `reduce' is not available... + (car + (apply + 'append + (mapcar + (lambda (x) + (let ((cache-hit + (tramp-get-file-property + v + (concat localname (substring filename 0 x)) + "file-name-all-completions" + nil))) + (when cache-hit (list cache-hit)))) + (tramp-compat-number-sequence (length filename) 0 -1))))) + + ;; Cache expired or no matching cache entry found so we need + ;; to perform a remote operation. + (let (result) + ;; Get a list of directories and files, including reliably + ;; tagging the directories with a trailing '/'. Because I + ;; rock. --daniel@danann.net + + ;; Changed to perform `cd' in the same remote op and only + ;; get entries starting with `filename'. Capture any `cd' + ;; error messages. Ensure any `cd' and `echo' aliases are + ;; ignored. + (tramp-send-command + v + (if (tramp-get-remote-perl v) + (progn + (tramp-maybe-send-script + v tramp-perl-file-name-all-completions + "tramp_perl_file_name_all_completions") + (format "tramp_perl_file_name_all_completions %s %s %d" + (tramp-shell-quote-argument localname) + (tramp-shell-quote-argument filename) + (if (symbol-value + ;; `read-file-name-completion-ignore-case' + ;; is introduced with Emacs 22.1. + (if (boundp + 'read-file-name-completion-ignore-case) + 'read-file-name-completion-ignore-case + 'completion-ignore-case)) + 1 0))) + + (format (concat + "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null" + ;; `ls' with wildcard might fail with `Argument + ;; list too long' error in some corner cases; if + ;; `ls' fails after `cd' succeeded, chances are + ;; that's the case, so let's retry without + ;; wildcard. This will return "too many" entries + ;; but that isn't harmful. + " || %s -a 2>/dev/null)" + " | while read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail") + (tramp-shell-quote-argument localname) + (tramp-get-ls-command v) + ;; When `filename' is empty, just `ls' without + ;; filename argument is more efficient than `ls *' + ;; for very large directories and might avoid the + ;; `Argument list too long' error. + ;; + ;; With and only with wildcard, we need to add + ;; `-d' to prevent `ls' from descending into + ;; sub-directories. + (if (zerop (length filename)) + "." + (concat (tramp-shell-quote-argument filename) "* -d")) + (tramp-get-ls-command v) + (tramp-get-test-command v)))) + + ;; Now grab the output. + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-max)) + + ;; Check result code, found in last line of output + (forward-line -1) + (if (looking-at "^fail$") + (progn + ;; Grab error message from line before last line + ;; (it was put there by `cd 2>&1') + (forward-line -1) + (tramp-error + v 'file-error + "tramp-sh-handle-file-name-all-completions: %s" + (buffer-substring (point) (point-at-eol)))) + ;; For peace of mind, if buffer doesn't end in `fail' + ;; then it should end in `ok'. If neither are in the + ;; buffer something went seriously wrong on the remote + ;; side. + (unless (looking-at "^ok$") + (tramp-error + v 'file-error + "\ +tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" + (tramp-shell-quote-argument localname) (buffer-string)))) + + (while (zerop (forward-line -1)) + (push (buffer-substring (point) (point-at-eol)) result))) + + ;; Because the remote op went through OK we know the + ;; directory we `cd'-ed to exists + (tramp-set-file-property + v localname "file-exists-p" t) + + ;; Because the remote op went through OK we know every + ;; file listed by `ls' exists. + (mapc (lambda (entry) + (tramp-set-file-property + v (concat localname entry) "file-exists-p" t)) + result) + + ;; Store result in the cache + (tramp-set-file-property + v (concat localname filename) + "file-name-all-completions" + result)))))))) + +;; cp, mv and ln + +(defun tramp-sh-handle-add-name-to-file + (filename newname &optional ok-if-already-exists) + "Like `add-name-to-file' for Tramp files." + (unless (tramp-equal-remote filename newname) + (with-parsed-tramp-file-name + (if (tramp-tramp-file-p filename) filename newname) nil + (tramp-error + v 'file-error + "add-name-to-file: %s" + "only implemented for same method, same user, same host"))) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + (let ((ln (when v1 (tramp-get-remote-ln v1)))) + (when (and (not ok-if-already-exists) + (file-exists-p newname) + (not (numberp ok-if-already-exists)) + (y-or-n-p + (format + "File %s already exists; make it a new name anyway? " + newname))) + (tramp-error + v2 'file-error + "add-name-to-file: file %s already exists" newname)) + (tramp-flush-file-property v2 (file-name-directory v2-localname)) + (tramp-flush-file-property v2 v2-localname) + (tramp-barf-unless-okay + v1 + (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname) + (tramp-shell-quote-argument v2-localname)) + "error with add-name-to-file, see buffer `%s' for details" + (buffer-name)))))) + +(defun tramp-sh-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + (cond + ;; At least one file a Tramp file? + ((or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context)) + ;; Compat section. + (preserve-selinux-context + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context))) + (preserve-uid-gid + (tramp-run-real-handler + 'copy-file + (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) + (t + (tramp-run-real-handler + 'copy-file (list filename newname ok-if-already-exists keep-date))))) + +(defun tramp-sh-handle-copy-directory + (dirname newname &optional keep-date parents) + "Like `copy-directory' for Tramp files." + (let ((t1 (tramp-tramp-file-p dirname)) + (t2 (tramp-tramp-file-p newname))) + (with-parsed-tramp-file-name (if t1 dirname newname) nil + (if (and (tramp-get-method-parameter method 'tramp-copy-recursive) + ;; When DIRNAME and NEWNAME are remote, they must have + ;; the same method. + (or (null t1) (null t2) + (string-equal + (tramp-file-name-method (tramp-dissect-file-name dirname)) + (tramp-file-name-method (tramp-dissect-file-name newname))))) + ;; scp or rsync DTRT. + (progn + (setq dirname (directory-file-name (expand-file-name dirname)) + newname (directory-file-name (expand-file-name newname))) + (if (and (file-directory-p newname) + (not (string-equal (file-name-nondirectory dirname) + (file-name-nondirectory newname)))) + (setq newname + (expand-file-name + (file-name-nondirectory dirname) newname))) + (if (not (file-directory-p (file-name-directory newname))) + (make-directory (file-name-directory newname) parents)) + (tramp-do-copy-or-rename-file-out-of-band + 'copy dirname newname keep-date)) + ;; We must do it file-wise. + (tramp-run-real-handler + 'copy-directory (list dirname newname keep-date parents))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname)))))) + +(defun tramp-sh-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + ;; Check if both files are local -- invoke normal rename-file. + ;; Otherwise, use Tramp from local system. + (setq filename (expand-file-name filename)) + (setq newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists t t) + (tramp-run-real-handler + 'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-selinux-context) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-SELINUX-CONTEXT activates selinux commands. + +This function is invoked by `tramp-sh-handle-copy-file' and +`tramp-sh-handle-rename-file'. It is an error if OP is neither +of `copy' and `rename'. FILENAME and NEWNAME must be absolute +file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (context (and preserve-selinux-context + (apply 'file-selinux-context (list filename)))) + pr tm) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error + v 'file-already-exists "File %s already exists" newname)) + + (with-progress-reporter + v 0 (format "%s %s to %s" + (if (eq op 'copy) "Copying" "Renaming") + filename newname) + + (cond + ;; Both are Tramp files. + ((and t1 t2) + (with-parsed-tramp-file-name filename v1 + (with-parsed-tramp-file-name newname v2 + (cond + ;; Shortcut: if method, host, user are the same for + ;; both files, we invoke `cp' or `mv' on the remote + ;; host directly. + ((tramp-equal-remote filename newname) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; Try out-of-band operation. + ((tramp-method-out-of-band-p + v1 (nth 7 (file-attributes (file-truename filename)))) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname keep-date)) + + ;; No shortcut was possible. So we copy the file + ;; first. If the operation was `rename', we go back + ;; and delete the original file (if the copy was + ;; successful). The approach is simple-minded: we + ;; create a new buffer, insert the contents of the + ;; source file into it, then write out the buffer to + ;; the target file. The advantage is that it doesn't + ;; matter which filename handlers are used for the + ;; source and target file. + (t + (tramp-do-copy-or-rename-file-via-buffer + op filename newname keep-date)))))) + + ;; One file is a Tramp file, the other one is local. + ((or t1 t2) + (cond + ;; Fast track on local machine. + ((tramp-local-host-p v) + (tramp-do-copy-or-rename-file-directly + op filename newname + ok-if-already-exists keep-date preserve-uid-gid)) + + ;; If the Tramp file has an out-of-band method, the + ;; corresponding copy-program can be invoked. + ((tramp-method-out-of-band-p + v (nth 7 (file-attributes (file-truename filename)))) + (tramp-do-copy-or-rename-file-out-of-band + op filename newname keep-date)) + + ;; Use the inline method via a Tramp buffer. + (t (tramp-do-copy-or-rename-file-via-buffer + op filename newname keep-date)))) + + (t + ;; One of them must be a Tramp file. + (error "Tramp implementation says this cannot happen"))) + + ;; Handle `preserve-selinux-context'. + (when context (apply 'set-file-selinux-context (list newname context))) + + ;; In case of `rename', we must flush the cache of the source file. + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-property v1 (file-name-directory localname)) + (tramp-flush-file-property v1 localname))) + + ;; When newname did exist, we have wrong cached values. + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-property v2 (file-name-directory localname)) + (tramp-flush-file-property v2 localname))))))) + +(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) + "Use an Emacs buffer to copy or rename a file. +First arg OP is either `copy' or `rename' and indicates the operation. +FILENAME is the source file, NEWNAME the target file. +KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." + (with-temp-buffer + ;; We must disable multibyte, because binary data shall not be + ;; converted. + (set-buffer-multibyte nil) + (let ((coding-system-for-read 'binary) + (jka-compr-inhibit t)) + (insert-file-contents-literally filename)) + ;; We don't want the target file to be compressed, so we let-bind + ;; `jka-compr-inhibit' to t. + (let ((coding-system-for-write 'binary) + (jka-compr-inhibit t)) + (write-region (point-min) (point-max) newname))) + ;; KEEP-DATE handling. + (when keep-date (set-file-times newname (nth 5 (file-attributes filename)))) + ;; Set the mode. + (set-file-modes newname (tramp-default-file-modes filename)) + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) (delete-file filename))) + +(defun tramp-do-copy-or-rename-file-directly + (op filename newname ok-if-already-exists keep-date preserve-uid-gid) + "Invokes `cp' or `mv' on the remote system. +OP must be one of `copy' or `rename', indicating `cp' or `mv', +respectively. FILENAME specifies the file to copy or rename, +NEWNAME is the name of the new file (for copy) or the new name of +the file (for rename). Both files must reside on the same host. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid from FILENAME." + (let ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (file-times (nth 5 (file-attributes filename))) + (file-modes (tramp-default-file-modes filename))) + (with-parsed-tramp-file-name (if t1 filename newname) nil + (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p") + ((eq op 'copy) "cp -f") + ((eq op 'rename) "mv -f") + (t (tramp-error + v 'file-error + "Unknown operation `%s', must be `copy' or `rename'" + op)))) + (localname1 + (if t1 + (tramp-file-name-handler 'file-remote-p filename 'localname) + filename)) + (localname2 + (if t2 + (tramp-file-name-handler 'file-remote-p newname 'localname) + newname)) + (prefix (file-remote-p (if t1 filename newname))) + cmd-result) + + (cond + ;; Both files are on a remote host, with same user. + ((and t1 t2) + (setq cmd-result + (tramp-send-command-and-check + v (format "%s %s %s" cmd + (tramp-shell-quote-argument localname1) + (tramp-shell-quote-argument localname2)))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (unless + (or + (and keep-date + ;; Mask cp -f error. + (re-search-forward + tramp-operation-not-permitted-regexp nil t)) + cmd-result) + (tramp-error-with-buffer + nil v 'file-error + "Copying directly failed, see buffer `%s' for details." + (buffer-name))))) + + ;; We are on the local host. + ((or t1 t2) + (cond + ;; We can do it directly. + ((let (file-name-handler-alist) + (and (file-readable-p localname1) + (file-writable-p (file-name-directory localname2)) + (or (file-directory-p localname2) + (file-writable-p localname2)))) + (if (eq op 'copy) + (tramp-compat-copy-file + localname1 localname2 ok-if-already-exists + keep-date preserve-uid-gid) + (tramp-run-real-handler + 'rename-file (list localname1 localname2 ok-if-already-exists)))) + + ;; We can do it directly with `tramp-send-command' + ((and (file-readable-p (concat prefix localname1)) + (file-writable-p + (file-name-directory (concat prefix localname2))) + (or (file-directory-p (concat prefix localname2)) + (file-writable-p (concat prefix localname2)))) + (tramp-do-copy-or-rename-file-directly + op (concat prefix localname1) (concat prefix localname2) + ok-if-already-exists keep-date t) + ;; We must change the ownership to the local user. + (tramp-set-file-uid-gid + (concat prefix localname2) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + + ;; We need a temporary file in between. + (t + ;; Create the temporary file. + (let ((tmpfile (tramp-compat-make-temp-file localname1))) + (unwind-protect + (progn + (cond + (t1 + (tramp-barf-unless-okay + v (format + "%s %s %s" cmd + (tramp-shell-quote-argument localname1) + (tramp-shell-quote-argument tmpfile)) + "Copying directly failed, see buffer `%s' for details." + (tramp-get-buffer v)) + ;; We must change the ownership as remote user. + ;; Since this does not work reliable, we also + ;; give read permissions. + (set-file-modes + (concat prefix tmpfile) + (tramp-compat-octal-to-decimal "0777")) + (tramp-set-file-uid-gid + (concat prefix tmpfile) + (tramp-get-local-uid 'integer) + (tramp-get-local-gid 'integer))) + (t2 + (if (eq op 'copy) + (tramp-compat-copy-file + localname1 tmpfile t + keep-date preserve-uid-gid) + (tramp-run-real-handler + 'rename-file + (list localname1 tmpfile t))) + ;; We must change the ownership as local user. + ;; Since this does not work reliable, we also + ;; give read permissions. + (set-file-modes + tmpfile (tramp-compat-octal-to-decimal "0777")) + (tramp-set-file-uid-gid + tmpfile + (tramp-get-remote-uid v 'integer) + (tramp-get-remote-gid v 'integer)))) + + ;; Move the temporary file to its destination. + (cond + (t2 + (tramp-barf-unless-okay + v (format + "cp -f -p %s %s" + (tramp-shell-quote-argument tmpfile) + (tramp-shell-quote-argument localname2)) + "Copying directly failed, see buffer `%s' for details." + (tramp-get-buffer v))) + (t1 + (tramp-run-real-handler + 'rename-file + (list tmpfile localname2 ok-if-already-exists))))) + + ;; Save exit. + (ignore-errors (delete-file tmpfile))))))))) + + ;; Set the time and mode. Mask possible errors. + (ignore-errors + (when keep-date + (set-file-times newname file-times) + (set-file-modes newname file-modes)))))) + +(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) + "Invoke rcp program to copy. +The method used must be an out-of-band method." + (let* ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (orig-vec (tramp-dissect-file-name (if t1 filename newname))) + copy-program copy-args copy-env copy-keep-date port spec + source target) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (if (and t1 t2) + + ;; Both are Tramp files. We shall optimize it, when the + ;; methods for filename and newname are the same. + (let* ((dir-flag (file-directory-p filename)) + (tmpfile (tramp-compat-make-temp-file localname dir-flag))) + (if dir-flag + (setq tmpfile + (expand-file-name + (file-name-nondirectory newname) tmpfile))) + (unwind-protect + (progn + (tramp-do-copy-or-rename-file-out-of-band + op filename tmpfile keep-date) + (tramp-do-copy-or-rename-file-out-of-band + 'rename tmpfile newname keep-date)) + ;; Save exit. + (ignore-errors + (if dir-flag + (tramp-compat-delete-directory + (expand-file-name ".." tmpfile) 'recursive) + (delete-file tmpfile))))) + + ;; Set variables for computing the prompt for reading + ;; password. + (setq tramp-current-method (tramp-file-name-method v) + tramp-current-user (tramp-file-name-user v) + tramp-current-host (tramp-file-name-host v)) + + ;; Expand hops. Might be necessary for gateway methods. + (setq v (car (tramp-compute-multi-hops v))) + (aset v 3 localname) + + ;; Check which ones of source and target are Tramp files. + (setq source (if t1 (tramp-make-copy-program-file-name v) filename) + target (funcall + (if (and (file-directory-p filename) + (string-equal + (file-name-nondirectory filename) + (file-name-nondirectory newname))) + 'file-name-directory + 'identity) + (if t2 (tramp-make-copy-program-file-name v) newname))) + + ;; Check for port number. Until now, there's no need for handling + ;; like method, user, host. + (setq host (tramp-file-name-real-host v) + port (tramp-file-name-port v) + port (or (and port (number-to-string port)) "")) + + ;; Compose copy command. + (setq spec (format-spec-make + ?h host ?u user ?p port + ?t (tramp-get-connection-property + (tramp-get-connection-process v) "temp-file" "") + ?k (if keep-date " " "")) + copy-program (tramp-get-method-parameter + method 'tramp-copy-program) + copy-keep-date (tramp-get-method-parameter + method 'tramp-copy-keep-date) + copy-args + (delete + ;; " " has either been a replacement of "%k" (when + ;; keep-date argument is non-nil), or a replacemtent + ;; for the whole keep-date sublist. + " " + (dolist + (x + (tramp-get-method-parameter method 'tramp-copy-args) + copy-args) + (setq copy-args + (append + copy-args + (let ((y (mapcar (lambda (z) (format-spec z spec)) x))) + (if (zerop (length (car y))) '(" ") y)))))) + copy-env + (delq + nil + (mapcar + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) (mapconcat 'identity x " "))) + (tramp-get-method-parameter method 'tramp-copy-env)))) + + ;; Check for program. + (when (and (fboundp 'executable-find) + (not (let ((default-directory + (tramp-compat-temporary-file-directory))) + (executable-find copy-program)))) + (tramp-error + v 'file-error "Cannot find copy program: %s" copy-program)) + + (with-temp-buffer + (unwind-protect + ;; The default directory must be remote. + (let ((default-directory + (file-name-directory (if t1 filename newname))) + (process-environment (copy-sequence process-environment))) + ;; Set the transfer process properties. + (tramp-set-connection-property + v "process-name" (buffer-name (current-buffer))) + (tramp-set-connection-property + v "process-buffer" (current-buffer)) + (while copy-env + (tramp-message + orig-vec 5 "%s=\"%s\"" (car copy-env) (cadr copy-env)) + (setenv (pop copy-env) (pop copy-env))) + + ;; Use an asynchronous process. By this, password can + ;; be handled. The default directory must be local, in + ;; order to apply the correct `copy-program'. We don't + ;; set a timeout, because the copying of large files can + ;; last longer than 60 secs. + (let ((p (let ((default-directory + (tramp-compat-temporary-file-directory))) + (apply 'start-process + (tramp-get-connection-name v) + (tramp-get-connection-buffer v) + copy-program + (append copy-args (list source target)))))) + (tramp-message + orig-vec 6 "%s" + (mapconcat 'identity (process-command p) " ")) + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-process-actions p v tramp-actions-copy-out-of-band))) + + ;; Reset the transfer process properties. + (tramp-message orig-vec 6 "%s" (buffer-string)) + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil))) + + ;; Handle KEEP-DATE argument. + (when (and keep-date (not copy-keep-date)) + (set-file-times newname (nth 5 (file-attributes filename)))) + + ;; Set the mode. + (unless (and keep-date copy-keep-date) + (ignore-errors + (set-file-modes newname (tramp-default-file-modes filename))))) + + ;; If the operation was `rename', delete the original file. + (unless (eq op 'copy) + (if (file-regular-p filename) + (delete-file filename) + (tramp-compat-delete-directory filename 'recursive)))))) + +(defun tramp-sh-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (setq dir (expand-file-name dir)) + (with-parsed-tramp-file-name dir nil + (tramp-flush-directory-property v (file-name-directory localname)) + (save-excursion + (tramp-barf-unless-okay + v (format "%s %s" + (if parents "mkdir -p" "mkdir") + (tramp-shell-quote-argument localname)) + "Couldn't make directory %s" dir)))) + +(defun tramp-sh-handle-delete-directory (directory &optional recursive) + "Like `delete-directory' for Tramp files." + (setq directory (expand-file-name directory)) + (with-parsed-tramp-file-name directory nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-directory-property v localname) + (tramp-barf-unless-okay + v (format "%s %s" + (if recursive "rm -rf" "rmdir") + (tramp-shell-quote-argument localname)) + "Couldn't delete %s" directory))) + +(defun tramp-sh-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + (tramp-barf-unless-okay + v (format "%s %s" + (or (and trash (tramp-get-remote-trash v)) "rm -f") + (tramp-shell-quote-argument localname)) + "Couldn't delete %s" filename))) + +;; Dired. + +;; CCC: This does not seem to be enough. Something dies when +;; we try and delete two directories under Tramp :/ +(defun tramp-sh-handle-dired-recursive-delete-directory (filename) + "Recursively delete the directory given. +This is like `dired-recursive-delete-directory' for Tramp files." + (with-parsed-tramp-file-name filename nil + ;; Run a shell command 'rm -r <localname>' + ;; Code shamelessly stolen from the dired implementation and, um, hacked :) + (unless (file-exists-p filename) + (tramp-error v 'file-error "No such directory: %s" filename)) + ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>) + (tramp-send-command + v + (format "rm -rf %s" (tramp-shell-quote-argument localname)) + ;; Don't read the output, do it explicitely. + nil t) + ;; Wait for the remote system to return to us... + ;; This might take a while, allow it plenty of time. + (tramp-wait-for-output (tramp-get-connection-process v) 120) + ;; Make sure that it worked... + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-directory-property v localname) + (and (file-exists-p filename) + (tramp-error + v 'file-error "Failed to recursively delete %s" filename)))) + +(defun tramp-sh-handle-dired-compress-file (file &rest ok-flag) + "Like `dired-compress-file' for Tramp files." + ;; OK-FLAG is valid for XEmacs only, but not implemented. + ;; Code stolen mainly from dired-aux.el. + (with-parsed-tramp-file-name file nil + (tramp-flush-file-property v localname) + (save-excursion + (let ((suffixes + (if (not (featurep 'xemacs)) + ;; Emacs case + (symbol-value 'dired-compress-file-suffixes) + ;; XEmacs has `dired-compression-method-alist', which is + ;; transformed into `dired-compress-file-suffixes' structure. + (mapcar + (lambda (x) + (list (concat (regexp-quote (nth 1 x)) "\\'") + nil + (mapconcat 'identity (nth 3 x) " "))) + (symbol-value 'dired-compression-method-alist)))) + suffix) + ;; See if any suffix rule matches this file name. + (while suffixes + (let (case-fold-search) + (if (string-match (car (car suffixes)) localname) + (setq suffix (car suffixes) suffixes nil)) + (setq suffixes (cdr suffixes)))) + + (cond ((file-symlink-p file) + nil) + ((and suffix (nth 2 suffix)) + ;; We found an uncompression rule. + (with-progress-reporter v 0 (format "Uncompressing %s" file) + (when (tramp-send-command-and-check + v (concat (nth 2 suffix) " " + (tramp-shell-quote-argument localname))) + ;; `dired-remove-file' is not defined in XEmacs. + (tramp-compat-funcall 'dired-remove-file file) + (string-match (car suffix) file) + (concat (substring file 0 (match-beginning 0)))))) + (t + ;; We don't recognize the file as compressed, so compress it. + ;; Try gzip. + (with-progress-reporter v 0 (format "Compressing %s" file) + (when (tramp-send-command-and-check + v (concat "gzip -f " + (tramp-shell-quote-argument localname))) + ;; `dired-remove-file' is not defined in XEmacs. + (tramp-compat-funcall 'dired-remove-file file) + (cond ((file-exists-p (concat file ".gz")) + (concat file ".gz")) + ((file-exists-p (concat file ".z")) + (concat file ".z")) + (t nil)))))))))) + +(defun tramp-sh-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + (if (and (featurep 'ls-lisp) + (not (symbol-value 'ls-lisp-use-insert-directory-program))) + (tramp-run-real-handler + 'insert-directory (list filename switches wildcard full-directory-p)) + (when (stringp switches) + (setq switches (split-string switches))) + (when (and (member "--dired" switches) + (not (tramp-get-ls-command-with-dired v))) + (setq switches (delete "--dired" switches))) + (when wildcard + (setq wildcard (tramp-run-real-handler + 'file-name-nondirectory (list localname))) + (setq localname (tramp-run-real-handler + 'file-name-directory (list localname)))) + (unless full-directory-p + (setq switches (add-to-list 'switches "-d" 'append))) + (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) + (when wildcard + (setq switches (concat switches " " wildcard))) + (tramp-message + v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s" + switches filename (if wildcard "yes" "no") + (if full-directory-p "yes" "no")) + ;; If `full-directory-p', we just say `ls -l FILENAME'. + ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'. + (if full-directory-p + (tramp-send-command + v + (format "%s %s %s 2>/dev/null" + (tramp-get-ls-command v) + switches + (if wildcard + localname + (tramp-shell-quote-argument (concat localname "."))))) + (tramp-barf-unless-okay + v + (format "cd %s" (tramp-shell-quote-argument + (tramp-run-real-handler + 'file-name-directory (list localname)))) + "Couldn't `cd %s'" + (tramp-shell-quote-argument + (tramp-run-real-handler 'file-name-directory (list localname)))) + (tramp-send-command + v + (format "%s %s %s" + (tramp-get-ls-command v) + switches + (if (or wildcard + (zerop (length + (tramp-run-real-handler + 'file-name-nondirectory (list localname))))) + "" + (tramp-shell-quote-argument + (tramp-run-real-handler + 'file-name-nondirectory (list localname))))))) + (let ((beg (point))) + ;; We cannot use `insert-buffer-substring' because the Tramp + ;; buffer changes its contents before insertion due to calling + ;; `expand-file' and alike. + (insert + (with-current-buffer (tramp-get-buffer v) + (buffer-string))) + + ;; Check for "--dired" output. + (forward-line -2) + (when (looking-at "//SUBDIRED//") + (forward-line -1)) + (when (looking-at "//DIRED//\\s-+") + (let ((databeg (match-end 0)) + (end (point-at-eol))) + ;; Now read the numeric positions of file names. + (goto-char databeg) + (while (< (point) end) + (let ((start (+ beg (read (current-buffer)))) + (end (+ beg (read (current-buffer))))) + (if (memq (char-after end) '(?\n ?\ )) + ;; End is followed by \n or by " -> ". + (put-text-property start end 'dired-filename t)))))) + ;; Remove trailing lines. + (goto-char (point-at-bol)) + (while (looking-at "//") + (forward-line 1) + (delete-region (match-beginning 0) (point))) + + ;; The inserted file could be from somewhere else. + (when (and (not wildcard) (not full-directory-p)) + (goto-char (point-max)) + (when (file-symlink-p filename) + (goto-char (search-backward "->" beg 'noerror))) + (search-backward + (if (zerop (length (file-name-nondirectory filename))) + "." + (file-name-nondirectory filename)) + beg 'noerror) + (replace-match (file-relative-name filename) t)) + + (goto-char (point-max)))))) + +;; Canonicalization of file names. + +(defun tramp-sh-handle-expand-file-name (name &optional dir) + "Like `expand-file-name' for Tramp files. +If the localname part of the given filename starts with \"/../\" then +the result will be a local, non-Tramp, filename." + ;; 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-connectable-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. This needs a shell which + ;; groks tilde expansion! The function `tramp-find-shell' is + ;; supposed to find such a shell on the remote host. Please + ;; tell me about it when this doesn't work on your system. + (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) + (let ((uname (match-string 1 localname)) + (fname (match-string 2 localname))) + ;; We cannot simply apply "~/", because under sudo "~/" is + ;; expanded to the local user home directory but to the + ;; root home directory. On the other hand, using always + ;; the default user name for tilde expansion is not + ;; appropriate either, because ssh and companions might + ;; use a user name from the config file. + (when (and (string-equal uname "~") + (string-match "\\`su\\(do\\)?\\'" method)) + (setq uname (concat uname user))) + (setq uname + (with-connection-property v uname + (tramp-send-command + v (format "cd %s; pwd" (tramp-shell-quote-argument uname))) + (with-current-buffer (tramp-get-buffer v) + (goto-char (point-min)) + (buffer-substring (point) (point-at-eol))))) + (setq localname (concat uname fname)))) + ;; There might be a double slash, for example when "~/" + ;; expands to "/". Remove this. + (while (string-match "//" localname) + (setq localname (replace-match "/" t t localname))) + ;; No tilde characters in file name, do normal + ;; `expand-file-name' (this does "/./" and "/../"). We bind + ;; `directory-sep-char' here for XEmacs on Windows, which would + ;; otherwise use backslash. `default-directory' is bound, + ;; because on Windows there would be problems with UNC shares or + ;; Cygwin mounts. + (let ((directory-sep-char ?/) + (default-directory (tramp-compat-temporary-file-directory))) + (tramp-make-tramp-file-name + method user host + (tramp-drop-volume-letter + (tramp-run-real-handler + 'expand-file-name (list localname)))))))) + +;;; Remote commands: + +(defun tramp-sh-handle-executable-find (command) + "Like `executable-find' for Tramp files." + (with-parsed-tramp-file-name default-directory nil + (tramp-find-executable v command (tramp-get-remote-path v) t))) + +(defun tramp-process-sentinel (proc event) + "Flush file caches." + (unless (memq (process-status proc) '(run open)) + (let ((vec (tramp-get-connection-property proc "vector" nil))) + (when vec + (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event) + (tramp-flush-directory-property vec ""))))) + +;; We use BUFFER also as connection buffer during setup. Because of +;; this, its original contents must be saved, and restored once +;; connection has been setup. +(defun tramp-sh-handle-start-file-process (name buffer program &rest args) + "Like `start-file-process' for Tramp files." + (with-parsed-tramp-file-name default-directory nil + ;; When PROGRAM is nil, we just provide a tty. + (let ((command + (when (stringp program) + (format "cd %s; exec %s" + (tramp-shell-quote-argument localname) + (mapconcat 'tramp-shell-quote-argument + (cons program args) " ")))) + (tramp-process-connection-type + (or (null program) tramp-process-connection-type)) + (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) + (name1 name) + (i 0)) + (unwind-protect + (save-excursion + (save-restriction + (unless buffer + ;; BUFFER can be nil. We use a temporary buffer. + (setq buffer (generate-new-buffer tramp-temp-buffer-name))) + (while (get-process name1) + ;; NAME must be unique as process name. + (setq i (1+ i) + name1 (format "%s<%d>" name i))) + (setq name name1) + ;; Set the new process properties. + (tramp-set-connection-property v "process-name" name) + (tramp-set-connection-property v "process-buffer" buffer) + ;; Activate narrowing in order to save BUFFER contents. + ;; Clear also the modification time; otherwise we might + ;; be interrupted by `verify-visited-file-modtime'. + (with-current-buffer (tramp-get-connection-buffer v) + (let ((buffer-undo-list t)) + (clear-visited-file-modtime) + (narrow-to-region (point-max) (point-max)) + (if command + ;; Send the command. + (tramp-send-command v command nil t) ; nooutput + ;; Check, whether a pty is associated. + (tramp-maybe-open-connection v) + (unless (tramp-compat-process-get + (tramp-get-connection-process v) 'remote-tty) + (tramp-error + v 'file-error + "pty association is not supported for `%s'" name))))) + (let ((p (tramp-get-connection-process v))) + ;; Set sentinel and query flag for this process. + (tramp-set-connection-property p "vector" v) + (set-process-sentinel p 'tramp-process-sentinel) + (tramp-compat-set-process-query-on-exit-flag p t) + ;; Return process. + p))) + ;; Save exit. + (with-current-buffer (tramp-get-connection-buffer v) + (if (string-match tramp-temp-buffer-name (buffer-name)) + (progn + (set-process-buffer (tramp-get-connection-process v) nil) + (kill-buffer (current-buffer))) + (set-buffer-modified-p bmp))) + (tramp-set-connection-property v "process-name" nil) + (tramp-set-connection-property v "process-buffer" nil))))) + +(defun tramp-sh-handle-process-file + (program &optional infile destination display &rest args) + "Like `process-file' for Tramp files." + ;; The implementation is not complete yet. + (when (and (numberp destination) (zerop destination)) + (error "Implementation does not handle immediate return")) + + (with-parsed-tramp-file-name default-directory nil + (let (command input tmpinput stderr tmpstderr outbuf ret) + ;; Compute command. + (setq command (mapconcat 'tramp-shell-quote-argument + (cons program args) " ")) + ;; Determine input. + (if (null infile) + (setq input "/dev/null") + (setq infile (expand-file-name infile)) + (if (tramp-equal-remote default-directory infile) + ;; INFILE is on the same remote host. + (setq input (with-parsed-tramp-file-name infile nil localname)) + ;; INFILE must be copied to remote host. + (setq input (tramp-make-tramp-temp-file v) + tmpinput (tramp-make-tramp-file-name method user host input)) + (copy-file infile tmpinput t))) + (when input (setq command (format "%s <%s" command input))) + + ;; Determine output. + (cond + ;; Just a buffer. + ((bufferp destination) + (setq outbuf destination)) + ;; A buffer name. + ((stringp destination) + (setq outbuf (get-buffer-create destination))) + ;; (REAL-DESTINATION ERROR-DESTINATION) + ((consp destination) + ;; output. + (cond + ((bufferp (car destination)) + (setq outbuf (car destination))) + ((stringp (car destination)) + (setq outbuf (get-buffer-create (car destination)))) + ((car destination) + (setq outbuf (current-buffer)))) + ;; stderr. + (cond + ((stringp (cadr destination)) + (setcar (cdr destination) (expand-file-name (cadr destination))) + (if (tramp-equal-remote default-directory (cadr destination)) + ;; stderr is on the same remote host. + (setq stderr (with-parsed-tramp-file-name + (cadr destination) nil localname)) + ;; stderr must be copied to remote host. The temporary + ;; file must be deleted after execution. + (setq stderr (tramp-make-tramp-temp-file v) + tmpstderr (tramp-make-tramp-file-name + method user host stderr)))) + ;; stderr to be discarded. + ((null (cadr destination)) + (setq stderr "/dev/null")))) + ;; 't + (destination + (setq outbuf (current-buffer)))) + (when stderr (setq command (format "%s 2>%s" command stderr))) + + ;; Send the command. It might not return in time, so we protect + ;; it. Call it in a subshell, in order to preserve working + ;; directory. + (condition-case nil + (unwind-protect + (setq ret + (if (tramp-send-command-and-check + v (format "\\cd %s; %s" + (tramp-shell-quote-argument localname) + command) + t t) + 0 1)) + ;; We should show the output anyway. + (when outbuf + (with-current-buffer outbuf + (insert + (with-current-buffer (tramp-get-connection-buffer v) + (buffer-string)))) + (when display (display-buffer outbuf)))) + ;; When the user did interrupt, we should do it also. We use + ;; return code -1 as marker. + (quit + (kill-buffer (tramp-get-connection-buffer v)) + (setq ret -1)) + ;; Handle errors. + (error + (kill-buffer (tramp-get-connection-buffer v)) + (setq ret 1))) + + ;; Provide error file. + (when tmpstderr (rename-file tmpstderr (cadr destination) t)) + + ;; Cleanup. We remove all file cache values for the connection, + ;; because the remote process could have changed them. + (when tmpinput (delete-file tmpinput)) + + ;; `process-file-side-effects' has been introduced with GNU + ;; Emacs 23.2. If set to `nil', no remote file will be changed + ;; by `program'. If it doesn't exist, we assume its default + ;; value 't'. + (unless (and (boundp 'process-file-side-effects) + (not (symbol-value 'process-file-side-effects))) + (tramp-flush-directory-property v "")) + + ;; Return exit status. + (if (equal ret -1) + (keyboard-quit) + ret)))) + +(defun tramp-sh-handle-call-process-region + (start end program &optional delete buffer display &rest args) + "Like `call-process-region' for Tramp files." + (let ((tmpfile (tramp-compat-make-temp-file ""))) + (write-region start end tmpfile) + (when delete (delete-region start end)) + (unwind-protect + (apply 'call-process program tmpfile buffer display args) + (delete-file tmpfile)))) + +(defun tramp-sh-handle-shell-command + (command &optional output-buffer error-buffer) + "Like `shell-command' for Tramp files." + (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) + ;; We cannot use `shell-file-name' and `shell-command-switch', + ;; they are variables of the local host. + (args (list + (tramp-get-method-parameter + (tramp-file-name-method + (tramp-dissect-file-name default-directory)) + 'tramp-remote-sh) + "-c" (substring command 0 asynchronous))) + current-buffer-p + (output-buffer + (cond + ((bufferp output-buffer) output-buffer) + ((stringp output-buffer) (get-buffer-create output-buffer)) + (output-buffer + (setq current-buffer-p t) + (current-buffer)) + (t (get-buffer-create + (if asynchronous + "*Async Shell Command*" + "*Shell Command Output*"))))) + (error-buffer + (cond + ((bufferp error-buffer) error-buffer) + ((stringp error-buffer) (get-buffer-create error-buffer)))) + (buffer + (if (and (not asynchronous) error-buffer) + (with-parsed-tramp-file-name default-directory nil + (list output-buffer (tramp-make-tramp-temp-file v))) + output-buffer)) + (p (get-buffer-process output-buffer))) + + ;; Check whether there is another process running. Tramp does not + ;; support 2 (asynchronous) processes in parallel. + (when p + (if (yes-or-no-p "A command is running. Kill it? ") + (ignore-errors (kill-process p)) + (error "Shell command in progress"))) + + (if current-buffer-p + (progn + (barf-if-buffer-read-only) + (push-mark nil t)) + (with-current-buffer output-buffer + (setq buffer-read-only nil) + (erase-buffer))) + + (if (and (not current-buffer-p) (integerp asynchronous)) + (prog1 + ;; Run the process. + (apply 'start-file-process "*Async Shell*" buffer args) + ;; Display output. + (pop-to-buffer output-buffer) + (setq mode-line-process '(":%s")) + (shell-mode)) + + (prog1 + ;; Run the process. + (apply 'process-file (car args) nil buffer nil (cdr args)) + ;; Insert error messages if they were separated. + (when (listp buffer) + (with-current-buffer error-buffer + (insert-file-contents (cadr buffer))) + (delete-file (cadr buffer))) + (if current-buffer-p + ;; This is like exchange-point-and-mark, but doesn't + ;; activate the mark. It is cleaner to avoid activation, + ;; even though the command loop would deactivate the mark + ;; because we inserted text. + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; There's some output, display it. + (when (with-current-buffer output-buffer (> (point-max) (point-min))) + (if (functionp 'display-message-or-buffer) + (tramp-compat-funcall 'display-message-or-buffer output-buffer) + (pop-to-buffer output-buffer)))))))) + +(defun tramp-sh-handle-file-local-copy (filename) + "Like `file-local-copy' for Tramp files." + (with-parsed-tramp-file-name filename nil + (unless (file-exists-p filename) + (tramp-error + v 'file-error + "Cannot make local copy of non-existing file `%s'" filename)) + + (let* ((size (nth 7 (file-attributes (file-truename filename)))) + (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) + (loc-dec (tramp-get-inline-coding v "local-decoding" size)) + (tmpfile (tramp-compat-make-temp-file filename))) + + (condition-case err + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (copy-file filename tmpfile t t)) + + ;; Use inline encoding for file transfer. + (rem-enc + (save-excursion + (with-progress-reporter + v 3 (format "Encoding remote file %s" filename) + (tramp-barf-unless-okay + v (format rem-enc (tramp-shell-quote-argument localname)) + "Encoding remote file failed")) + + (if (functionp loc-dec) + ;; If local decoding is a function, we call it. We + ;; must disable multibyte, because + ;; `uudecode-decode-region' doesn't handle it + ;; correctly. + (with-temp-buffer + (set-buffer-multibyte nil) + (insert-buffer-substring (tramp-get-buffer v)) + (with-progress-reporter + v 3 (format "Decoding remote file %s with function %s" + filename loc-dec) + (funcall loc-dec (point-min) (point-max)) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (write-region (point-min) (point-max) tmpfile)))) + + ;; If tramp-decoding-function is not defined for this + ;; method, we invoke tramp-decoding-command instead. + (let ((tmpfile2 (tramp-compat-make-temp-file filename))) + ;; Unset `file-name-handler-alist'. Otherwise, + ;; epa-file gets confused. + (let (file-name-handler-alist + (coding-system-for-write 'binary)) + (write-region (point-min) (point-max) tmpfile2)) + (with-progress-reporter + v 3 (format "Decoding remote file %s with command %s" + filename loc-dec) + (unwind-protect + (tramp-call-local-coding-command + loc-dec tmpfile2 tmpfile) + (delete-file tmpfile2))))) + + ;; Set proper permissions. + (set-file-modes tmpfile (tramp-default-file-modes filename)) + ;; Set local user ownership. + (tramp-set-file-uid-gid tmpfile))) + + ;; Oops, I don't know what to do. + (t (tramp-error + v 'file-error "Wrong method specification for `%s'" method))) + + ;; Error handling. + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + (run-hooks 'tramp-handle-file-local-copy-hook) + tmpfile))) + +;; This is needed for XEmacs only. Code stolen from files.el. +(defun tramp-sh-handle-insert-file-contents-literally + (filename &optional visit beg end replace) + "Like `insert-file-contents-literally' for Tramp files." + (let ((format-alist nil) + (after-insert-file-functions nil) + (coding-system-for-read 'no-conversion) + (coding-system-for-write 'no-conversion) + (find-buffer-file-type-function + (if (fboundp 'find-buffer-file-type) + (symbol-function 'find-buffer-file-type) + nil)) + (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) + (inhibit-file-name-operation 'insert-file-contents)) + (unwind-protect + (progn + (fset 'find-buffer-file-type (lambda (filename) t)) + (insert-file-contents filename visit beg end replace)) + ;; Save exit. + (if find-buffer-file-type-function + (fset 'find-buffer-file-type find-buffer-file-type-function) + (fmakunbound 'find-buffer-file-type))))) + +(defun tramp-sh-handle-make-auto-save-file-name () + "Like `make-auto-save-file-name' for Tramp files. +Returns a file name in `tramp-auto-save-directory' for autosaving this file." + (let ((tramp-auto-save-directory tramp-auto-save-directory) + (buffer-file-name + (tramp-subst-strs-in-string + '(("_" . "|") + ("/" . "_a") + (":" . "_b") + ("|" . "__") + ("[" . "_l") + ("]" . "_r")) + (buffer-file-name)))) + ;; File name must be unique. This is ensured with Emacs 22 (see + ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for + ;; all other cases we must do it ourselves. + (when (boundp 'auto-save-file-name-transforms) + (mapc + (lambda (x) + (when (and (string-match (car x) buffer-file-name) + (not (car (cddr x)))) + (setq tramp-auto-save-directory + (or tramp-auto-save-directory + (tramp-compat-temporary-file-directory))))) + (symbol-value 'auto-save-file-name-transforms))) + ;; Create directory. + (when tramp-auto-save-directory + (setq buffer-file-name + (expand-file-name buffer-file-name tramp-auto-save-directory)) + (unless (file-exists-p tramp-auto-save-directory) + (make-directory tramp-auto-save-directory t))) + ;; Run plain `make-auto-save-file-name'. There might be an advice when + ;; it is not a magic file name operation (since Emacs 22). + ;; We must deactivate it temporarily. + (if (not (ad-is-active 'make-auto-save-file-name)) + (tramp-run-real-handler 'make-auto-save-file-name nil) + ;; else + (ad-deactivate 'make-auto-save-file-name) + (prog1 + (tramp-run-real-handler 'make-auto-save-file-name nil) + (ad-activate 'make-auto-save-file-name))))) + +;; CCC grok LOCKNAME +(defun tramp-sh-handle-write-region + (start end filename &optional append visit lockname confirm) + "Like `write-region' for Tramp files." + (setq filename (expand-file-name filename)) + (with-parsed-tramp-file-name filename nil + ;; Following part commented out because we don't know what to do about + ;; file locking, and it does not appear to be a problem to ignore it. + ;; Ange-ftp ignores it, too. + ;; (when (and lockname (stringp lockname)) + ;; (setq lockname (expand-file-name lockname))) + ;; (unless (or (eq lockname nil) + ;; (string= lockname filename)) + ;; (error + ;; "tramp-sh-handle-write-region: LOCKNAME must be nil or equal FILENAME")) + + ;; XEmacs takes a coding system as the seventh argument, not `confirm'. + (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) + (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) + (tramp-error v 'file-error "File not overwritten"))) + + (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) + + (if (and (tramp-local-host-p v) + ;; `file-writable-p' calls `file-expand-file-name'. We + ;; cannot use `tramp-run-real-handler' therefore. + (let (file-name-handler-alist) + (and + (file-writable-p (file-name-directory localname)) + (or (file-directory-p localname) + (file-writable-p localname))))) + ;; Short track: if we are on the local host, we can run directly. + (tramp-run-real-handler + 'write-region + (list start end localname append 'no-message lockname confirm)) + + (let ((modes (save-excursion (tramp-default-file-modes filename))) + ;; We use this to save the value of + ;; `last-coding-system-used' after writing the tmp + ;; file. At the end of the function, we set + ;; `last-coding-system-used' to this saved value. This + ;; way, any intermediary coding systems used while + ;; talking to the remote shell or suchlike won't hose + ;; this variable. This approach was snarfed from + ;; ange-ftp.el. + coding-system-used + ;; Write region into a tmp file. This isn't really + ;; needed if we use an encoding function, but currently + ;; we use it always because this makes the logic + ;; simpler. + (tmpfile (or tramp-temp-buffer-file-name + (tramp-compat-make-temp-file filename)))) + + ;; If `append' is non-nil, we copy the file locally, and let + ;; the native `write-region' implementation do the job. + (when append (copy-file filename tmpfile 'ok)) + + ;; We say `no-message' here because we don't want the + ;; visited file modtime data to be clobbered from the temp + ;; file. We call `set-visited-file-modtime' ourselves later + ;; on. We must ensure that `file-coding-system-alist' + ;; matches `tmpfile'. + (let (file-name-handler-alist + (file-coding-system-alist + (tramp-find-file-name-coding-system-alist filename tmpfile))) + (condition-case err + (tramp-run-real-handler + 'write-region + (list start end tmpfile append 'no-message lockname confirm)) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Now, `last-coding-system-used' has the right value. Remember it. + (when (boundp 'last-coding-system-used) + (setq coding-system-used + (symbol-value 'last-coding-system-used)))) + + ;; The permissions of the temporary file should be set. If + ;; filename does not exist (eq modes nil) it has been + ;; renamed to the backup file. This case `save-buffer' + ;; handles permissions. + ;; Ensure, that it is still readable. + (when modes + (set-file-modes + tmpfile + (logior (or modes 0) (tramp-compat-octal-to-decimal "0400")))) + + ;; This is a bit lengthy due to the different methods + ;; possible for file transfer. First, we check whether the + ;; method uses an rcp program. If so, we call it. + ;; Otherwise, both encoding and decoding command must be + ;; specified. However, if the method _also_ specifies an + ;; encoding function, then that is used for encoding the + ;; contents of the tmp file. + (let* ((size (nth 7 (file-attributes tmpfile))) + (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) + (loc-enc (tramp-get-inline-coding v "local-encoding" size))) + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + method 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. + (unwind-protect + (copy-file tmpfile filename t) + (delete-file tmpfile)))) + + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. + (unwind-protect + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (if (functionp loc-enc) + (with-progress-reporter + v 3 (format "Encoding region using function `%s'" + loc-enc) + (let ((coding-system-for-read 'binary)) + (insert-file-contents-literally tmpfile)) + ;; The following `let' is a workaround for the + ;; base64.el that comes with pgnus-0.84. If + ;; both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (funcall loc-enc (point-min) (point-max)))) + + (with-progress-reporter + v 3 (format "Encoding region using command `%s'" + loc-enc) + (unless (zerop (tramp-call-local-coding-command + loc-enc tmpfile t)) + (tramp-error + v 'file-error + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") + filename loc-enc)))) + + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (with-progress-reporter + v 3 + (format "Decoding region into remote file %s" filename) + (goto-char (point-max)) + (unless (bolp) (newline)) + (tramp-send-command + v + (format + (concat rem-dec " <<'EOF'\n%sEOF") + (tramp-shell-quote-argument localname) + (buffer-string))) + (tramp-barf-unless-okay + v nil + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region is + ;; written to a temporary file. Check that the + ;; checksum is equal to that from the local tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-compat-call-process "cksum" tmpfile t)) + ;; cksum runs remotely. + (tramp-send-command-and-check + v + (format + "cksum <%s" (tramp-shell-quote-argument localname))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (with-current-buffer (tramp-get-buffer v) + (buffer-string)))) + (tramp-error + v 'file-error + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") + filename rem-dec))))) + + ;; Save exit. + (delete-file tmpfile))) + + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an rcp program") + method)))) + + ;; Make `last-coding-system-used' have the right value. + (when coding-system-used + (set 'last-coding-system-used coding-system-used)))) + + (tramp-flush-file-property v (file-name-directory localname)) + (tramp-flush-file-property v localname) + + ;; We must protect `last-coding-system-used', now we have set it + ;; to its correct value. + (let (last-coding-system-used (need-chown t)) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (let ((file-attr (file-attributes filename))) + (set-visited-file-modtime + ;; We must pass modtime explicitely, because filename can + ;; be different from (buffer-file-name), f.e. if + ;; `file-precious-flag' is set. + (nth 5 file-attr)) + (when (and (eq (nth 2 file-attr) uid) + (eq (nth 3 file-attr) gid)) + (setq need-chown nil)))) + + ;; Set the ownership. + (when need-chown + (tramp-set-file-uid-gid filename uid gid)) + (when (or (eq visit t) (null visit) (stringp visit)) + (tramp-message v 0 "Wrote %s" filename)) + (run-hooks 'tramp-handle-write-region-hook))))) + +(defvar tramp-vc-registered-file-names nil + "List used to collect file names, which are checked during `vc-registered'.") + +;; VC backends check for the existence of various different special +;; files. This is very time consuming, because every single check +;; requires a remote command (the file cache must be invalidated). +;; Therefore, we apply a kind of optimization. We install the file +;; name handler `tramp-vc-file-name-handler', which does nothing but +;; remembers all file names for which `file-exists-p' or +;; `file-readable-p' has been applied. A first run of `vc-registered' +;; is performed. Afterwards, a script is applied for all collected +;; file names, using just one remote command. The result of this +;; script is used to fill the file cache with actual values. Now we +;; can reset the file name handlers, and we make a second run of +;; `vc-registered', which returns the expected result without sending +;; any other remote command. +(defun tramp-sh-handle-vc-registered (file) + "Like `vc-registered' for Tramp files." + (tramp-compat-with-temp-message "" + (with-parsed-tramp-file-name file nil + (with-progress-reporter + v 3 (format "Checking `vc-registered' for %s" file) + + ;; There could be new files, created by the vc backend. We + ;; cannot reuse the old cache entries, therefore. + (let (tramp-vc-registered-file-names + (remote-file-name-inhibit-cache (current-time)) + (file-name-handler-alist + `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) + + ;; Here we collect only file names, which need an operation. + (tramp-run-real-handler 'vc-registered (list file)) + (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) + + ;; Send just one command, in order to fill the cache. + (when tramp-vc-registered-file-names + (tramp-maybe-send-script + v + (format tramp-vc-registered-read-file-names + (tramp-get-file-exists-command v) + (format "%s -r" (tramp-get-test-command v))) + "tramp_vc_registered_read_file_names") + + (dolist + (elt + (tramp-send-command-and-read + v + (format + "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n" + (mapconcat 'tramp-shell-quote-argument + tramp-vc-registered-file-names + "\n")))) + + (tramp-set-file-property + v (car elt) (cadr elt) (cadr (cdr elt)))))) + + ;; Second run. Now all `file-exists-p' or `file-readable-p' + ;; calls shall be answered from the file cache. We unset + ;; `process-file-side-effects' in order to keep the cache when + ;; `process-file' calls appear. + (let (process-file-side-effects) + (tramp-run-real-handler 'vc-registered (list file))))))) + +;;;###tramp-autoload +(defun tramp-sh-file-name-handler (operation &rest args) + "Invoke remote-shell Tramp file name handler. +Fall back to normal file name handler if no Tramp handler exists." + (when (and tramp-locked (not tramp-locker)) + (setq tramp-locked nil) + (signal 'file-error (list "Forbidden reentrant call of Tramp"))) + (let ((tl tramp-locked)) + (unwind-protect + (progn + (setq tramp-locked t) + (let ((tramp-locker t)) + (save-match-data + (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (if fn + (apply (cdr fn) args) + (tramp-run-real-handler operation args)))))) + (setq tramp-locked tl)))) + +(defun tramp-vc-file-name-handler (operation &rest args) + "Invoke special file name handler, which collects files to be handled." + (save-match-data + (let ((filename + (tramp-replace-environment-variables + (apply 'tramp-file-name-for-operation operation args))) + (fn (assoc operation tramp-sh-file-name-handler-alist))) + (with-parsed-tramp-file-name filename nil + (cond + ;; That's what we want: file names, for which checks are + ;; applied. We assume, that VC uses only `file-exists-p' and + ;; `file-readable-p' checks; otherwise we must extend the + ;; list. We do not perform any action, but return nil, in + ;; order to keep `vc-registered' running. + ((and fn (memq operation '(file-exists-p file-readable-p))) + (add-to-list 'tramp-vc-registered-file-names localname 'append) + nil) + ;; Tramp file name handlers like `expand-file-name'. They + ;; must still work. + (fn + (save-match-data (apply (cdr fn) args))) + ;; Default file name handlers, we don't care. + (t (tramp-run-real-handler operation args))))))) + +;;; Internal Functions: + +(defun tramp-maybe-send-script (vec script name) + "Define in remote shell function NAME implemented as SCRIPT. +Only send the definition if it has not already been done." + (let* ((p (tramp-get-connection-process vec)) + (scripts (tramp-get-connection-property p "scripts" nil))) + (unless (member name scripts) + (with-progress-reporter vec 5 (format "Sending script `%s'" name) + ;; The script could contain a call of Perl. This is masked with `%s'. + (tramp-barf-unless-okay + vec + (format "%s () {\n%s\n}" name + (format script (tramp-get-remote-perl vec))) + "Script %s sending failed" name) + (tramp-set-connection-property p "scripts" (cons name scripts)))))) + +(defun tramp-set-auto-save () + (when (and ;; ange-ftp has its own auto-save mechanism + (eq (tramp-find-foreign-file-name-handler (buffer-file-name)) + 'tramp-sh-file-name-handler) + auto-save-default) + (auto-save-mode 1))) +(add-hook 'find-file-hooks 'tramp-set-auto-save t) +(add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'find-file-hooks 'tramp-set-auto-save))) + +(defun tramp-run-test (switch filename) + "Run `test' on the remote system, given a SWITCH and a FILENAME. +Returns the exit code of the `test' program." + (with-parsed-tramp-file-name filename nil + (tramp-send-command-and-check + v + (format + "%s %s %s" + (tramp-get-test-command v) + switch + (tramp-shell-quote-argument localname))))) + +(defun tramp-run-test2 (format-string file1 file2) + "Run `test'-like program on the remote system, given FILE1, FILE2. +FORMAT-STRING contains the program name, switches, and place holders. +Returns the exit code of the `test' program. Barfs if the methods, +hosts, or files, disagree." + (unless (tramp-equal-remote file1 file2) + (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil + (tramp-error + v 'file-error + "tramp-run-test2 only implemented for same method, user, host"))) + (with-parsed-tramp-file-name file1 v1 + (with-parsed-tramp-file-name file1 v2 + (tramp-send-command-and-check + v1 + (format format-string + (tramp-shell-quote-argument v1-localname) + (tramp-shell-quote-argument v2-localname)))))) + +(defun tramp-find-executable + (vec progname dirlist &optional ignore-tilde ignore-path) + "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST. +First arg VEC specifies the connection, PROGNAME is the program +to search for, and DIRLIST gives the list of directories to +search. If IGNORE-TILDE is non-nil, directory names starting +with `~' will be ignored. If IGNORE-PATH is non-nil, searches +only in DIRLIST. + +Returns the absolute file name of PROGNAME, if found, and nil otherwise. + +This function expects to be in the right *tramp* buffer." + (with-current-buffer (tramp-get-connection-buffer vec) + (let (result) + ;; Check whether the executable is in $PATH. "which(1)" does not + ;; report always a correct error code; therefore we check the + ;; number of words it returns. + (unless ignore-path + (tramp-send-command vec (format "which \\%s | wc -w" progname)) + (goto-char (point-min)) + (if (looking-at "^\\s-*1$") + (setq result (concat "\\" progname)))) + (unless result + (when ignore-tilde + ;; Remove all ~/foo directories from dirlist. In XEmacs, + ;; `remove' is in CL, and we want to avoid CL dependencies. + (let (newdl d) + (while dirlist + (setq d (car dirlist)) + (setq dirlist (cdr dirlist)) + (unless (char-equal ?~ (aref d 0)) + (setq newdl (cons d newdl)))) + (setq dirlist (nreverse newdl)))) + (tramp-send-command + vec + (format (concat "while read d; " + "do if test -x $d/%s -a -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'EOF'\n" + "%s\nEOF") + progname progname progname (mapconcat 'identity dirlist "\n"))) + (goto-char (point-max)) + (when (search-backward "tramp_executable " nil t) + (skip-chars-forward "^ ") + (skip-chars-forward " ") + (setq result (buffer-substring (point) (point-at-eol))))) + result))) + +(defun tramp-set-remote-path (vec) + "Sets the remote environment PATH to existing directories. +I.e., for each directory in `tramp-remote-path', it is tested +whether it exists and if so, it is added to the environment +variable PATH." + (tramp-message vec 5 (format "Setting $PATH environment variable")) + (tramp-send-command + vec (format "PATH=%s; export PATH" + (mapconcat 'identity (tramp-get-remote-path vec) ":")))) + +;; ------------------------------------------------------------ +;; -- Communication with external shell -- +;; ------------------------------------------------------------ + +(defun tramp-find-file-exists-command (vec) + "Find a command on the remote host for checking if a file exists. +Here, we are looking for a command which has zero exit status if the +file exists and nonzero exit status otherwise." + (let ((existing "/") + (nonexisting + (tramp-shell-quote-argument "/ this file does not exist ")) + result) + ;; The algorithm is as follows: we try a list of several commands. + ;; For each command, we first run `$cmd /' -- this should return + ;; true, as the root directory always exists. And then we run + ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed + ;; does not exist. This should return false. We use the first + ;; command we find that seems to work. + ;; The list of commands to try is as follows: + ;; `ls -d' This works on most systems, but NetBSD 1.4 + ;; has a bug: `ls' always returns zero exit + ;; status, even for files which don't exist. + ;; `test -e' Some Bourne shells have a `test' builtin + ;; which does not know the `-e' option. + ;; `/bin/test -e' For those, the `test' binary on disk normally + ;; provides the option. Alas, the binary + ;; is sometimes `/bin/test' and sometimes it's + ;; `/usr/bin/test'. + ;; `/usr/bin/test -e' In case `/bin/test' does not exist. + (unless (or + (and (setq result (format "%s -e" (tramp-get-test-command vec))) + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting)))) + (and (setq result "/bin/test -e") + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting)))) + (and (setq result "/usr/bin/test -e") + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting)))) + (and (setq result (format "%s -d" (tramp-get-ls-command vec))) + (tramp-send-command-and-check + vec (format "%s %s" result existing)) + (not (tramp-send-command-and-check + vec (format "%s %s" result nonexisting))))) + (tramp-error + vec 'file-error "Couldn't find command to check if file exists")) + result)) + +(defun tramp-open-shell (vec shell) + "Opens shell SHELL." + (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell) + ;; Find arguments for this shell. + (let ((tramp-end-of-output tramp-initial-end-of-output) + (alist tramp-sh-extra-args) + item extra-args) + (while (and alist (null extra-args)) + (setq item (pop alist)) + (when (string-match (car item) shell) + (setq extra-args (cdr item)))) + (when extra-args (setq shell (concat shell " " extra-args))) + (tramp-send-command + vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s" + (shell-quote-argument tramp-end-of-output) shell) + t)) + ;; Setting prompts. + (tramp-send-command + vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) + (tramp-send-command vec "PS2=''" t) + (tramp-send-command vec "PS3=''" t) + (tramp-send-command vec "PROMPT_COMMAND=''" t))) + +(defun tramp-find-shell (vec) + "Opens a shell on the remote host which groks tilde expansion." + (unless (tramp-get-connection-property vec "remote-shell" nil) + (let (shell) + (with-current-buffer (tramp-get-buffer vec) + (tramp-send-command vec "echo ~root" t) + (cond + ((or (string-match "^~root$" (buffer-string)) + ;; The default shell (ksh93) of OpenSolaris is buggy. + (string-equal (tramp-get-connection-property vec "uname" "") + "SunOS 5.11")) + (setq shell + (or (tramp-find-executable + vec "bash" (tramp-get-remote-path vec) t t) + (tramp-find-executable + vec "ksh" (tramp-get-remote-path vec) t t))) + (unless shell + (tramp-error + vec 'file-error + "Couldn't find a shell which groks tilde expansion")) + (tramp-message + vec 5 "Starting remote shell `%s' for tilde expansion" shell) + (tramp-open-shell vec shell)) + + (t (tramp-message + vec 5 "Remote `%s' groks tilde expansion, good" + (tramp-set-connection-property + vec "remote-shell" + (tramp-get-method-parameter + (tramp-file-name-method vec) 'tramp-remote-sh))))))))) + +;; Utility functions. + +(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args) + "Wait for shell prompt and barf if none appears. +Looks at process PROC to see if a shell prompt appears in TIMEOUT +seconds. If not, it produces an error message with the given ERROR-ARGS." + (unless + (tramp-wait-for-regexp + proc timeout + (format + "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern)) + (apply 'tramp-error-with-buffer nil proc 'file-error error-args))) + +(defun tramp-open-connection-setup-interactive-shell (proc vec) + "Set up an interactive shell. +Mainly sets the prompt and the echo correctly. PROC is the shell +process to set up. VEC specifies the connection." + (let ((tramp-end-of-output tramp-initial-end-of-output)) + ;; It is useful to set the prompt in the following command because + ;; some people have a setting for $PS1 which /bin/sh doesn't know + ;; about and thus /bin/sh will display a strange prompt. For + ;; example, if $PS1 has "${CWD}" in the value, then ksh will + ;; display the current working directory but /bin/sh will display + ;; a dollar sign. The following command line sets $PS1 to a sane + ;; value, and works under Bourne-ish shells as well as csh-like + ;; shells. Daniel Pittman reports that the unusual positioning of + ;; the single quotes makes it work under `rc', too. We also unset + ;; the variable $ENV because that is read by some sh + ;; implementations (eg, bash when called as sh) on startup; this + ;; way, we avoid the startup file clobbering $PS1. $PROMPT_COMMAND + ;; is another way to set the prompt in /bin/bash, it must be + ;; discarded as well. + (tramp-open-shell + vec + (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh)) + + ;; Disable echo. + (tramp-message vec 5 "Setting up remote shell environment") + (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) + ;; Check whether the echo has really been disabled. Some + ;; implementations, like busybox of embedded GNU/Linux, don't + ;; support disabling. + (tramp-send-command vec "echo foo" t) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (when (looking-at "echo foo") + (tramp-set-connection-property proc "remote-echo" t) + (tramp-message vec 5 "Remote echo still on. Ok.") + ;; Make sure backspaces and their echo are enabled and no line + ;; width magic interferes with them. + (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) + + (tramp-message vec 5 "Setting shell prompt") + (tramp-send-command + vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) + (tramp-send-command vec "PS2=''" t) + (tramp-send-command vec "PS3=''" t) + (tramp-send-command vec "PROMPT_COMMAND=''" t) + + ;; Try to set up the coding system correctly. + ;; CCC this can't be the right way to do it. Hm. + (tramp-message vec 5 "Determining coding system") + (tramp-send-command vec "echo foo ; echo bar" t) + (with-current-buffer (process-buffer proc) + (goto-char (point-min)) + (if (featurep 'mule) + ;; Use MULE to select the right EOL convention for communicating + ;; with the process. + (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc) + (cons 'undecided 'undecided))) + cs-decode cs-encode) + (when (symbolp cs) (setq cs (cons cs cs))) + (setq cs-decode (car cs)) + (setq cs-encode (cdr cs)) + (unless cs-decode (setq cs-decode 'undecided)) + (unless cs-encode (setq cs-encode 'undecided)) + (setq cs-encode (tramp-compat-coding-system-change-eol-conversion + cs-encode 'unix)) + (when (search-forward "\r" nil t) + (setq cs-decode (tramp-compat-coding-system-change-eol-conversion + cs-decode 'dos))) + (tramp-compat-funcall + 'set-buffer-process-coding-system cs-decode cs-encode) + (tramp-message + vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode)) + ;; Look for ^M and do something useful if found. + (when (search-forward "\r" nil t) + ;; We have found a ^M but cannot frob the process coding system + ;; because we're running on a non-MULE Emacs. Let's try + ;; stty, instead. + (tramp-send-command vec "stty -onlcr" t)))) + + (tramp-send-command vec "set +o vi +o emacs" t) + + ;; Check whether the output of "uname -sr" has been changed. If + ;; yes, this is a strong indication that we must expire all + ;; connection properties. We start again with + ;; `tramp-maybe-open-connection', it will be catched there. + (tramp-message vec 5 "Checking system information") + (let ((old-uname (tramp-get-connection-property vec "uname" nil)) + (new-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) + (with-current-buffer (tramp-get-debug-buffer vec) + ;; Keep the debug buffer. + (rename-buffer + (generate-new-buffer-name tramp-temp-buffer-name) 'unique) + (tramp-cleanup-connection vec) + (if (= (point-min) (point-max)) + (kill-buffer nil) + (rename-buffer (tramp-debug-buffer-name vec) 'unique)) + ;; We call `tramp-get-buffer' in order to keep the debug buffer. + (tramp-get-buffer vec) + (tramp-message + vec 3 + "Connection reset, because remote host changed from `%s' to `%s'" + old-uname new-uname) + (throw 'uname-changed (tramp-maybe-open-connection vec))))) + + ;; Check whether the remote host suffers from buggy + ;; `send-process-string'. This is known for FreeBSD (see comment in + ;; `send_process', file process.c). I've tested sending 624 bytes + ;; successfully, sending 625 bytes failed. Emacs makes a hack when + ;; this host type is detected locally. It cannot handle remote + ;; hosts, though. + (with-connection-property proc "chunksize" + (cond + ((and (integerp tramp-chunksize) (> tramp-chunksize 0)) + tramp-chunksize) + (t + (tramp-message + vec 5 "Checking remote host type for `send-process-string' bug") + (if (string-match + "^FreeBSD" (tramp-get-connection-property vec "uname" "")) + 500 0)))) + + ;; Set remote PATH variable. + (tramp-set-remote-path vec) + + ;; Search for a good shell before searching for a command which + ;; checks if a file exists. This is done because Tramp wants to use + ;; "test foo; echo $?" to check if various conditions hold, and + ;; there are buggy /bin/sh implementations which don't execute the + ;; "echo $?" part if the "test" part has an error. In particular, + ;; the OpenSolaris /bin/sh is a problem. There are also other + ;; problems with /bin/sh of OpenSolaris, like redirection of stderr + ;; in function declarations, or changing HISTFILE in place. + ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when + ;; detected. + (tramp-find-shell vec) + + ;; Disable unexpected output. + (tramp-send-command vec "mesg n; biff n" t) + + ;; IRIX64 bash expands "!" even when in single quotes. This + ;; destroys our shell functions, we must disable it. See + ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. + (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" "")) + (tramp-send-command vec "set +H" t)) + + ;; On BSD-like systems, ?\t is expanded to spaces. Suppress this. + (when (string-match "BSD\\|Darwin" + (tramp-get-connection-property vec "uname" "")) + (tramp-send-command vec "stty -oxtabs" t)) + + ;; Set `remote-tty' process property. + (ignore-errors + (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\""))) + (unless (zerop (length tty)) + (tramp-compat-process-put proc 'remote-tty tty)))) + + ;; Dump stty settings in the traces. + (when (>= tramp-verbose 9) + (tramp-send-command vec "stty -a" t)) + + ;; Set the environment. + (tramp-message vec 5 "Setting default environment") + + (let ((env (copy-sequence tramp-remote-process-environment)) + unset item) + (while env + (setq item (tramp-compat-split-string (car env) "=")) + (setcdr item (mapconcat 'identity (cdr item) "=")) + (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) + (tramp-send-command + vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t) + (push (car item) unset)) + (setq env (cdr env))) + (when unset + (tramp-send-command + vec (format "unset %s" (mapconcat 'identity unset " ")) t)))) + +;; CCC: We should either implement a Perl version of base64 encoding +;; and decoding. Then we just use that in the last item. The other +;; alternative is to use the Perl version of UU encoding. But then +;; we need a Lisp version of uuencode. +;; +;; Old text from documentation of tramp-methods: +;; Using a uuencode/uudecode inline method is discouraged, please use one +;; of the base64 methods instead since base64 encoding is much more +;; reliable and the commands are more standardized between the different +;; Unix versions. But if you can't use base64 for some reason, please +;; note that the default uudecode command does not work well for some +;; Unices, in particular AIX and Irix. For AIX, you might want to use +;; the following command for uudecode: +;; +;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1 +;; +;; For Irix, no solution is known yet. + +(autoload 'uudecode-decode-region "uudecode") + +(defconst tramp-local-coding-commands + '((b64 base64-encode-region base64-decode-region) + (uu tramp-uuencode-region uudecode-decode-region) + (pack + "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" + "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) + "List of local coding commands for inline transfer. +Each item is a list that looks like this: + +\(FORMAT ENCODING DECODING\) + +FORMAT is symbol describing the encoding/decoding format. It can be +`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. + +ENCODING and DECODING can be strings, giving commands, or symbols, +giving functions. If they are strings, then they can contain +the \"%s\" format specifier. If that specifier is present, the input +filename will be put into the command line at that spot. If the +specifier is not present, the input should be read from standard +input. + +If they are functions, they will be called with two arguments, start +and end of region, and are expected to replace the region contents +with the encoded or decoded results, respectively.") + +(defconst tramp-remote-coding-commands + '((b64 "base64" "base64 -d -i") + ;; "-i" is more robust with older base64 from GNU coreutils. + ;; However, I don't know whether all base64 versions do supports + ;; this option. + (b64 "base64" "base64 -d") + (b64 "mimencode -b" "mimencode -u -b") + (b64 "mmencode -b" "mmencode -u -b") + (b64 "recode data..base64" "recode base64..data") + (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) + (b64 tramp-perl-encode tramp-perl-decode) + (uu "uuencode xxx" "uudecode -o /dev/stdout") + (uu "uuencode xxx" "uudecode -o -") + (uu "uuencode xxx" "uudecode -p") + (uu "uuencode xxx" tramp-uudecode) + (pack + "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" + "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) + "List of remote coding commands for inline transfer. +Each item is a list that looks like this: + +\(FORMAT ENCODING DECODING\) + +FORMAT is symbol describing the encoding/decoding format. It can be +`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. + +ENCODING and DECODING can be strings, giving commands, or symbols, +giving variables. If they are strings, then they can contain +the \"%s\" format specifier. If that specifier is present, the input +filename will be put into the command line at that spot. If the +specifier is not present, the input should be read from standard +input. + +If they are variables, this variable is a string containing a Perl +implementation for this functionality. This Perl program will be transferred +to the remote host, and it is available as shell function with the same name.") + +(defun tramp-find-inline-encoding (vec) + "Find an inline transfer encoding that works. +Goes through the list `tramp-local-coding-commands' and +`tramp-remote-coding-commands'." + (save-excursion + (let ((local-commands tramp-local-coding-commands) + (magic "xyzzy") + loc-enc loc-dec rem-enc rem-dec litem ritem found) + (while (and local-commands (not found)) + (setq litem (pop local-commands)) + (catch 'wont-work-local + (let ((format (nth 0 litem)) + (remote-commands tramp-remote-coding-commands)) + (setq loc-enc (nth 1 litem)) + (setq loc-dec (nth 2 litem)) + ;; If the local encoder or decoder is a string, the + ;; corresponding command has to work locally. + (if (not (stringp loc-enc)) + (tramp-message + vec 5 "Checking local encoding function `%s'" loc-enc) + (tramp-message + vec 5 "Checking local encoding command `%s' for sanity" loc-enc) + (unless (zerop (tramp-call-local-coding-command + loc-enc nil nil)) + (throw 'wont-work-local nil))) + (if (not (stringp loc-dec)) + (tramp-message + vec 5 "Checking local decoding function `%s'" loc-dec) + (tramp-message + vec 5 "Checking local decoding command `%s' for sanity" loc-dec) + (unless (zerop (tramp-call-local-coding-command + loc-dec nil nil)) + (throw 'wont-work-local nil))) + ;; Search for remote coding commands with the same format + (while (and remote-commands (not found)) + (setq ritem (pop remote-commands)) + (catch 'wont-work-remote + (when (equal format (nth 0 ritem)) + (setq rem-enc (nth 1 ritem)) + (setq rem-dec (nth 2 ritem)) + ;; Check if remote encoding and decoding commands can be + ;; called remotely with null input and output. This makes + ;; sure there are no syntax errors and the command is really + ;; found. Note that we do not redirect stdout to /dev/null, + ;; for two reasons: when checking the decoding command, we + ;; actually check the output it gives. And also, when + ;; redirecting "mimencode" output to /dev/null, then as root + ;; it might change the permissions of /dev/null! + (when (not (stringp rem-enc)) + (let ((name (symbol-name rem-enc))) + (while (string-match (regexp-quote "-") name) + (setq name (replace-match "_" nil t name))) + (tramp-maybe-send-script vec (symbol-value rem-enc) name) + (setq rem-enc name))) + (tramp-message + vec 5 + "Checking remote encoding command `%s' for sanity" rem-enc) + (unless (tramp-send-command-and-check + vec (format "%s </dev/null" rem-enc) t) + (throw 'wont-work-remote nil)) + + (when (not (stringp rem-dec)) + (let ((name (symbol-name rem-dec))) + (while (string-match (regexp-quote "-") name) + (setq name (replace-match "_" nil t name))) + (tramp-maybe-send-script vec (symbol-value rem-dec) name) + (setq rem-dec name))) + (tramp-message + vec 5 + "Checking remote decoding command `%s' for sanity" rem-dec) + (unless (tramp-send-command-and-check + vec + (format "echo %s | %s | %s" magic rem-enc rem-dec) + t) + (throw 'wont-work-remote nil)) + + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (unless (looking-at (regexp-quote magic)) + (throw 'wont-work-remote nil))) + + ;; `rem-enc' and `rem-dec' could be a string meanwhile. + (setq rem-enc (nth 1 ritem)) + (setq rem-dec (nth 2 ritem)) + (setq found t))))))) + + ;; Did we find something? + (unless found + (tramp-error + vec 'file-error "Couldn't find an inline transfer encoding")) + + ;; Set connection properties. + (tramp-message vec 5 "Using local encoding `%s'" loc-enc) + (tramp-set-connection-property vec "local-encoding" loc-enc) + (tramp-message vec 5 "Using local decoding `%s'" loc-dec) + (tramp-set-connection-property vec "local-decoding" loc-dec) + (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) + (tramp-set-connection-property vec "remote-encoding" rem-enc) + (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) + (tramp-set-connection-property vec "remote-decoding" rem-dec)))) + +(defun tramp-call-local-coding-command (cmd input output) + "Call the local encoding or decoding command. +If CMD contains \"%s\", provide input file INPUT there in command. +Otherwise, INPUT is passed via standard input. +INPUT can also be nil which means `/dev/null'. +OUTPUT can be a string (which specifies a filename), or t (which +means standard output and thus the current buffer), or nil (which +means discard it)." + (tramp-compat-call-process + tramp-encoding-shell + (when (and input (not (string-match "%s" cmd))) input) + (if (eq output t) t nil) + nil + tramp-encoding-command-switch + (concat + (if (string-match "%s" cmd) (format cmd input) cmd) + (if (stringp output) (concat "> " output) "")))) + +(defconst tramp-inline-compress-commands + '(("gzip" "gzip -d") + ("bzip2" "bzip2 -d") + ("compress" "compress -d")) + "List of compress and decompress commands for inline transfer. +Each item is a list that looks like this: + +\(COMPRESS DECOMPRESS\) + +COMPRESS or DECOMPRESS are strings with the respective commands.") + +(defun tramp-find-inline-compress (vec) + "Find an inline transfer compress command that works. +Goes through the list `tramp-inline-compress-commands'." + (save-excursion + (let ((commands tramp-inline-compress-commands) + (magic "xyzzy") + item compress decompress + found) + (while (and commands (not found)) + (catch 'next + (setq item (pop commands) + compress (nth 0 item) + decompress (nth 1 item)) + (tramp-message + vec 5 + "Checking local compress command `%s', `%s' for sanity" + compress decompress) + (unless (zerop (tramp-call-local-coding-command + (format "echo %s | %s | %s" + magic compress decompress) nil nil)) + (throw 'next nil)) + (tramp-message + vec 5 + "Checking remote compress command `%s', `%s' for sanity" + compress decompress) + (unless (tramp-send-command-and-check + vec (format "echo %s | %s | %s" magic compress decompress) t) + (throw 'next nil)) + (setq found t))) + + ;; Did we find something? + (if found + (progn + ;; Set connection properties. + (tramp-message + vec 5 "Using inline transfer compress command `%s'" compress) + (tramp-set-connection-property vec "inline-compress" compress) + (tramp-message + vec 5 "Using inline transfer decompress command `%s'" decompress) + (tramp-set-connection-property vec "inline-decompress" decompress)) + + (tramp-set-connection-property vec "inline-compress" nil) + (tramp-set-connection-property vec "inline-decompress" nil) + (tramp-message + vec 2 "Couldn't find an inline transfer compress command"))))) + +(defun tramp-compute-multi-hops (vec) + "Expands VEC according to `tramp-default-proxies-alist'. +Gateway hops are already opened." + (let ((target-alist `(,vec)) + (choices tramp-default-proxies-alist) + item proxy) + + ;; Look for proxy hosts to be passed. + (while choices + (setq item (pop choices) + proxy (eval (nth 2 item))) + (when (and + ;; host + (string-match (or (eval (nth 0 item)) "") + (or (tramp-file-name-host (car target-alist)) "")) + ;; user + (string-match (or (eval (nth 1 item)) "") + (or (tramp-file-name-user (car target-alist)) ""))) + (if (null proxy) + ;; No more hops needed. + (setq choices nil) + ;; Replace placeholders. + (setq proxy + (format-spec + proxy + (format-spec-make + ?u (or (tramp-file-name-user (car target-alist)) "") + ?h (or (tramp-file-name-host (car target-alist)) "")))) + (with-parsed-tramp-file-name proxy l + ;; Add the hop. + (add-to-list 'target-alist l) + ;; Start next search. + (setq choices tramp-default-proxies-alist))))) + + ;; Handle gateways. + (when (string-match + (format + "^\\(%s\\|%s\\)$" tramp-gw-tunnel-method tramp-gw-socks-method) + (tramp-file-name-method (car target-alist))) + (let ((gw (pop target-alist)) + (hop (pop target-alist))) + ;; Is the method prepared for gateways? + (unless (tramp-file-name-port hop) + (tramp-error + vec 'file-error + "Connection `%s' is not supported for gateway access." hop)) + ;; Open the gateway connection. + (add-to-list + 'target-alist + (vector + (tramp-file-name-method hop) (tramp-file-name-user hop) + (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil)) + ;; For the password prompt, we need the correct values. + ;; Therefore, we must remember the gateway vector. But we + ;; cannot do it as connection property, because it shouldn't + ;; be persistent. And we have no started process yet either. + (tramp-set-file-property (car target-alist) "" "gateway" hop))) + + ;; Foreign and out-of-band methods are not supported for multi-hops. + (when (cdr target-alist) + (setq choices target-alist) + (while choices + (setq item (pop choices)) + (when + (or + (not + (tramp-get-method-parameter + (tramp-file-name-method item) 'tramp-login-program)) + (tramp-get-method-parameter + (tramp-file-name-method item) 'tramp-copy-program)) + (tramp-error + vec 'file-error + "Method `%s' is not supported for multi-hops." + (tramp-file-name-method item))))) + + ;; In case the host name is not used for the remote shell + ;; command, the user could be misguided by applying a random + ;; hostname. + (let* ((v (car target-alist)) + (method (tramp-file-name-method v)) + (host (tramp-file-name-host v))) + (unless + (or + ;; There are multi-hops. + (cdr target-alist) + ;; The host name is used for the remote shell command. + (member + '("%h") (tramp-get-method-parameter method 'tramp-login-args)) + ;; The host is local. We cannot use `tramp-local-host-p' + ;; here, because it opens a connection as well. + (string-match tramp-local-host-regexp host)) + (tramp-error + v 'file-error + "Host `%s' looks like a remote host, `%s' can only use the local host" + host method))) + + ;; Result. + target-alist)) + +(defun tramp-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + (catch 'uname-changed + (let ((p (tramp-get-connection-process vec)) + (process-name (tramp-get-connection-property vec "process-name" nil)) + (process-environment (copy-sequence process-environment))) + + ;; If too much time has passed since last command was sent, look + ;; whether process is still alive. If it isn't, kill it. When + ;; using ssh, it can sometimes happen that the remote end has + ;; hung up but the local ssh client doesn't recognize this until + ;; it tries to send some data to the remote end. So that's why + ;; we try to send a command from time to time, then look again + ;; whether the process is really alive. + (condition-case nil + (when (and (> (tramp-time-diff + (current-time) + (tramp-get-connection-property + p "last-cmd-time" '(0 0 0))) + 60) + p (processp p) (memq (process-status p) '(run open))) + (tramp-send-command vec "echo are you awake" t t) + (unless (and (memq (process-status p) '(run open)) + (tramp-wait-for-output p 10)) + ;; The error will be catched locally. + (tramp-error vec 'file-error "Awake did fail"))) + (file-error + (tramp-flush-connection-property vec) + (tramp-flush-connection-property p) + (delete-process p) + (setq p nil))) + + ;; New connection must be opened. + (unless (and p (processp p) (memq (process-status p) '(run open))) + + ;; We call `tramp-get-buffer' in order to get a debug buffer for + ;; messages from the beginning. + (tramp-get-buffer vec) + (with-progress-reporter + vec 3 + (if (zerop (length (tramp-file-name-user vec))) + (format "Opening connection for %s using %s" + (tramp-file-name-host vec) + (tramp-file-name-method vec)) + (format "Opening connection for %s@%s using %s" + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-file-name-method vec))) + + ;; Start new process. + (when (and p (processp p)) + (delete-process p)) + (setenv "TERM" tramp-terminal-type) + (setenv "LC_ALL" "C") + (setenv "PROMPT_COMMAND") + (setenv "PS1" tramp-initial-end-of-output) + (let* ((target-alist (tramp-compute-multi-hops vec)) + (process-connection-type tramp-process-connection-type) + (process-adaptive-read-buffering nil) + (coding-system-for-read nil) + ;; This must be done in order to avoid our file name handler. + (p (let ((default-directory + (tramp-compat-temporary-file-directory))) + (start-process + (tramp-get-connection-name vec) + (tramp-get-connection-buffer vec) + tramp-encoding-shell)))) + + (tramp-message + vec 6 "%s" (mapconcat 'identity (process-command p) " ")) + + ;; Check whether process is alive. + (tramp-compat-set-process-query-on-exit-flag p nil) + (tramp-barf-if-no-shell-prompt + p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell) + + ;; Now do all the connections as specified. + (while target-alist + (let* ((hop (car target-alist)) + (l-method (tramp-file-name-method hop)) + (l-user (tramp-file-name-user hop)) + (l-host (tramp-file-name-host hop)) + (l-port nil) + (login-program + (tramp-get-method-parameter + l-method 'tramp-login-program)) + (login-args + (tramp-get-method-parameter l-method 'tramp-login-args)) + (async-args + (tramp-get-method-parameter l-method 'tramp-async-args)) + (gw-args + (tramp-get-method-parameter l-method 'tramp-gw-args)) + (gw (tramp-get-file-property hop "" "gateway" nil)) + (g-method (and gw (tramp-file-name-method gw))) + (g-user (and gw (tramp-file-name-user gw))) + (g-host (and gw (tramp-file-name-host gw))) + (command login-program) + ;; We don't create the temporary file. In fact, + ;; it is just a prefix for the ControlPath option + ;; of ssh; the real temporary file has another + ;; name, and it is created and protected by ssh. + ;; It is also removed by ssh, when the connection + ;; is closed. + (tmpfile + (tramp-set-connection-property + p "temp-file" + (make-temp-name + (expand-file-name + tramp-temp-name-prefix + (tramp-compat-temporary-file-directory))))) + spec) + + ;; Add arguments for asynchrononous processes. + (when (and process-name async-args) + (setq login-args (append async-args login-args))) + + ;; Add gateway arguments if necessary. + (when (and gw gw-args) + (setq login-args (append gw-args login-args))) + + ;; Check for port number. Until now, there's no need + ;; for handling like method, user, host. + (when (string-match tramp-host-with-port-regexp l-host) + (setq l-port (match-string 2 l-host) + l-host (match-string 1 l-host))) + + ;; Set variables for computing the prompt for reading + ;; password. They can also be derived from a gateway. + (setq tramp-current-method (or g-method l-method) + tramp-current-user (or g-user l-user) + tramp-current-host (or g-host l-host)) + + ;; Replace login-args place holders. + (setq + l-host (or l-host "") + l-user (or l-user "") + l-port (or l-port "") + spec (format-spec-make + ?h l-host ?u l-user ?p l-port ?t tmpfile) + command + (concat + ;; We do not want to see the trailing local prompt in + ;; `start-file-process'. + (unless (memq system-type '(windows-nt)) "exec ") + command " " + (mapconcat + (lambda (x) + (setq x (mapcar (lambda (y) (format-spec y spec)) x)) + (unless (member "" x) (mapconcat 'identity x " "))) + login-args " ") + ;; Local shell could be a Windows COMSPEC. It + ;; doesn't know the ";" syntax, but we must exit + ;; always for `start-file-process'. "exec" does not + ;; work either. + (if (memq system-type '(windows-nt)) " && exit || exit"))) + + ;; Send the command. + (tramp-message vec 3 "Sending command `%s'" command) + (tramp-send-command vec command t t) + (tramp-process-actions p vec tramp-actions-before-shell 60) + (tramp-message + vec 3 "Found remote shell prompt on `%s'" l-host)) + ;; Next hop. + (setq target-alist (cdr target-alist))) + + ;; Make initial shell settings. + (tramp-open-connection-setup-interactive-shell p vec))))))) + +(defun tramp-send-command (vec command &optional neveropen nooutput) + "Send the COMMAND to connection VEC. +Erases temporary buffer before sending the command. If optional +arg NEVEROPEN is non-nil, never try to open the connection. This +is meant to be used from `tramp-maybe-open-connection' only. The +function waits for output unless NOOUTPUT is set." + (unless neveropen (tramp-maybe-open-connection vec)) + (let ((p (tramp-get-connection-process vec))) + (when (tramp-get-connection-property p "remote-echo" nil) + ;; We mark the command string that it can be erased in the output buffer. + (tramp-set-connection-property p "check-remote-echo" t) + (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark))) + (when (string-match "<<'EOF'" command) + ;; Unset $PS1 when using here documents, in order to avoid + ;; multiple prompts. + (setq command (concat "(PS1= ; " command "\n)"))) + ;; Send the command. + (tramp-message vec 6 "%s" command) + (tramp-send-string vec command) + (unless nooutput (tramp-wait-for-output p)))) + +(defun tramp-wait-for-output (proc &optional timeout) + "Wait for output from remote command." + (unless (buffer-live-p (process-buffer proc)) + (delete-process proc) + (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) + (with-current-buffer (process-buffer proc) + (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might + ;; be leading escape sequences, which must be ignored. + (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output))) + ;; Sometimes, the commands do not return a newline but a + ;; null byte before the shell prompt, for example "git + ;; ls-files -c -z ...". + (regexp1 (format "\\(^\\|\000\\)%s" regexp)) + (found (tramp-wait-for-regexp proc timeout regexp1))) + (if found + (let (buffer-read-only) + ;; A simple-minded busybox has sent " ^H" sequences. + ;; Delete them. + (goto-char (point-min)) + (when (re-search-forward "^\\(.\b\\)+$" (point-at-eol) t) + (forward-line 1) + (delete-region (point-min) (point))) + ;; Delete the prompt. + (goto-char (point-max)) + (re-search-backward regexp nil t) + (delete-region (point) (point-max))) + (if timeout + (tramp-error + proc 'file-error + "[[Remote prompt `%s' not found in %d secs]]" + tramp-end-of-output timeout) + (tramp-error + proc 'file-error + "[[Remote prompt `%s' not found]]" tramp-end-of-output))) + ;; Return value is whether end-of-output sentinel was found. + found))) + +(defun tramp-send-command-and-check + (vec command &optional subshell dont-suppress-err) + "Run COMMAND and check its exit status. +Sends `echo $?' along with the COMMAND for checking the exit status. If +COMMAND is nil, just sends `echo $?'. Returns the exit status found. + +If the optional argument SUBSHELL is non-nil, the command is +executed in a subshell, ie surrounded by parentheses. If +DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." + (tramp-send-command + vec + (concat (if subshell "( " "") + command + (if command (if dont-suppress-err "; " " 2>/dev/null; ") "") + "echo tramp_exit_status $?" + (if subshell " )" ""))) + (with-current-buffer (tramp-get-connection-buffer vec) + (goto-char (point-max)) + (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) + (tramp-error + vec 'file-error "Couldn't find exit status of `%s'" command)) + (skip-chars-forward "^ ") + (prog1 + (zerop (read (current-buffer))) + (let (buffer-read-only) + (delete-region (match-beginning 0) (point-max)))))) + +(defun tramp-barf-unless-okay (vec command fmt &rest args) + "Run COMMAND, check exit status, throw error if exit status not okay. +Similar to `tramp-send-command-and-check' but accepts two more arguments +FMT and ARGS which are passed to `error'." + (unless (tramp-send-command-and-check vec command) + (apply 'tramp-error vec 'file-error fmt args))) + +(defun tramp-send-command-and-read (vec command) + "Run COMMAND and return the output, which must be a Lisp expression. +In case there is no valid Lisp expression, it raises an error" + (tramp-barf-unless-okay vec command "`%s' returns with error" command) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Read the expression. + (goto-char (point-min)) + (condition-case nil + (prog1 (read (current-buffer)) + ;; Error handling. + (when (re-search-forward "\\S-" (point-at-eol) t) + (error nil))) + (error (tramp-error + vec 'file-error + "`%s' does not return a valid Lisp expression: `%s'" + command (buffer-string)))))) + +(defun tramp-convert-file-attributes (vec attr) + "Convert file-attributes ATTR generated by perl script, stat or ls. +Convert file mode bits to string and set virtual device number. +Return ATTR." + (when attr + ;; Convert last access time. + (unless (listp (nth 4 attr)) + (setcar (nthcdr 4 attr) + (list (floor (nth 4 attr) 65536) + (floor (mod (nth 4 attr) 65536))))) + ;; Convert last modification time. + (unless (listp (nth 5 attr)) + (setcar (nthcdr 5 attr) + (list (floor (nth 5 attr) 65536) + (floor (mod (nth 5 attr) 65536))))) + ;; Convert last status change time. + (unless (listp (nth 6 attr)) + (setcar (nthcdr 6 attr) + (list (floor (nth 6 attr) 65536) + (floor (mod (nth 6 attr) 65536))))) + ;; Convert file size. + (when (< (nth 7 attr) 0) + (setcar (nthcdr 7 attr) -1)) + (when (and (floatp (nth 7 attr)) + (<= (nth 7 attr) (tramp-compat-most-positive-fixnum))) + (setcar (nthcdr 7 attr) (round (nth 7 attr)))) + ;; Convert file mode bits to string. + (unless (stringp (nth 8 attr)) + (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) + (when (stringp (car attr)) + (aset (nth 8 attr) 0 ?l))) + ;; Convert directory indication bit. + (when (string-match "^d" (nth 8 attr)) + (setcar attr t)) + ;; Convert symlink from `tramp-do-file-attributes-with-stat'. + (when (consp (car attr)) + (if (and (stringp (caar attr)) + (string-match ".+ -> .\\(.+\\)." (caar attr))) + (setcar attr (match-string 1 (caar attr))) + (setcar attr nil))) + ;; Set file's gid change bit. + (setcar (nthcdr 9 attr) + (if (numberp (nth 3 attr)) + (not (= (nth 3 attr) + (tramp-get-remote-gid vec 'integer))) + (not (string-equal + (nth 3 attr) + (tramp-get-remote-gid vec 'string))))) + ;; Convert inode. + (unless (listp (nth 10 attr)) + (setcar (nthcdr 10 attr) + (condition-case nil + (cons (floor (nth 10 attr) 65536) + (floor (mod (nth 10 attr) 65536))) + ;; Inodes can be incredible huge. We must hide this. + (error (tramp-get-inode vec))))) + ;; Set virtual device number. + (setcar (nthcdr 11 attr) + (tramp-get-device vec)) + attr)) + +(defun tramp-check-cached-permissions (vec access) + "Check `file-attributes' caches for VEC. +Return t if according to the cache access type ACCESS is known to +be granted." + (let ((result nil) + (offset (cond + ((eq ?r access) 1) + ((eq ?w access) 2) + ((eq ?x access) 3)))) + (dolist (suffix '("string" "integer") result) + (setq + result + (or + result + (let ((file-attr + (tramp-get-file-property + vec (tramp-file-name-localname vec) + (concat "file-attributes-" suffix) nil)) + (remote-uid + (tramp-get-connection-property + vec (concat "uid-" suffix) nil)) + (remote-gid + (tramp-get-connection-property + vec (concat "gid-" suffix) nil))) + (and + file-attr + (or + ;; Not a symlink + (eq t (car file-attr)) + (null (car file-attr))) + (or + ;; World accessible. + (eq access (aref (nth 8 file-attr) (+ offset 6))) + ;; User accessible and owned by user. + (and + (eq access (aref (nth 8 file-attr) offset)) + (equal remote-uid (nth 2 file-attr))) + ;; Group accessible and owned by user's + ;; principal group. + (and + (eq access (aref (nth 8 file-attr) (+ offset 3))) + (equal remote-gid (nth 3 file-attr))))))))))) + +(defun tramp-file-mode-from-int (mode) + "Turn an integer representing a file mode into an ls(1)-like string." + (let ((type (cdr + (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) + (user (logand (lsh mode -6) 7)) + (group (logand (lsh mode -3) 7)) + (other (logand (lsh mode -0) 7)) + (suid (> (logand (lsh mode -9) 4) 0)) + (sgid (> (logand (lsh mode -9) 2) 0)) + (sticky (> (logand (lsh mode -9) 1) 0))) + (setq user (tramp-file-mode-permissions user suid "s")) + (setq group (tramp-file-mode-permissions group sgid "s")) + (setq other (tramp-file-mode-permissions other sticky "t")) + (concat type user group other))) + +(defun tramp-file-mode-permissions (perm suid suid-text) + "Convert a permission bitset into a string. +This is used internally by `tramp-file-mode-from-int'." + (let ((r (> (logand perm 4) 0)) + (w (> (logand perm 2) 0)) + (x (> (logand perm 1) 0))) + (concat (or (and r "r") "-") + (or (and w "w") "-") + (or (and suid x suid-text) ; suid, execute + (and suid (upcase suid-text)) ; suid, !execute + (and x "x") "-")))) ; !suid + +(defun tramp-shell-case-fold (string) + "Converts STRING to shell glob pattern which ignores case." + (mapconcat + (lambda (c) + (if (equal (downcase c) (upcase c)) + (vector c) + (format "[%c%c]" (downcase c) (upcase c)))) + string + "")) + +(defun tramp-make-copy-program-file-name (vec) + "Create a file name suitable to be passed to `rcp' and workalikes." + (let ((user (tramp-file-name-user vec)) + (host (tramp-file-name-real-host vec)) + (localname (tramp-shell-quote-argument + (tramp-file-name-localname vec)))) + (if (not (zerop (length user))) + (format "%s@%s:%s" user host localname) + (format "%s:%s" host localname)))) + +(defun tramp-method-out-of-band-p (vec size) + "Return t if this is an out-of-band method, nil otherwise." + (and + ;; It shall be an out-of-band method. + (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program) + ;; Either the file size is large enough, or (in rare cases) there + ;; does not exist a remote encoding. + (or (null tramp-copy-size-limit) + (> size tramp-copy-size-limit) + (null (tramp-get-inline-coding vec "remote-encoding" size))))) + +;; Variables local to connection. + +(defun tramp-get-remote-path (vec) + (with-connection-property + ;; When `tramp-own-remote-path' is in `tramp-remote-path', we + ;; cache the result for the session only. Otherwise, the result + ;; is cached persistently. + (if (memq 'tramp-own-remote-path tramp-remote-path) + (tramp-get-connection-process vec) + vec) + "remote-path" + (let* ((remote-path (copy-tree tramp-remote-path)) + (elt1 (memq 'tramp-default-remote-path remote-path)) + (elt2 (memq 'tramp-own-remote-path remote-path)) + (default-remote-path + (when elt1 + (condition-case nil + (tramp-send-command-and-read + vec "echo \\\"`getconf PATH`\\\"") + ;; Default if "getconf" is not available. + (error + (tramp-message + vec 3 + "`getconf PATH' not successful, using default value \"%s\"." + "/bin:/usr/bin") + "/bin:/usr/bin")))) + (own-remote-path + (when elt2 + (condition-case nil + (tramp-send-command-and-read vec "echo \\\"$PATH\\\"") + ;; Default if "getconf" is not available. + (error + (tramp-message + vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.") + nil))))) + + ;; Replace place holder `tramp-default-remote-path'. + (when elt1 + (setcdr elt1 + (append + (tramp-compat-split-string default-remote-path ":") + (cdr elt1))) + (setq remote-path (delq 'tramp-default-remote-path remote-path))) + + ;; Replace place holder `tramp-own-remote-path'. + (when elt2 + (setcdr elt2 + (append + (tramp-compat-split-string own-remote-path ":") + (cdr elt2))) + (setq remote-path (delq 'tramp-own-remote-path remote-path))) + + ;; Remove double entries. + (setq elt1 remote-path) + (while (consp elt1) + (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) + (setcar elt2 nil)) + (setq elt1 (cdr elt1))) + + ;; Remove non-existing directories. + (delq + nil + (mapcar + (lambda (x) + (and + (stringp x) + (file-directory-p + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + x)) + x)) + remote-path))))) + +(defun tramp-get-remote-tmpdir (vec) + (with-connection-property vec "tmp-directory" + (let ((dir (tramp-shell-quote-argument "/tmp"))) + (if (and (tramp-send-command-and-check + vec (format "%s -d %s" (tramp-get-test-command vec) dir)) + (tramp-send-command-and-check + vec (format "%s -w %s" (tramp-get-test-command vec) dir))) + dir + (tramp-error vec 'file-error "Directory %s not accessible" dir))))) + +(defun tramp-get-ls-command (vec) + (with-connection-property vec "ls" + (tramp-message vec 5 "Finding a suitable `ls' command") + (or + (catch 'ls-found + (dolist (cmd '("ls" "gnuls" "gls")) + (let ((dl (tramp-get-remote-path vec)) + result) + (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) + ;; Check parameters. On busybox, "ls" output coloring is + ;; enabled by default sometimes. So we try to disable it + ;; when possible. $LS_COLORING is not supported there. + ;; Some "ls" versions are sensible wrt the order of + ;; arguments, they fail when "-al" is after the + ;; "--color=never" argument (for example on FreeBSD). + (when (tramp-send-command-and-check + vec (format "%s -lnd /" result)) + (when (tramp-send-command-and-check + vec (format + "%s --color=never -al /dev/null" result)) + (setq result (concat result " --color=never"))) + (throw 'ls-found result)) + (setq dl (cdr dl)))))) + (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) + +(defun tramp-get-ls-command-with-dired (vec) + (save-match-data + (with-connection-property vec "ls-dired" + (tramp-message vec 5 "Checking, whether `ls --dired' works") + ;; Some "ls" versions are sensible wrt the order of arguments, + ;; they fail when "-al" is after the "--dired" argument (for + ;; example on FreeBSD). + (tramp-send-command-and-check + vec (format "%s --dired -al /dev/null" (tramp-get-ls-command vec)))))) + +(defun tramp-get-test-command (vec) + (with-connection-property vec "test" + (tramp-message vec 5 "Finding a suitable `test' command") + (if (tramp-send-command-and-check vec "test 0") + "test" + (tramp-find-executable vec "test" (tramp-get-remote-path vec))))) + +(defun tramp-get-test-nt-command (vec) + ;; Does `test A -nt B' work? Use abominable `find' construct if it + ;; doesn't. BSD/OS 4.0 wants the parentheses around the command, + ;; for otherwise the shell crashes. + (with-connection-property vec "test-nt" + (or + (progn + (tramp-send-command + vec (format "( %s / -nt / )" (tramp-get-test-command vec))) + (with-current-buffer (tramp-get-buffer vec) + (goto-char (point-min)) + (when (looking-at (regexp-quote tramp-end-of-output)) + (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) + (progn + (tramp-send-command + vec + (format + "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}" + (tramp-get-test-command vec))) + "tramp_test_nt %s %s")))) + +(defun tramp-get-file-exists-command (vec) + (with-connection-property vec "file-exists" + (tramp-message vec 5 "Finding command to check if file exists") + (tramp-find-file-exists-command vec))) + +(defun tramp-get-remote-ln (vec) + (with-connection-property vec "ln" + (tramp-message vec 5 "Finding a suitable `ln' command") + (tramp-find-executable vec "ln" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-perl (vec) + (with-connection-property vec "perl" + (tramp-message vec 5 "Finding a suitable `perl' command") + (let ((result + (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec)) + (tramp-find-executable + vec "perl" (tramp-get-remote-path vec))))) + ;; We must check also for some Perl modules. + (when result + (with-connection-property vec "perl-file-spec" + (tramp-send-command-and-check + vec (format "%s -e 'use File::Spec;'" result))) + (with-connection-property vec "perl-cwd-realpath" + (tramp-send-command-and-check + vec (format "%s -e 'use Cwd \"realpath\";'" result)))) + result))) + +(defun tramp-get-remote-stat (vec) + (with-connection-property vec "stat" + (tramp-message vec 5 "Finding a suitable `stat' command") + (let ((result (tramp-find-executable + vec "stat" (tramp-get-remote-path vec))) + tmp) + ;; Check whether stat(1) returns usable syntax. %s does not + ;; work on older AIX systems. + (when result + (setq tmp + ;; We don't want to display an error message. + (tramp-compat-with-temp-message (or (current-message) "") + (ignore-errors + (tramp-send-command-and-read + vec (format "%s -c '(\"%%N\" %%s)' /" result))))) + (unless (and (listp tmp) (stringp (car tmp)) + (string-match "^./.$" (car tmp)) + (integerp (cadr tmp))) + (setq result nil))) + result))) + +(defun tramp-get-remote-readlink (vec) + (with-connection-property vec "readlink" + (tramp-message vec 5 "Finding a suitable `readlink' command") + (let ((result (tramp-find-executable + vec "readlink" (tramp-get-remote-path vec)))) + (when (and result + ;; We don't want to display an error message. + (tramp-compat-with-temp-message (or (current-message) "") + (ignore-errors + (tramp-send-command-and-check + vec (format "%s --canonicalize-missing /" result))))) + result)))) + +(defun tramp-get-remote-trash (vec) + (with-connection-property vec "trash" + (tramp-message vec 5 "Finding a suitable `trash' command") + (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-id (vec) + (with-connection-property vec "id" + (tramp-message vec 5 "Finding POSIX `id' command") + (or + (catch 'id-found + (let ((dl (tramp-get-remote-path vec)) + result) + (while (and dl (setq result (tramp-find-executable vec "id" dl t t))) + ;; Check POSIX parameter. + (when (tramp-send-command-and-check vec (format "%s -u" result)) + (throw 'id-found result)) + (setq dl (cdr dl))))) + (tramp-error vec 'file-error "Couldn't find a POSIX `id' command")))) + +(defun tramp-get-remote-uid (vec id-format) + (with-connection-property vec (format "uid-%s" id-format) + (let ((res (tramp-send-command-and-read + vec + (format "%s -u%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) + ;; The command might not always return a number. + (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) + +(defun tramp-get-remote-gid (vec id-format) + (with-connection-property vec (format "gid-%s" id-format) + (let ((res (tramp-send-command-and-read + vec + (format "%s -g%s %s" + (tramp-get-remote-id vec) + (if (equal id-format 'integer) "" "n") + (if (equal id-format 'integer) + "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) + ;; The command might not always return a number. + (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) + +(defun tramp-get-local-uid (id-format) + (if (equal id-format 'integer) (user-uid) (user-login-name))) + +(defun tramp-get-local-gid (id-format) + (nth 3 (tramp-compat-file-attributes "~/" id-format))) + +;; Some predefined connection properties. +(defun tramp-get-inline-compress (vec prop size) + "Return the compress command related to PROP. +PROP is either `inline-compress' or `inline-decompress'. SIZE is +the length of the file to be compressed. + +If no corresponding command is found, nil is returned." + (when (and (integerp tramp-inline-compress-start-size) + (> size tramp-inline-compress-start-size)) + (with-connection-property vec prop + (tramp-find-inline-compress vec) + (tramp-get-connection-property vec prop nil)))) + +(defun tramp-get-inline-coding (vec prop size) + "Return the coding command related to PROP. +PROP is either `remote-encoding', `remode-decoding', +`local-encoding' or `local-decoding'. + +SIZE is the length of the file to be coded. Depending on SIZE, +compression might be applied. + +If no corresponding command is found, nil is returned. +Otherwise, either a string is returned which contains a `%s' mark +to be used for the respective input or output file; or a Lisp +function cell is returned to be applied on a buffer." + ;; We must catch the errors, because we want to return `nil', when + ;; no inline coding is found. + (ignore-errors + (let ((coding + (with-connection-property vec prop + (tramp-find-inline-encoding vec) + (tramp-get-connection-property vec prop nil))) + (prop1 (if (string-match "encoding" prop) + "inline-compress" "inline-decompress")) + compress) + ;; The connection property might have been cached. So we must + ;; send the script to the remote side - maybe. + (when (and coding (symbolp coding) (string-match "remote" prop)) + (let ((name (symbol-name coding))) + (while (string-match (regexp-quote "-") name) + (setq name (replace-match "_" nil t name))) + (tramp-maybe-send-script vec (symbol-value coding) name) + (setq coding name))) + (when coding + ;; Check for the `compress' command. + (setq compress (tramp-get-inline-compress vec prop1 size)) + ;; Return the value. + (cond + ((and compress (symbolp coding)) + (if (string-match "decompress" prop1) + `(lambda (beg end) + (,coding beg end) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (apply + 'call-process-region (point-min) (point-max) + (car (split-string ,compress)) t t nil + (cdr (split-string ,compress))))) + `(lambda (beg end) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (apply + 'call-process-region beg end + (car (split-string ,compress)) t t nil + (cdr (split-string ,compress)))) + (,coding (point-min) (point-max))))) + ((symbolp coding) + coding) + ((and compress (string-match "decoding" prop)) + (format "(%s | %s >%%s)" coding compress)) + (compress + (format "(%s <%%s | %s)" compress coding)) + ((string-match "decoding" prop) + (format "%s >%%s" coding)) + (t + (format "%s <%%s" coding))))))) + +;;; Integration of eshell.el: + +(eval-when-compile + (defvar eshell-path-env)) + +;; eshell.el keeps the path in `eshell-path-env'. We must change it +;; when `default-directory' points to another host. +(defun tramp-eshell-directory-change () + "Set `eshell-path-env' to $PATH of the host related to `default-directory'." + (setq eshell-path-env + (if (file-remote-p default-directory) + (with-parsed-tramp-file-name default-directory nil + (mapconcat + 'identity + (tramp-get-remote-path v) + ":")) + (getenv "PATH")))) + +(eval-after-load "esh-util" + '(progn + (tramp-eshell-directory-change) + (add-hook 'eshell-directory-change-hook + 'tramp-eshell-directory-change) + (add-hook 'tramp-unload-hook + (lambda () + (remove-hook 'eshell-directory-change-hook + 'tramp-eshell-directory-change))))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-sh 'force))) + +(provide 'tramp-sh) + +;;; TODO: + +;; * Don't use globbing for directories with many files, as this is +;; likely to produce long command lines, and some shells choke on +;; long command lines. +;; * Make it work for different encodings, and for different file name +;; encodings, too. (Daniel Pittman) +;; * Don't search for perl5 and perl. Instead, only search for perl and +;; then look if it's the right version (with `perl -v'). +;; * When editing a remote CVS controlled file as a different user, VC +;; gets confused about the file locking status. Try to find out why +;; the workaround doesn't work. +;; * Allow out-of-band methods as _last_ multi-hop. Open a connection +;; until the last but one hop via `start-file-process'. Apply it +;; also for ftp and smb. +;; * WIBNI if we had a command "trampclient"? If I was editing in +;; some shell with root priviledges, it would be nice if I could +;; just call +;; trampclient filename.c +;; as an editor, and the _current_ shell would connect to an Emacs +;; server and would be used in an existing non-priviledged Emacs +;; session for doing the editing in question. +;; That way, I need not tell Emacs my password again and be afraid +;; that it makes it into core dumps or other ugly stuff (I had Emacs +;; once display a just typed password in the context of a keyboard +;; sequence prompt for a question immediately following in a shell +;; script run within Emacs -- nasty). +;; And if I have some ssh session running to a different computer, +;; having the possibility of passing a local file there to a local +;; Emacs session (in case I can arrange for a connection back) would +;; be nice. +;; Likely the corresponding Tramp server should not allow the +;; equivalent of the emacsclient -eval option in order to make this +;; reasonably unproblematic. And maybe trampclient should have some +;; way of passing credentials, like by using an SSL socket or +;; something. (David Kastrup) +;; * Reconnect directly to a compliant shell without first going +;; through the user's default shell. (Pete Forman) +;; * How can I interrupt the remote process with a signal +;; (interrupt-process seems not to work)? (Markus Triska) +;; * Avoid the local shell entirely for starting remote processes. If +;; so, I think even a signal, when delivered directly to the local +;; SSH instance, would correctly be propagated to the remote process +;; automatically; possibly SSH would have to be started with +;; "-t". (Markus Triska) +;; * It makes me wonder if tramp couldn't fall back to ssh when scp +;; isn't on the remote host. (Mark A. Hershberger) +;; * Use lsh instead of ssh. (Alfred M. Szmidt) +;; * Optimize out-of-band copying, when both methods are scp-like (not +;; rsync). +;; * Keep a second connection open for out-of-band methods like scp or +;; rsync. +;; * Try telnet+curl as new method. It might be useful for busybox, +;; without built-in uuencode/uudecode. + +;;; tramp-sh.el ends here diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index 5e62bc45da3..98b39ed2e50 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -5,6 +5,7 @@ ;; Author: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -29,27 +30,28 @@ (eval-when-compile (require 'cl)) ; block, return (require 'tramp) -(require 'tramp-cache) -(require 'tramp-compat) ;; Define SMB method ... -(defcustom tramp-smb-method "smb" - "*Method to connect SAMBA and M$ SMB servers." - :group 'tramp - :type 'string) +;;;###tramp-autoload +(defconst tramp-smb-method "smb" + "*Method to connect SAMBA and M$ SMB servers.") ;; ... and add it to the method list. -(add-to-list 'tramp-methods (cons tramp-smb-method nil)) +;;;###tramp-autoload +(unless (memq system-type '(cygwin windows-nt)) + (add-to-list 'tramp-methods (cons tramp-smb-method nil))) ;; Add a default for `tramp-default-method-alist'. Rule: If there is ;; a domain in USER, it must be the SMB method. +;;;###tramp-autoload (add-to-list 'tramp-default-method-alist `(nil ,tramp-prefix-domain-regexp ,tramp-smb-method)) ;; Add a default for `tramp-default-user-alist'. Rule: For the SMB method, ;; the anonymous user is chosen. +;;;###tramp-autoload (add-to-list 'tramp-default-user-alist - `(,tramp-smb-method nil "")) + `(,(concat "\\`" tramp-smb-method "\\'") nil nil)) ;; Add completion function for SMB method. (tramp-set-completion-function @@ -153,7 +155,7 @@ See `tramp-actions-before-shell' for more info.") (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) + . tramp-handle-directory-files-and-attributes) (dired-call-process . ignore) (dired-compress-file . ignore) (dired-uncache . tramp-handle-dired-uncache) @@ -161,8 +163,8 @@ See `tramp-actions-before-shell' for more info.") (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) - (file-executable-p . tramp-smb-handle-file-exists-p) - (file-exists-p . tramp-smb-handle-file-exists-p) + (file-executable-p . tramp-handle-file-exists-p) + (file-exists-p . tramp-handle-file-exists-p) (file-local-copy . tramp-smb-handle-file-local-copy) (file-modes . tramp-handle-file-modes) (file-name-all-completions . tramp-smb-handle-file-name-all-completions) @@ -171,9 +173,9 @@ See `tramp-actions-before-shell' for more info.") (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-newer-than-file-p . tramp-smb-handle-file-newer-than-file-p) + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) (file-ownership-preserved-p . ignore) - (file-readable-p . tramp-smb-handle-file-exists-p) + (file-readable-p . tramp-handle-file-exists-p) (file-regular-p . tramp-handle-file-regular-p) (file-remote-p . tramp-handle-file-remote-p) ;; `file-selinux-context' performed by default handler. @@ -204,11 +206,13 @@ See `tramp-actions-before-shell' for more info.") "Alist of handler functions for Tramp SMB method. Operations not mentioned here will be handled by the default Emacs primitives.") -(defun tramp-smb-file-name-p (filename) +;;;###tramp-autoload +(defsubst tramp-smb-file-name-p (filename) "Check if it's a filename for SMB servers." (let ((v (tramp-dissect-file-name filename))) (string= (tramp-file-name-method v) tramp-smb-method))) +;;;###tramp-autoload (defun tramp-smb-file-name-handler (operation &rest args) "Invoke the SMB related OPERATION. First arg specifies the OPERATION, second arg is a list of arguments to @@ -218,8 +222,10 @@ pass to the OPERATION." (save-match-data (apply (cdr fn) args)) (tramp-run-real-handler operation args)))) -(add-to-list 'tramp-foreign-file-name-handler-alist - (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler)) +;;;###tramp-autoload +(unless (memq system-type '(cygwin windows-nt)) + (add-to-list 'tramp-foreign-file-name-handler-alist + (cons 'tramp-smb-file-name-p 'tramp-smb-file-name-handler))) ;; File name primitives. @@ -447,15 +453,6 @@ PRESERVE-UID-GID is completely ignored." ;; That's it. result)) -(defun tramp-smb-handle-directory-files-and-attributes - (directory &optional full match nosort id-format) - "Like `directory-files-and-attributes' for Tramp files." - (mapcar - (lambda (x) - (cons x (tramp-compat-file-attributes - (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 "/". @@ -593,10 +590,6 @@ PRESERVE-UID-GID is completely ignored." (and (file-exists-p filename) (eq ?d (aref (nth 8 (file-attributes filename)) 0)))) -(defun tramp-smb-handle-file-exists-p (filename) - "Like `file-exists-p' for Tramp files." - (not (null (file-attributes filename)))) - (defun tramp-smb-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." (with-parsed-tramp-file-name filename nil @@ -634,14 +627,6 @@ PRESERVE-UID-GID is completely ignored." (nth 0 x)))) entries))))))) -(defun tramp-smb-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond - ((not (file-exists-p file1)) nil) - ((not (file-exists-p file2)) t) - (t (tramp-time-less-p (nth 5 (file-attributes file2)) - (nth 5 (file-attributes file1)))))) - (defun tramp-smb-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." (if (file-exists-p filename) @@ -783,7 +768,7 @@ PRESERVE-UID-GID is completely ignored." (if (tramp-smb-get-cifs-capabilities v) (format "posix_mkdir \"%s\" %s" - file (tramp-decimal-to-octal (default-file-modes))) + file (tramp-compat-decimal-to-octal (default-file-modes))) (format "mkdir \"%s\"" file))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. @@ -892,7 +877,7 @@ target of the symlink differ." (unless (tramp-smb-send-command v (format "chmod \"%s\" %s" (tramp-smb-get-localname v) - (tramp-decimal-to-octal mode))) + (tramp-compat-decimal-to-octal mode))) (tramp-error v 'file-error "Error while changing file's mode %s" filename))))) @@ -1096,7 +1081,7 @@ If SHARE is result, entries are of type dir. Otherwise, shares are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; We are called from `tramp-smb-get-file-entries', which sets the ;; current buffer. - (let ((line (buffer-substring (point) (tramp-compat-line-end-position))) + (let ((line (buffer-substring (point) (point-at-eol))) localname mode size month day hour min sec year mtime) (if (not share) @@ -1194,8 +1179,7 @@ Result is the list (LOCALNAME MODE SIZE MTIME)." (member "pathnames" (split-string - (buffer-substring - (point) (tramp-compat-line-end-position)) nil t))))))))) + (buffer-substring (point) (point-at-eol)) nil t))))))))) (defun tramp-smb-get-stat-capability (vec) "Check, whether the SMB server supports the STAT command." @@ -1319,7 +1303,7 @@ connection if a previous connection has died for some reason." (tramp-message vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-process-query-on-exit-flag p nil) + (tramp-compat-set-process-query-on-exit-flag p nil) ;; Set variables for computing the prompt for reading password. (setq tramp-current-method tramp-smb-method @@ -1396,6 +1380,9 @@ Returns nil if an error message has appeared." (tramp-message vec 6 "\n%s" (buffer-string)) (not err)))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-smb 'force))) (provide 'tramp-smb) @@ -1410,5 +1397,4 @@ Returns nil if an error message has appeared." ;; regular again. ;; * Make it multi-hop capable. -;; arch-tag: fcc9dbec-7503-4d73-b638-3c8aa59575f5 ;;; tramp-smb.el ends here diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el index 16b46017727..89947ae761d 100644 --- a/lisp/net/tramp-uu.el +++ b/lisp/net/tramp-uu.el @@ -5,6 +5,7 @@ ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Keywords: comm, terminals +;; Package: tramp ;; This file is part of GNU Emacs. @@ -49,6 +50,7 @@ "Return the byte that is encoded as CHAR." (cdr (assq char tramp-uu-b64-char-to-byte))) +;;;###tramp-autoload (defun tramp-uuencode-region (beg end) "UU-encode the region between BEG and END." ;; First we base64 encode the region, then we transmogrify that into @@ -86,6 +88,10 @@ (goto-char beg) (insert "begin 600 xxx\n")))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-uu 'force))) + (provide 'tramp-uu) ;; arch-tag: 7153f2c6-8be5-4cd2-8c06-0fbcf5190ef6 diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 0ac5048ef3b..cd9ef314acc 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -3,11 +3,10 @@ ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, ;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. -;; (copyright statements below in code to be updated with the above notice) - ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -59,117 +58,7 @@ ;;; Code: -;; Since Emacs 23.1, loading messages have been disabled during -;; autoload. However, loading Tramp takes a while, and it could -;; happen while typing a filename in the minibuffer. Therefore, Tramp -;; shall inform about. -(when (and load-in-progress (null (current-message))) - (message "Loading tramp...")) - -;; The Tramp version number and bug report address, as prepared by configure. -(require 'trampver) -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'trampver) - (unload-feature 'trampver 'force)))) - (require 'tramp-compat) -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'tramp-compat) - (unload-feature 'tramp-compat 'force)))) - -(require 'format-spec) -;; As long as password.el is not part of (X)Emacs, it shouldn't -;; be mandatory -(if (featurep 'xemacs) - (load "password" 'noerror) - (or (require 'password-cache nil 'noerror) - (require 'password nil 'noerror))) ; from No Gnus, also in tar ball - -(require 'shell) -(require 'advice) - -(eval-and-compile - (if (featurep 'xemacs) - (load "auth-source" 'noerror) - (require 'auth-source nil 'noerror))) - -;; Requiring 'tramp-cache results in an endless loop. -(autoload 'tramp-get-file-property "tramp-cache") -(autoload 'tramp-set-file-property "tramp-cache") -(autoload 'tramp-flush-file-property "tramp-cache") -(autoload 'tramp-flush-directory-property "tramp-cache") -(autoload 'tramp-get-connection-property "tramp-cache") -(autoload 'tramp-set-connection-property "tramp-cache") -(autoload 'tramp-flush-connection-property "tramp-cache") -(autoload 'tramp-parse-connection-properties "tramp-cache") -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'tramp-cache) - (unload-feature 'tramp-cache 'force)))) - -(autoload 'tramp-uuencode-region "tramp-uu" - "Implementation of `uuencode' in Lisp.") -(add-hook 'tramp-unload-hook - (lambda () - (when (featurep 'tramp-uu) - (unload-feature 'tramp-uu 'force)))) - -(autoload 'uudecode-decode-region "uudecode") - -;; The following Tramp packages must be loaded after tramp.el, because -;; they require it as well. -(eval-after-load "tramp" - '(dolist - (feature - (list - - ;; Tramp interactive commands. - 'tramp-cmds - - ;; Load foreign FTP method. - (if (featurep 'xemacs) 'tramp-efs 'tramp-ftp) - - ;; tramp-smb uses "smbclient" from Samba. Not available - ;; under Cygwin and Windows, because they don't offer - ;; "smbclient". And even not necessary there, because Emacs - ;; supports UNC file names like "//host/share/localname". - (unless (memq system-type '(cygwin windows-nt)) 'tramp-smb) - - ;; Load foreign FISH method. - 'tramp-fish - - ;; tramp-gvfs needs D-Bus messages. Available since Emacs 23 - ;; on some system types. We don't call `dbus-ping', because - ;; this would load dbus.el. - (when (and (featurep 'dbusbind) - (condition-case nil - (tramp-compat-funcall 'dbus-get-unique-name :session) - (error nil)) - (tramp-compat-process-running-p "gvfs-fuse-daemon")) - 'tramp-gvfs) - - ;; Load gateways. It needs `make-network-process' from Emacs 22. - (when (functionp 'make-network-process) 'tramp-gw) - - ;; tramp-imap needs both epa (from Emacs 23.1) and imap-hash - ;; (from Emacs 23.2). - (when (and (locate-library "epa") (locate-library "imap-hash")) - 'tramp-imap))) - - (when feature - ;; We have used just some basic tests, whether a package shall - ;; be added. There might still be other errors during loading, - ;; which we will catch here. - (catch 'tramp-loading - (require feature) - (add-hook 'tramp-unload-hook - `(lambda () - (when (featurep (quote ,feature)) - (unload-feature (quote ,feature) 'force))))) - (unless (featurep feature) - (message "Loading %s failed, ignoring this package" feature))))) ;;; User Customizable Internal Variables: @@ -286,386 +175,8 @@ See the variable `tramp-encoding-shell' for more information." :group 'tramp :type 'string) -(defcustom tramp-inline-compress-start-size 4096 - "*The minimum size of compressing where inline transfer. -When inline transfer, compress transfered data of file -whose size is this value or above (up to `tramp-copy-size-limit'). -If it is nil, no compression at all will be applied." - :group 'tramp - :type '(choice (const nil) integer)) - -(defcustom tramp-copy-size-limit 10240 - "*The maximum file size where inline copying is preferred over an out-of-the-band copy. -If it is nil, inline out-of-the-band copy will be used without a check." - :group 'tramp - :type '(choice (const nil) integer)) - -(defcustom tramp-terminal-type "dumb" - "*Value of TERM environment variable for logging in to remote host. -Because Tramp wants to parse the output of the remote shell, it is easily -confused by ANSI color escape sequences and suchlike. Often, shell init -files conditionalize this setup based on the TERM environment variable." - :group 'tramp - :type 'string) - -;; ksh on OpenBSD 4.5 requires, that PS1 contains a `#' character for -;; root users. It uses the `$' character for other users. In order -;; to guarantee a proper prompt, we use "#$" for the prompt. - -(defvar tramp-end-of-output - (format - "///%s#$" - (md5 (concat (prin1-to-string process-environment) (current-time-string)))) - "String used to recognize end of output. -The '$' character at the end is quoted; the string cannot be -detected as prompt when being sent on echoing hosts, therefore.") - -(defconst tramp-initial-end-of-output "#$ " - "Prompt when establishing a connection.") - -(defvar tramp-methods - `(("rcp" (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("scp" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scp1" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-1") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-1") ("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scp2" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-2") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-2") ("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scp1_old" - (tramp-login-program "ssh1") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp1") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("scp2_old" - (tramp-login-program "ssh2") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp2") - (tramp-copy-args (("-p" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("sftp" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "sftp") - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("rsync" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rsync") - (tramp-copy-args (("-e" "ssh") ("-t" "%k") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-keep-tmpfile t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("rsyncc" - (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-o" "ControlPath=%t.%%r@%%h:%%p") - ("-o" "ControlMaster=yes") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rsync") - (tramp-copy-args (("-t" "%k") ("-r"))) - (tramp-copy-env (("RSYNC_RSH") - (,(concat - "ssh" - " -o ControlPath=%t.%%r@%%h:%%p" - " -o ControlMaster=auto")))) - (tramp-copy-keep-date t) - (tramp-copy-keep-tmpfile t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil)) - ("remcp" (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "rcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line nil)) - ("rsh" (tramp-login-program "rsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("ssh" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("ssh1" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-1") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("ssh2" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-2") ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("ssh1_old" - (tramp-login-program "ssh1") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("ssh2_old" - (tramp-login-program "ssh2") - (tramp-login-args (("%h") ("-l" "%u") ("-p" "%p") - ("-e" "none"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("remsh" (tramp-login-program "remsh") - (tramp-login-args (("%h") ("-l" "%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("telnet" - (tramp-login-program "telnet") - (tramp-login-args (("%h") ("%p"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-default-port 23)) - ("su" (tramp-login-program "su") - (tramp-login-args (("-") ("%u"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("sudo" (tramp-login-program "sudo") - (tramp-login-args (("-u" "%u") - ("-s") ("-H") ("-p" "Password:"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("scpc" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-o" "ControlPath=%t.%%r@%%h:%%p") - ("-o" "ControlMaster=yes") - ("-e" "none") ("%h"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") ("-q") ("-r") - ("-o" "ControlPath=%t.%%r@%%h:%%p") - ("-o" "ControlMaster=auto"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("scpx" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("-t" "-t") - ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "scp") - (tramp-copy-args (("-P" "%p") ("-p" "%k") - ("-q") ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("sshx" (tramp-login-program "ssh") - (tramp-login-args (("-l" "%u") ("-p" "%p") - ("-e" "none") ("-t" "-t") - ("%h") ("/bin/sh"))) - (tramp-async-args (("-q"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil) - (tramp-gw-args (("-o" - "GlobalKnownHostsFile=/dev/null") - ("-o" "UserKnownHostsFile=/dev/null") - ("-o" "StrictHostKeyChecking=no"))) - (tramp-default-port 22)) - ("krlogin" - (tramp-login-program "krlogin") - (tramp-login-args (("%h") ("-l" "%u") ("-x"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("plink" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line "xy") ;see docstring for "xy" - (tramp-default-port 22)) - ("plink1" - (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-1" "-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line "xy") ;see docstring for "xy" - (tramp-default-port 22)) - ("plinkx" - (tramp-login-program "plink") - ;; ("%h") must be a single element, see - ;; `tramp-compute-multi-hops'. - (tramp-login-args (("-load") ("%h") ("-t") - (,(format - "env 'TERM=%s' 'PROMPT_COMMAND=' 'PS1=%s'" - tramp-terminal-type - tramp-initial-end-of-output)) - ("/bin/sh"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program nil) - (tramp-copy-args nil) - (tramp-copy-keep-date nil) - (tramp-password-end-of-line nil)) - ("pscp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "pscp") - (tramp-copy-args (("-P" "%p") ("-scp") ("-p" "%k") - ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line "xy") ;see docstring for "xy" - (tramp-default-port 22)) - ("psftp" (tramp-login-program "plink") - (tramp-login-args (("-l" "%u") ("-P" "%p") - ("-ssh") ("%h"))) - (tramp-remote-sh "/bin/sh") - (tramp-copy-program "pscp") - (tramp-copy-args (("-P" "%p") ("-sftp") ("-p" "%k") - ("-r"))) - (tramp-copy-keep-date t) - (tramp-copy-recursive t) - (tramp-password-end-of-line "xy")) ;see docstring for "xy" - ("fcp" (tramp-login-program "fsh") - (tramp-login-args (("%h") ("-l" "%u") ("sh" "-i"))) - (tramp-remote-sh "/bin/sh -i") - (tramp-copy-program "fcp") - (tramp-copy-args (("-p" "%k"))) - (tramp-copy-keep-date t) - (tramp-password-end-of-line nil))) +;;;###tramp-autoload +(defvar tramp-methods nil "*Alist of methods for remote files. This is a list of entries of the form (NAME PARAM1 PARAM2 ...). Each NAME stands for a remote access method. Each PARAM is a @@ -807,8 +318,8 @@ Also see `tramp-default-method-alist'." :group 'tramp :type 'string) -(defcustom tramp-default-method-alist - '(("\\`localhost\\'" "\\`root\\'" "su")) +;;;###tramp-autoload +(defcustom tramp-default-method-alist nil "*Default method to use for specific host/user pairs. This is an alist of items (HOST USER METHOD). The first matching item specifies the method to use for a file name which does not specify a @@ -825,8 +336,7 @@ See `tramp-methods' for a list of possibilities for METHOD." (choice :tag "User regexp" regexp sexp) (choice :tag "Method name" string (const nil))))) -(defcustom tramp-default-user - nil +(defcustom tramp-default-user nil "*Default user to use for transferring files. It is nil by default; otherwise settings in configuration files like \"~/.ssh/config\" would be overwritten. Also see `tramp-default-user-alist'. @@ -835,10 +345,8 @@ This variable is regarded as obsolete, and will be removed soon." :group 'tramp :type '(choice (const nil) string)) -(defcustom tramp-default-user-alist - `(("\\`su\\(do\\)?\\'" nil "root") - ("\\`r\\(em\\)?\\(cp\\|sh\\)\\|telnet\\|plink1?\\'" - nil ,(user-login-name))) +;;;###tramp-autoload +(defcustom tramp-default-user-alist nil "*Default user to use for specific method/host pairs. This is an alist of items (METHOD HOST USER). The first matching item specifies the user to use for a file name which does not specify a @@ -853,8 +361,7 @@ empty string for the method name." (choice :tag " Host regexp" regexp sexp) (choice :tag " User name" string (const nil))))) -(defcustom tramp-default-host - (system-name) +(defcustom tramp-default-host (system-name) "*Default host to use for transferring files. Useful for su and sudo methods mostly." :group 'tramp @@ -879,44 +386,15 @@ interpreted as a regular expression which always matches." (choice :tag "User regexp" regexp sexp) (choice :tag " Proxy name" string (const nil))))) +;;;###tramp-autoload (defconst tramp-local-host-regexp (concat - "^" (regexp-opt (list "localhost" (system-name) "127\.0\.0\.1" "::1") t) "$") + "\\`" + (regexp-opt + (list "localhost" "localhost6" (system-name) "127\.0\.0\.1" "::1") t) + "\\'") "*Host names which are regarded as local host.") -(defconst tramp-completion-function-alist-rsh - '((tramp-parse-rhosts "/etc/hosts.equiv") - (tramp-parse-rhosts "~/.rhosts")) - "Default list of (FUNCTION FILE) pairs to be examined for rsh methods.") - -(defconst tramp-completion-function-alist-ssh - '((tramp-parse-rhosts "/etc/hosts.equiv") - (tramp-parse-rhosts "/etc/shosts.equiv") - (tramp-parse-shosts "/etc/ssh_known_hosts") - (tramp-parse-sconfig "/etc/ssh_config") - (tramp-parse-shostkeys "/etc/ssh2/hostkeys") - (tramp-parse-sknownhosts "/etc/ssh2/knownhosts") - (tramp-parse-rhosts "~/.rhosts") - (tramp-parse-rhosts "~/.shosts") - (tramp-parse-shosts "~/.ssh/known_hosts") - (tramp-parse-sconfig "~/.ssh/config") - (tramp-parse-shostkeys "~/.ssh2/hostkeys") - (tramp-parse-sknownhosts "~/.ssh2/knownhosts")) - "Default list of (FUNCTION FILE) pairs to be examined for ssh methods.") - -(defconst tramp-completion-function-alist-telnet - '((tramp-parse-hosts "/etc/hosts")) - "Default list of (FUNCTION FILE) pairs to be examined for telnet methods.") - -(defconst tramp-completion-function-alist-su - '((tramp-parse-passwd "/etc/passwd")) - "Default list of (FUNCTION FILE) pairs to be examined for su methods.") - -(defconst tramp-completion-function-alist-putty - '((tramp-parse-putty - "HKEY_CURRENT_USER\\Software\\SimonTatham\\PuTTY\\Sessions")) - "Default list of (FUNCTION REGISTRY) pairs to be examined for putty methods.") - (defvar tramp-completion-function-alist nil "*Alist of methods for remote files. This is a list of entries of the form \(NAME PAIR1 PAIR2 ...\). @@ -937,63 +415,6 @@ names from FILE for completion. The following predefined FUNCTIONs exists: FUNCTION can also be a customer defined function. For more details see the info pages.") -(eval-after-load "tramp" - '(progn - (tramp-set-completion-function - "rcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "scp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp1" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp2" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp1_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "scp2_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "rsync" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "rsyncc" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "remcp" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "rsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "ssh" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh1" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh2" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh1_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "ssh2_old" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "remsh" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "telnet" tramp-completion-function-alist-telnet) - (tramp-set-completion-function - "su" tramp-completion-function-alist-su) - (tramp-set-completion-function - "sudo" tramp-completion-function-alist-su) - (tramp-set-completion-function - "scpx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "sshx" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "krlogin" tramp-completion-function-alist-rsh) - (tramp-set-completion-function - "plink" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "plink1" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "plinkx" tramp-completion-function-alist-putty) - (tramp-set-completion-function - "pscp" tramp-completion-function-alist-ssh) - (tramp-set-completion-function - "fcp" tramp-completion-function-alist-ssh))) - (defconst tramp-echo-mark-marker "_echo" "String marker to surround echoed commands.") @@ -1042,55 +463,6 @@ The default value is to use the same value as `tramp-rsh-end-of-line'." :group 'tramp :type 'string) -;; "getconf PATH" yields: -;; HP-UX: /usr/bin:/usr/ccs/bin:/opt/ansic/bin:/opt/langtools/bin:/opt/fortran/bin -;; Solaris: /usr/xpg4/bin:/usr/ccs/bin:/usr/bin:/opt/SUNWspro/bin -;; GNU/Linux (Debian, Suse): /bin:/usr/bin -;; FreeBSD: /usr/bin:/bin:/usr/sbin:/sbin: - beware trailing ":"! -;; IRIX64: /usr/bin -(defcustom tramp-remote-path - '(tramp-default-remote-path "/usr/sbin" "/usr/local/bin" - "/local/bin" "/local/freeware/bin" "/local/gnu/bin" - "/usr/freeware/bin" "/usr/pkg/bin" "/usr/contrib/bin") - "*List of directories to search for executables on remote host. -For every remote host, this variable will be set buffer local, -keeping the list of existing directories on that host. - -You can use `~' in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with `~' will be ignored. - -`Default Directories' represent the list of directories given by -the command \"getconf PATH\". It is recommended to use this -entry on top of this list, because these are the default -directories for POSIX compatible commands. - -`Private Directories' are the settings of the $PATH environment, -as given in your `~/.profile'." - :group 'tramp - :type '(repeat (choice - (const :tag "Default Directories" tramp-default-remote-path) - (const :tag "Private Directories" tramp-own-remote-path) - (string :tag "Directory")))) - -(defcustom tramp-remote-process-environment - `("HISTFILE=$HOME/.tramp_history" "HISTSIZE=1" "LC_ALL=C" - ,(format "TERM=%s" tramp-terminal-type) - "EMACS=t" ;; Deprecated. - ,(format "INSIDE_EMACS='%s,tramp:%s'" emacs-version tramp-version) - "CDPATH=" "HISTORY=" "MAIL=" "MAILCHECK=" "MAILPATH=" - "autocorrect=" "correct=") - - "*List of environment variables to be set on the remote host. - -Each element should be a string of the form ENVVARNAME=VALUE. An -entry ENVVARNAME= diables the corresponding environment variable, -which might have been set in the init files like ~/.profile. - -Special handling is applied to the PATH environment, which should -not be set here. Instead of, it should be set via `tramp-remote-path'." - :group 'tramp - :type '(repeat string)) - (defcustom tramp-login-prompt-regexp ".*ogin\\( .*\\)?: *" "*Regexp matching login-like prompts. @@ -1218,15 +590,13 @@ The answer will be provided by `tramp-action-process-alive', :group 'tramp :type 'regexp) -(defcustom tramp-temp-name-prefix "tramp." +(defconst tramp-temp-name-prefix "tramp." "*Prefix to use for temporary files. If this is a relative file name (such as \"tramp.\"), it is considered relative to the directory name returned by the function `tramp-compat-temporary-file-directory' (which see). It may also be an absolute file name; don't forget to include a prefix for the filename -part, though." - :group 'tramp - :type 'string) +part, though.") (defconst tramp-temp-buffer-name " *tramp temp*" "Buffer name for a temporary buffer. @@ -1236,22 +606,7 @@ It shall be used in combination with `generate-new-buffer-name'.") "File name of a persistent local temporary file. Useful for \"rsync\" like methods.") (make-variable-buffer-local 'tramp-temp-buffer-file-name) - -(defcustom tramp-sh-extra-args '(("/bash\\'" . "-norc -noprofile")) - "*Alist specifying extra arguments to pass to the remote shell. -Entries are (REGEXP . ARGS) where REGEXP is a regular expression -matching the shell file name and ARGS is a string specifying the -arguments. - -This variable is only used when Tramp needs to start up another shell -for tilde expansion. The extra arguments should typically prevent the -shell from reading its init file." - :group 'tramp - ;; This might be the wrong way to test whether the widget type - ;; `alist' is available. Who knows the right way to test it? - :type (if (get 'alist 'widget-type) - '(alist :key-type string :value-type string) - '(repeat (cons string string)))) +(put 'tramp-temp-buffer-file-name 'permanent-local t) ;; XEmacs is distributed with few Lisp packages. Further packages are ;; installed using EFS. If we use a unified filename format, then @@ -1311,20 +666,20 @@ Used in `tramp-make-tramp-file-name'.") "*Regexp matching delimeter between method and user or host names. Derived from `tramp-postfix-method-format'.") -(defconst tramp-user-regexp - "[^:/ \t]+" +(defconst tramp-user-regexp "[^:/ \t]+" "*Regexp matching user names.") +;;;###tramp-autoload (defconst tramp-prefix-domain-format "%" "*String matching delimeter between user and domain names.") +;;;###tramp-autoload (defconst tramp-prefix-domain-regexp (regexp-quote tramp-prefix-domain-format) "*Regexp matching delimeter between user and domain names. Derived from `tramp-prefix-domain-format'.") -(defconst tramp-domain-regexp - "[-a-zA-Z0-9_.]+" +(defconst tramp-domain-regexp "[-a-zA-Z0-9_.]+" "*Regexp matching domain names.") (defconst tramp-user-with-domain-regexp @@ -1333,8 +688,7 @@ Derived from `tramp-prefix-domain-format'.") "\\(" tramp-domain-regexp "\\)") "*Regexp matching user names with domain names.") -(defconst tramp-postfix-user-format - "@" +(defconst tramp-postfix-user-format "@" "*String matching delimeter between user and host names. Used in `tramp-make-tramp-file-name'.") @@ -1343,8 +697,7 @@ Used in `tramp-make-tramp-file-name'.") "*Regexp matching delimeter between user and host names. Derived from `tramp-postfix-user-format'.") -(defconst tramp-host-regexp - "[a-zA-Z0-9_.-]+" +(defconst tramp-host-regexp "[a-zA-Z0-9_.-]+" "*Regexp matching host names.") (defconst tramp-prefix-ipv6-format @@ -1392,8 +745,7 @@ Derived from `tramp-postfix-ipv6-format'.") "*Regexp matching delimeter between host names and port numbers. Derived from `tramp-prefix-port-format'.") -(defconst tramp-port-regexp - "[0-9]+" +(defconst tramp-port-regexp "[0-9]+" "*Regexp matching port numbers.") (defconst tramp-host-with-port-regexp @@ -1415,11 +767,10 @@ Used in `tramp-make-tramp-file-name'.") "*Regexp matching delimeter between host names and localnames. Derived from `tramp-postfix-host-format'.") -(defconst tramp-localname-regexp - ".*$" +(defconst tramp-localname-regexp ".*$" "*Regexp matching localnames.") -;; File name format. +;;; File name format: (defconst tramp-file-name-structure (list @@ -1464,15 +815,13 @@ Tramp. See `tramp-file-name-structure' for more explanations. On W32 systems, the volume letter must be ignored.") ;;;###autoload -(defconst tramp-file-name-regexp-separate - "\\`/\\[.*\\]" +(defconst tramp-file-name-regexp-separate "\\`/\\[.*\\]" "Value for `tramp-file-name-regexp' for separate remoting. XEmacs uses a separate filename syntax for Tramp and EFS. See `tramp-file-name-structure' for more explanations.") ;;;###autoload -(defconst tramp-file-name-regexp-url - "\\`/[^/:]+://" +(defconst tramp-file-name-regexp-url "\\`/[^/:]+://" "Value for `tramp-file-name-regexp' for URL-like remoting. See `tramp-file-name-structure' for more explanations.") @@ -1546,38 +895,6 @@ updated after changing this variable. Also see `tramp-file-name-structure'.") -(defconst tramp-actions-before-shell - '((tramp-login-prompt-regexp tramp-action-login) - (tramp-password-prompt-regexp tramp-action-password) - (tramp-wrong-passwd-regexp tramp-action-permission-denied) - (shell-prompt-pattern tramp-action-succeed) - (tramp-shell-prompt-pattern tramp-action-succeed) - (tramp-yesno-prompt-regexp tramp-action-yesno) - (tramp-yn-prompt-regexp tramp-action-yn) - (tramp-terminal-prompt-regexp tramp-action-terminal) - (tramp-process-alive-regexp tramp-action-process-alive)) - "List of pattern/action pairs. -Whenever a pattern matches, the corresponding action is performed. -Each item looks like (PATTERN ACTION). - -The PATTERN should be a symbol, a variable. The value of this -variable gives the regular expression to search for. Note that the -regexp must match at the end of the buffer, \"\\'\" is implicitly -appended to it. - -The ACTION should also be a symbol, but a function. When the -corresponding PATTERN matches, the ACTION function is called.") - -(defconst tramp-actions-copy-out-of-band - '((tramp-password-prompt-regexp tramp-action-password) - (tramp-wrong-passwd-regexp tramp-action-permission-denied) - (tramp-copy-failed-regexp tramp-action-permission-denied) - (tramp-process-alive-regexp tramp-action-out-of-band)) - "List of pattern/action pairs. -This list is used for copying/renaming with out-of-band methods. - -See `tramp-actions-before-shell' for more info.") - ;; Chunked sending kludge. We set this to 500 for black-listed constellations ;; known to have a bug in `process-send-string'; some ssh connections appear ;; to drop bytes when data is sent too quickly. There is also a connection @@ -1666,8 +983,8 @@ A remote directory might have changed its contents. In order to make it visible during file name completion in the minibuffer, Tramp flushes its cache and rereads the directory contents when more than `tramp-completion-reread-directory-timeout' seconds -have been gone since last remote command execution. A value of 0 -would require an immediate reread during filename completion, nil +have been gone since last remote command execution. A value of `t' +would require an immediate reread during filename completion, `nil' means to use always cached values for the directory contents." :group 'tramp :type '(choice (const nil) integer)) @@ -1683,437 +1000,276 @@ means to use always cached values for the directory contents." (defvar tramp-current-host nil "Remote host for this *tramp* buffer.") -(defconst tramp-uudecode - "(echo begin 600 /tmp/tramp.$$; tail +2) | uudecode -cat /tmp/tramp.$$ -rm -f /tmp/tramp.$$" - "Shell function to implement `uudecode' to standard output. -Many systems support `uudecode -o /dev/stdout' or `uudecode -o -' -for this or `uudecode -p', but some systems don't, and for them -we have this shell function.") - -(defconst tramp-perl-file-truename - "%s -e ' -use File::Spec; -use Cwd \"realpath\"; - -sub recursive { - my ($volume, @dirs) = @_; - my $real = realpath(File::Spec->catpath( - $volume, File::Spec->catdir(@dirs), \"\")); - if ($real) { - my ($vol, $dir) = File::Spec->splitpath($real, 1); - return ($vol, File::Spec->splitdir($dir)); - } - else { - my $last = pop(@dirs); - ($volume, @dirs) = recursive($volume, @dirs); - push(@dirs, $last); - return ($volume, @dirs); - } -} - -$result = realpath($ARGV[0]); -if (!$result) { - my ($vol, $dir) = File::Spec->splitpath($ARGV[0], 1); - ($vol, @dirs) = recursive($vol, File::Spec->splitdir($dir)); - - $result = File::Spec->catpath($vol, File::Spec->catdir(@dirs), \"\"); -} - -if ($ARGV[0] =~ /\\/$/) { - $result = $result . \"/\"; -} - -print \"\\\"$result\\\"\\n\"; -' \"$1\" 2>/dev/null" - "Perl script to produce output suitable for use with `file-truename' -on the remote file system. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-perl-file-name-all-completions - "%s -e 'sub case { - my $str = shift; - if ($ARGV[2]) { - return lc($str); - } - else { - return $str; - } -} -opendir(d, $ARGV[0]) || die(\"$ARGV[0]: $!\\nfail\\n\"); -@files = readdir(d); closedir(d); -foreach $f (@files) { - if (case(substr($f, 0, length($ARGV[1]))) eq case($ARGV[1])) { - if (-d \"$ARGV[0]/$f\") { - print \"$f/\\n\"; - } - else { - print \"$f\\n\"; - } - } -} -print \"ok\\n\" -' \"$1\" \"$2\" \"$3\" 2>/dev/null" - "Perl script to produce output suitable for use with -`file-name-all-completions' on the remote file system. Escape -sequence %s is replaced with name of Perl binary. This string is -passed to `format', so percent characters need to be doubled.") - -;; Perl script to implement `file-attributes' in a Lisp `read'able -;; output. If you are hacking on this, note that you get *no* output -;; unless this spits out a complete line, including the '\n' at the -;; end. -;; The device number is returned as "-1", because there will be a virtual -;; device number set in `tramp-handle-file-attributes'. -(defconst tramp-perl-file-attributes - "%s -e ' -@stat = lstat($ARGV[0]); -if (!@stat) { - print \"nil\\n\"; - exit 0; -} -if (($stat[2] & 0170000) == 0120000) -{ - $type = readlink($ARGV[0]); - $type = \"\\\"$type\\\"\"; -} -elsif (($stat[2] & 0170000) == 040000) -{ - $type = \"t\"; -} -else -{ - $type = \"nil\" -}; -$uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; -$gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; -printf( - \"(%%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) -1)\\n\", - $type, - $stat[3], - $uid, - $gid, - $stat[8] >> 16 & 0xffff, - $stat[8] & 0xffff, - $stat[9] >> 16 & 0xffff, - $stat[9] & 0xffff, - $stat[10] >> 16 & 0xffff, - $stat[10] & 0xffff, - $stat[7], - $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff -);' \"$1\" \"$2\" 2>/dev/null" - "Perl script to produce output suitable for use with `file-attributes' -on the remote file system. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-perl-directory-files-and-attributes - "%s -e ' -chdir($ARGV[0]) or printf(\"\\\"Cannot change to $ARGV[0]: $''!''\\\"\\n\"), exit(); -opendir(DIR,\".\") or printf(\"\\\"Cannot open directory $ARGV[0]: $''!''\\\"\\n\"), exit(); -@list = readdir(DIR); -closedir(DIR); -$n = scalar(@list); -printf(\"(\\n\"); -for($i = 0; $i < $n; $i++) -{ - $filename = $list[$i]; - @stat = lstat($filename); - if (($stat[2] & 0170000) == 0120000) - { - $type = readlink($filename); - $type = \"\\\"$type\\\"\"; - } - elsif (($stat[2] & 0170000) == 040000) - { - $type = \"t\"; - } - else - { - $type = \"nil\" - }; - $uid = ($ARGV[1] eq \"integer\") ? $stat[4] : \"\\\"\" . getpwuid($stat[4]) . \"\\\"\"; - $gid = ($ARGV[1] eq \"integer\") ? $stat[5] : \"\\\"\" . getgrgid($stat[5]) . \"\\\"\"; - printf( - \"(\\\"%%s\\\" %%s %%u %%s %%s (%%u %%u) (%%u %%u) (%%u %%u) %%u.0 %%u t (%%u . %%u) (%%u . %%u))\\n\", - $filename, - $type, - $stat[3], - $uid, - $gid, - $stat[8] >> 16 & 0xffff, - $stat[8] & 0xffff, - $stat[9] >> 16 & 0xffff, - $stat[9] & 0xffff, - $stat[10] >> 16 & 0xffff, - $stat[10] & 0xffff, - $stat[7], - $stat[2], - $stat[1] >> 16 & 0xffff, - $stat[1] & 0xffff, - $stat[0] >> 16 & 0xffff, - $stat[0] & 0xffff); -} -printf(\")\\n\");' \"$1\" \"$2\" 2>/dev/null" - "Perl script implementing `directory-files-attributes' as Lisp `read'able -output. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -;; ;; These two use uu encoding. -;; (defvar tramp-perl-encode "%s -e'\ -;; print qq(begin 644 xxx\n); -;; my $s = q(); -;; my $res = q(); -;; while (read(STDIN, $s, 45)) { -;; print pack(q(u), $s); -;; } -;; print qq(`\n); -;; print qq(end\n); -;; '" -;; "Perl program to use for encoding a file. -;; Escape sequence %s is replaced with name of Perl binary.") - -;; (defvar tramp-perl-decode "%s -ne ' -;; print unpack q(u), $_; -;; '" -;; "Perl program to use for decoding a file. -;; Escape sequence %s is replaced with name of Perl binary.") - -;; These two use base64 encoding. -(defconst tramp-perl-encode-with-module - "%s -MMIME::Base64 -0777 -ne 'print encode_base64($_)' 2>/dev/null" - "Perl program to use for encoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled. -This implementation requires the MIME::Base64 Perl module to be installed -on the remote host.") - -(defconst tramp-perl-decode-with-module - "%s -MMIME::Base64 -0777 -ne 'print decode_base64($_)' 2>/dev/null" - "Perl program to use for decoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled. -This implementation requires the MIME::Base64 Perl module to be installed -on the remote host.") - -(defconst tramp-perl-encode - "%s -e ' -# This script contributed by Juanma Barranquero <lektu@terra.es>. -# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -# Free Software Foundation, Inc. -use strict; - -my %%trans = do { - my $i = 0; - map {(substr(unpack(q(B8), chr $i++), 2, 6), $_)} - split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/); -}; - -binmode(\\*STDIN); - -# We read in chunks of 54 bytes, to generate output lines -# of 72 chars (plus end of line) -$/ = \\54; - -while (my $data = <STDIN>) { - my $pad = q(); - - # Only for the last chunk, and only if did not fill the last three-byte packet - if (eof) { - my $mod = length($data) %% 3; - $pad = q(=) x (3 - $mod) if $mod; - } - - # Not the fastest method, but it is simple: unpack to binary string, split - # by groups of 6 bits and convert back from binary to byte; then map into - # the translation table - print - join q(), - map($trans{$_}, - (substr(unpack(q(B*), $data) . q(00000), 0, 432) =~ /....../g)), - $pad, - qq(\\n); -}' 2>/dev/null" - "Perl program to use for encoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-perl-decode - "%s -e ' -# This script contributed by Juanma Barranquero <lektu@terra.es>. -# Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 -# Free Software Foundation, Inc. -use strict; - -my %%trans = do { - my $i = 0; - map {($_, substr(unpack(q(B8), chr $i++), 2, 6))} - split //, q(ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/) -}; - -my %%bytes = map {(unpack(q(B8), chr $_), chr $_)} 0 .. 255; - -binmode(\\*STDOUT); - -# We are going to accumulate into $pending to accept any line length -# (we do not check they are <= 76 chars as the RFC says) -my $pending = q(); - -while (my $data = <STDIN>) { - chomp $data; - - # If we find one or two =, we have reached the end and - # any following data is to be discarded - my $finished = $data =~ s/(==?).*/$1/; - $pending .= $data; - - my $len = length($pending); - my $chunk = substr($pending, 0, $len & ~3); - $pending = substr($pending, $len & ~3 + 1); - - # Easy method: translate from chars to (pregenerated) six-bit packets, join, - # split in 8-bit chunks and convert back to char. - print join q(), - map $bytes{$_}, - ((join q(), map {$trans{$_} || q()} split //, $chunk) =~ /......../g); - - last if $finished; -}' 2>/dev/null" - "Perl program to use for decoding a file. -Escape sequence %s is replaced with name of Perl binary. -This string is passed to `format', so percent characters need to be doubled.") - -(defconst tramp-vc-registered-read-file-names - "echo \"(\" -while read file; do - if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" t)\" - else - echo \"(\\\"$file\\\" \\\"file-exists-p\\\" nil)\" - fi - if %s \"$file\"; then - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" t)\" - else - echo \"(\\\"$file\\\" \\\"file-readable-p\\\" nil)\" - fi -done -echo \")\"" - "Script to check existence of VC related files. -It must be send formatted with two strings; the tests for file -existence, and file readability. Input shall be read via -here-document, otherwise the command could exceed maximum length -of command line.") - -(defconst tramp-file-mode-type-map - '((0 . "-") ; Normal file (SVID-v2 and XPG2) - (1 . "p") ; fifo - (2 . "c") ; character device - (3 . "m") ; multiplexed character device (v7) - (4 . "d") ; directory - (5 . "?") ; Named special file (XENIX) - (6 . "b") ; block device - (7 . "?") ; multiplexed block device (v7) - (8 . "-") ; regular file - (9 . "n") ; network special file (HP-UX) - (10 . "l") ; symlink - (11 . "?") ; ACL shadow inode (Solaris, not userspace) - (12 . "s") ; socket - (13 . "D") ; door special (Solaris) - (14 . "w")) ; whiteout (BSD) - "A list of file types returned from the `stat' system call. -This is used to map a mode number to a permission string.") - -;; New handlers should be added here. The following operations can be -;; handled using the normal primitives: file-name-sans-versions, -;; get-file-buffer. -(defconst tramp-file-name-handler-alist - '((load . tramp-handle-load) - (make-symbolic-link . tramp-handle-make-symbolic-link) - (file-name-as-directory . tramp-handle-file-name-as-directory) - (file-name-directory . tramp-handle-file-name-directory) - (file-name-nondirectory . tramp-handle-file-name-nondirectory) - (file-truename . tramp-handle-file-truename) - (file-exists-p . tramp-handle-file-exists-p) - (file-directory-p . tramp-handle-file-directory-p) - (file-executable-p . tramp-handle-file-executable-p) - (file-readable-p . tramp-handle-file-readable-p) - (file-regular-p . tramp-handle-file-regular-p) - (file-symlink-p . tramp-handle-file-symlink-p) - (file-writable-p . tramp-handle-file-writable-p) - (file-ownership-preserved-p . tramp-handle-file-ownership-preserved-p) - (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) - (file-attributes . tramp-handle-file-attributes) - (file-modes . tramp-handle-file-modes) - (directory-files . tramp-handle-directory-files) - (directory-files-and-attributes . tramp-handle-directory-files-and-attributes) - (file-name-all-completions . tramp-handle-file-name-all-completions) - (file-name-completion . tramp-handle-file-name-completion) - (add-name-to-file . tramp-handle-add-name-to-file) - (copy-file . tramp-handle-copy-file) - (copy-directory . tramp-handle-copy-directory) - (rename-file . tramp-handle-rename-file) - (set-file-modes . tramp-handle-set-file-modes) - (set-file-times . tramp-handle-set-file-times) - (make-directory . tramp-handle-make-directory) - (delete-directory . tramp-handle-delete-directory) - (delete-file . tramp-handle-delete-file) - (directory-file-name . tramp-handle-directory-file-name) - ;; `executable-find' is not official yet. - (executable-find . tramp-handle-executable-find) - (start-file-process . tramp-handle-start-file-process) - (process-file . tramp-handle-process-file) - (shell-command . tramp-handle-shell-command) - (insert-directory . tramp-handle-insert-directory) - (expand-file-name . tramp-handle-expand-file-name) - (substitute-in-file-name . tramp-handle-substitute-in-file-name) - (file-local-copy . tramp-handle-file-local-copy) - (file-remote-p . tramp-handle-file-remote-p) - (insert-file-contents . tramp-handle-insert-file-contents) - (insert-file-contents-literally - . tramp-handle-insert-file-contents-literally) - (write-region . tramp-handle-write-region) - (find-backup-file-name . tramp-handle-find-backup-file-name) - (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) - (unhandled-file-name-directory . tramp-handle-unhandled-file-name-directory) - (dired-compress-file . tramp-handle-dired-compress-file) - (dired-recursive-delete-directory - . tramp-handle-dired-recursive-delete-directory) - (dired-uncache . tramp-handle-dired-uncache) - (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) - (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) - (file-selinux-context . tramp-handle-file-selinux-context) - (set-file-selinux-context . tramp-handle-set-file-selinux-context) - (vc-registered . tramp-handle-vc-registered)) - "Alist of handler functions. -Operations not mentioned here will be handled by the normal Emacs functions.") - -;; Handlers for partial Tramp file names. For Emacs just -;; `file-name-all-completions' is needed. ;;;###autoload (defconst tramp-completion-file-name-handler-alist '((file-name-all-completions . tramp-completion-handle-file-name-all-completions) (file-name-completion . tramp-completion-handle-file-name-completion)) "Alist of completion handler functions. -Used for file names matching `tramp-file-name-regexp'. Operations not -mentioned here will be handled by `tramp-file-name-handler-alist' or the -normal Emacs functions.") +Used for file names matching `tramp-file-name-regexp'. Operations +not mentioned here will be handled by Tramp's file name handler +functions, or the normal Emacs functions.") ;; Handlers for foreign methods, like FTP or SMB, shall be plugged here. -(defvar tramp-foreign-file-name-handler-alist - ;; (identity . tramp-sh-file-name-handler) should always be the last - ;; entry, because `identity' always matches. - '((identity . tramp-sh-file-name-handler)) +;;;###tramp-autoload +(defvar tramp-foreign-file-name-handler-alist nil "Alist of elements (FUNCTION . HANDLER) for foreign methods handled specially. If (FUNCTION FILENAME) returns non-nil, then all I/O on that file is done by calling HANDLER.") ;;; Internal functions which must come first: +;; Conversion functions between external representation and +;; internal data structure. Convenience functions for internal +;; data structure. + +(defun tramp-file-name-p (vec) + "Check, whether VEC is a Tramp object." + (and (vectorp vec) (= 4 (length vec)))) + +(defun tramp-file-name-method (vec) + "Return method component of VEC." + (and (tramp-file-name-p vec) (aref vec 0))) + +(defun tramp-file-name-user (vec) + "Return user component of VEC." + (and (tramp-file-name-p vec) (aref vec 1))) + +(defun tramp-file-name-host (vec) + "Return host component of VEC." + (and (tramp-file-name-p vec) (aref vec 2))) + +(defun tramp-file-name-localname (vec) + "Return localname component of VEC." + (and (tramp-file-name-p vec) (aref vec 3))) + +;; The user part of a Tramp file name vector can be of kind +;; "user%domain". Sometimes, we must extract these parts. +(defun tramp-file-name-real-user (vec) + "Return the user name of VEC without domain." + (save-match-data + (let ((user (tramp-file-name-user vec))) + (if (and (stringp user) + (string-match tramp-user-with-domain-regexp user)) + (match-string 1 user) + user)))) + +(defun tramp-file-name-domain (vec) + "Return the domain name of VEC." + (save-match-data + (let ((user (tramp-file-name-user vec))) + (and (stringp user) + (string-match tramp-user-with-domain-regexp user) + (match-string 2 user))))) + +;; The host part of a Tramp file name vector can be of kind +;; "host#port". Sometimes, we must extract these parts. +(defun tramp-file-name-real-host (vec) + "Return the host name of VEC without port." + (save-match-data + (let ((host (tramp-file-name-host vec))) + (if (and (stringp host) + (string-match tramp-host-with-port-regexp host)) + (match-string 1 host) + host)))) + +(defun tramp-file-name-port (vec) + "Return the port number of VEC." + (save-match-data + (let ((method (tramp-file-name-method vec)) + (host (tramp-file-name-host vec))) + (or (and (stringp host) + (string-match tramp-host-with-port-regexp host) + (string-to-number (match-string 2 host))) + (tramp-get-method-parameter method 'tramp-default-port))))) + +;;;###tramp-autoload +(defun tramp-tramp-file-p (name) + "Return t if NAME is a string with Tramp file name syntax." + (save-match-data + (and (stringp name) (string-match tramp-file-name-regexp name)))) + +(defun tramp-find-method (method user host) + "Return the right method string to use. +This is METHOD, if non-nil. Otherwise, do a lookup in +`tramp-default-method-alist'." + (or method + (let ((choices tramp-default-method-alist) + lmethod item) + (while choices + (setq item (pop choices)) + (when (and (string-match (or (nth 0 item) "") (or host "")) + (string-match (or (nth 1 item) "") (or user ""))) + (setq lmethod (nth 2 item)) + (setq choices nil))) + lmethod) + tramp-default-method)) + +(defun tramp-find-user (method user host) + "Return the right user string to use. +This is USER, if non-nil. Otherwise, do a lookup in +`tramp-default-user-alist'." + (or user + (let ((choices tramp-default-user-alist) + luser item) + (while choices + (setq item (pop choices)) + (when (and (string-match (or (nth 0 item) "") (or method "")) + (string-match (or (nth 1 item) "") (or host ""))) + (setq luser (nth 2 item)) + (setq choices nil))) + luser) + tramp-default-user)) + +(defun tramp-find-host (method user host) + "Return the right host string to use. +This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." + (or (and (> (length host) 0) host) + tramp-default-host)) + +(defun tramp-dissect-file-name (name &optional nodefault) + "Return a `tramp-file-name' structure. +The structure consists of remote method, remote user, remote host +and localname (file name on remote host). If NODEFAULT is +non-nil, the file name parts are not expanded to their default +values." + (save-match-data + (let ((match (string-match (nth 0 tramp-file-name-structure) name))) + (unless match (error "Not a Tramp file name: %s" name)) + (let ((method (match-string (nth 1 tramp-file-name-structure) name)) + (user (match-string (nth 2 tramp-file-name-structure) name)) + (host (match-string (nth 3 tramp-file-name-structure) name)) + (localname (match-string (nth 4 tramp-file-name-structure) name))) + (when host + (when (string-match tramp-prefix-ipv6-regexp host) + (setq host (replace-match "" nil t host))) + (when (string-match tramp-postfix-ipv6-regexp host) + (setq host (replace-match "" nil t host)))) + (if nodefault + (vector method user host localname) + (vector + (tramp-find-method method user host) + (tramp-find-user method user host) + (tramp-find-host method user host) + localname)))))) + +(defun tramp-buffer-name (vec) + "A name for the connection buffer VEC." + ;; We must use `tramp-file-name-real-host', because for gateway + ;; methods the default port will be expanded later on, which would + ;; tamper the name. + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-real-host vec))) + (if (not (zerop (length user))) + (format "*tramp/%s %s@%s*" method user host) + (format "*tramp/%s %s*" method host)))) + +(defun tramp-make-tramp-file-name (method user host localname) + "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME." + (concat tramp-prefix-format + (when (not (zerop (length method))) + (concat method tramp-postfix-method-format)) + (when (not (zerop (length user))) + (concat user tramp-postfix-user-format)) + (when host + (if (string-match tramp-ipv6-regexp host) + (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host)) + tramp-postfix-host-format + (when localname localname))) + +(defun tramp-completion-make-tramp-file-name (method user host localname) + "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. +It must not be a complete Tramp file name, but as long as there are +necessary only. This function will be used in file name completion." + (concat tramp-prefix-format + (when (not (zerop (length method))) + (concat method tramp-postfix-method-format)) + (when (not (zerop (length user))) + (concat user tramp-postfix-user-format)) + (when (not (zerop (length host))) + (concat + (if (string-match tramp-ipv6-regexp host) + (concat + tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) + host) + tramp-postfix-host-format)) + (when localname localname))) + +(defun tramp-get-buffer (vec) + "Get the connection buffer to be used for VEC." + (or (get-buffer (tramp-buffer-name vec)) + (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) + (setq buffer-undo-list t) + (setq default-directory + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + "/")) + (current-buffer)))) + +(defun tramp-get-connection-buffer (vec) + "Get the connection buffer to be used for VEC. +In case a second asynchronous communication has been started, it is different +from `tramp-get-buffer'." + (or (tramp-get-connection-property vec "process-buffer" nil) + (tramp-get-buffer vec))) + +(defun tramp-get-connection-name (vec) + "Get the connection name to be used for VEC. +In case a second asynchronous communication has been started, it is different +from the default one." + (or (tramp-get-connection-property vec "process-name" nil) + (tramp-buffer-name vec))) + +(defun tramp-get-connection-process (vec) + "Get the connection process to be used for VEC. +In case a second asynchronous communication has been started, it is different +from the default one." + (get-process (tramp-get-connection-name vec))) + +(defun tramp-debug-buffer-name (vec) + "A name for the debug buffer for VEC." + ;; We must use `tramp-file-name-real-host', because for gateway + ;; methods the default port will be expanded later on, which would + ;; tamper the name. + (let ((method (tramp-file-name-method vec)) + (user (tramp-file-name-user vec)) + (host (tramp-file-name-real-host vec))) + (if (not (zerop (length user))) + (format "*debug tramp/%s %s@%s*" method user host) + (format "*debug tramp/%s %s*" method host)))) + +(defconst tramp-debug-outline-regexp + "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #" + "Used for highlighting Tramp debug buffers in `outline-mode'.") + +(defun tramp-debug-outline-level () + "Return the depth to which a statement is nested in the outline. +Point must be at the beginning of a header line. + +The outline level is equal to the verbosity of the Tramp message." + (1+ (string-to-number (match-string 1)))) + +(defun tramp-get-debug-buffer (vec) + "Get the debug buffer for VEC." + (with-current-buffer + (get-buffer-create (tramp-debug-buffer-name vec)) + (when (bobp) + (setq buffer-undo-list t) + ;; Activate `outline-mode'. This runs `text-mode-hook' and + ;; `outline-mode-hook'. We must prevent that local processes + ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". + ;; Furthermore, `outline-regexp' must have the correct value + ;; already, because it is used by `font-lock-compile-keywords'. + (let ((default-directory (tramp-compat-temporary-file-directory)) + (outline-regexp tramp-debug-outline-regexp)) + (outline-mode)) + (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) + (set (make-local-variable 'outline-level) 'tramp-debug-outline-level)) + (current-buffer))) + (defsubst tramp-debug-message (vec fmt-string &rest args) "Append message to debug buffer. Message is formatted with FMT-STRING as control string and the remaining @@ -2144,7 +1300,7 @@ ARGS to actually emit the message (if applicable)." (setq fn (symbol-name btf)) (unless (and (string-match "^tramp" fn) (not (string-match - "^tramp\\(-debug\\)?\\(-message\\|-error\\|-compat-funcall\\)$" + "^tramp\\(-debug\\)?\\(-message\\|-error\\|-compat\\(-funcall\\|-with-temp-message\\)\\)$" fn))) (setq fn nil))) (setq btn (1+ btn)))) @@ -2180,36 +1336,34 @@ is greater than or equal 4. Calls functions `message' and `tramp-debug-message' with FMT-STRING as control string and the remaining ARGS to actually emit the message (if applicable)." - (condition-case nil - (when (<= level tramp-verbose) - ;; Match data must be preserved! - (save-match-data - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) - (apply 'message - (concat - (cond - ((= level 0) "") - ((= level 1) "") - ((= level 2) "Warning: ") - (t "Tramp: ")) - fmt-string) - args)) - ;; Log only when there is a minimum level. - (when (>= tramp-verbose 4) - (when (and vec-or-proc - (processp vec-or-proc) - (buffer-name (process-buffer vec-or-proc))) - (with-current-buffer (process-buffer vec-or-proc) - ;; Translate proc to vec. - (setq vec-or-proc (tramp-dissect-file-name default-directory)))) - (when (and vec-or-proc (vectorp vec-or-proc)) - (apply 'tramp-debug-message - vec-or-proc - (concat (format "(%d) # " level) fmt-string) - args))))) - ;; Suppress all errors. - (error nil))) + (ignore-errors + (when (<= level tramp-verbose) + ;; Match data must be preserved! + (save-match-data + ;; Display only when there is a minimum level. + (when (and tramp-message-show-message (<= level 3)) + (apply 'message + (concat + (cond + ((= level 0) "") + ((= level 1) "") + ((= level 2) "Warning: ") + (t "Tramp: ")) + fmt-string) + args)) + ;; Log only when there is a minimum level. + (when (>= tramp-verbose 4) + (when (and vec-or-proc + (processp vec-or-proc) + (buffer-name (process-buffer vec-or-proc))) + (with-current-buffer (process-buffer vec-or-proc) + ;; Translate proc to vec. + (setq vec-or-proc (tramp-dissect-file-name default-directory)))) + (when (and vec-or-proc (vectorp vec-or-proc)) + (apply 'tramp-debug-message + vec-or-proc + (concat (format "(%d) # " level) fmt-string) + args))))))) (defsubst tramp-error (vec-or-proc signal fmt-string &rest args) "Emit an error. @@ -2271,46 +1425,14 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (put 'with-parsed-tramp-file-name 'lisp-indent-function 2) (put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) - -(defmacro with-file-property (vec file property &rest body) - "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. -FILE must be a local file name on a connection identified via VEC." - `(if (file-name-absolute-p ,file) - (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) - (when (eq value 'undef) - ;; We cannot pass @body as parameter to - ;; `tramp-set-file-property' because it mangles our - ;; debug messages. - (setq value (progn ,@body)) - (tramp-set-file-property ,vec ,file ,property value)) - value) - ,@body)) - -(put 'with-file-property 'lisp-indent-function 3) -(put 'with-file-property 'edebug-form-spec t) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-file-property\\>")) - -(defmacro with-connection-property (key property &rest body) - "Check in Tramp for property PROPERTY, otherwise executes BODY and set." - `(let ((value (tramp-get-connection-property ,key ,property 'undef))) - (when (eq value 'undef) - ;; We cannot pass ,@body as parameter to - ;; `tramp-set-connection-property' because it mangles our debug - ;; messages. - (setq value (progn ,@body)) - (tramp-set-connection-property ,key ,property value)) - value)) - -(put 'with-connection-property 'lisp-indent-function 2) -(put 'with-connection-property 'edebug-form-spec t) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-connection-property\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value) (let* ((parameters (cdr reporter)) (message (aref parameters 3))) (when (string-match message (or (current-message) "")) - (funcall 'progress-reporter-update reporter value)))) + (tramp-compat-funcall 'progress-reporter-update reporter value)))) (defmacro with-progress-reporter (vec level message &rest body) "Executes BODY, spinning a progress reporter with MESSAGE. @@ -2324,11 +1446,10 @@ progress reporter." (when (and tramp-message-show-message ;; Display only when there is a minimum level. (<= ,level (min tramp-verbose 3))) - (condition-case nil - (setq pr (tramp-compat-funcall 'make-progress-reporter ,message) - tm (when pr - (run-at-time 3 0.1 'tramp-progress-reporter-update pr))) - (error nil))) + (ignore-errors + (setq pr (tramp-compat-funcall 'make-progress-reporter ,message) + tm (when pr + (run-at-time 3 0.1 'tramp-progress-reporter-update pr))))) (unwind-protect ;; Execute the body. Unset `tramp-message-show-message' when ;; the timer object is created, in order to suppress @@ -2342,13 +1463,14 @@ progress reporter." (put 'with-progress-reporter 'lisp-indent-function 3) (put 'with-progress-reporter 'edebug-form-spec t) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<with-progress-reporter\\>")) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\<with-progress-reporter\\>")) (eval-and-compile ;; Silence compiler. (if (memq system-type '(cygwin windows-nt)) (defun tramp-drop-volume-letter (name) "Cut off unnecessary drive letter from file NAME. -The function `tramp-handle-expand-file-name' calls `expand-file-name' +The functions `tramp-*-handle-expand-file-name' call `expand-file-name' locally on a remote file name. When the local system is a W32 system but the remote system is Unix, this introduces a superfluous drive letter into the file name. This function removes it." @@ -2359,34 +1481,6 @@ letter into the file name. This function removes it." (defalias 'tramp-drop-volume-letter 'identity))) -(defsubst tramp-make-tramp-temp-file (vec) - "Create a temporary file on the remote host identified by VEC. -Return the local name of the temporary file." - (let ((prefix - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - (tramp-drop-volume-letter - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) - result) - (while (not result) - ;; `make-temp-file' would be the natural choice for - ;; implementation. But it calls `write-region' internally, - ;; which also needs a temporary file - we would end in an - ;; infinite loop. - (setq result (make-temp-name prefix)) - (if (file-exists-p result) - (setq result nil) - ;; This creates the file by side effect. - (set-file-times result) - (set-file-modes result (tramp-octal-to-decimal "0700")))) - - ;; Return the local part. - (with-parsed-tramp-file-name result nil localname))) - - ;;; Config Manipulation Functions: (defun tramp-set-completion-function (method function-list) @@ -2421,7 +1515,7 @@ Example: ;; Windows registry. (and (memq system-type '(cygwin windows-nt)) (zerop - (tramp-local-call-process + (tramp-compat-call-process "reg" nil nil nil "query" (nth 1 (car v))))) ;; Configuration file. (file-exists-p (nth 1 (car v))))) @@ -2509,279 +1603,6 @@ been set up by `rfn-eshadow-setup-minibuffer'." (remove-hook 'rfn-eshadow-update-overlay-hook 'tramp-rfn-eshadow-update-overlay)))) - -;;; Integration of eshell.el: - -(eval-when-compile - (defvar eshell-path-env)) - -;; eshell.el keeps the path in `eshell-path-env'. We must change it -;; when `default-directory' points to another host. -(defun tramp-eshell-directory-change () - "Set `eshell-path-env' to $PATH of the host related to `default-directory'." - (setq eshell-path-env - (if (file-remote-p default-directory) - (with-parsed-tramp-file-name default-directory nil - (mapconcat - 'identity - (tramp-get-remote-path v) - ":")) - (getenv "PATH")))) - -(eval-after-load "esh-util" - '(progn - (tramp-eshell-directory-change) - (add-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change) - (add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'eshell-directory-change-hook - 'tramp-eshell-directory-change))))) - - -;;; File Name Handler Functions: - -(defun tramp-handle-make-symbolic-link - (filename linkname &optional ok-if-already-exists) - "Like `make-symbolic-link' for Tramp files. -If LINKNAME is a non-Tramp file, it is used verbatim as the target of -the symlink. If LINKNAME is a Tramp file, only the localname component is -used as the target of the symlink. - -If LINKNAME is a Tramp file and the localname component is relative, then -it is expanded first, before the localname component is taken. Note that -this can give surprising results if the user/host for the source and -target of the symlink differ." - (with-parsed-tramp-file-name linkname l - (let ((ln (tramp-get-remote-ln l)) - (cwd (tramp-run-real-handler - 'file-name-directory (list l-localname)))) - (unless ln - (tramp-error - l 'file-error - "Making a symbolic link. ln(1) does not exist on the remote host.")) - - ;; Do the 'confirm if exists' thing. - (when (file-exists-p linkname) - ;; What to do? - (if (or (null ok-if-already-exists) ; not allowed to exist - (and (numberp ok-if-already-exists) - (not (yes-or-no-p - (format - "File %s already exists; make it a link anyway? " - l-localname))))) - (tramp-error - l 'file-already-exists "File %s already exists" l-localname) - (delete-file linkname))) - - ;; If FILENAME is a Tramp name, use just the localname component. - (when (tramp-tramp-file-p filename) - (setq filename - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name filename))))) - - (tramp-flush-file-property l (file-name-directory l-localname)) - (tramp-flush-file-property l l-localname) - - ;; Right, they are on the same host, regardless of user, method, etc. - ;; We now make the link on the remote machine. This will occur as the user - ;; that FILENAME belongs to. - (zerop - (tramp-send-command-and-check - l - (format - "cd %s && %s -sf %s %s" - (tramp-shell-quote-argument cwd) - ln - (tramp-shell-quote-argument filename) - (tramp-shell-quote-argument l-localname)) - t))))) - -(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) - "Like `load' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name file) nil - (unless nosuffix - (cond ((file-exists-p (concat file ".elc")) - (setq file (concat file ".elc"))) - ((file-exists-p (concat file ".el")) - (setq file (concat file ".el"))))) - (when must-suffix - ;; The first condition is always true for absolute file names. - ;; Included for safety's sake. - (unless (or (file-name-directory file) - (string-match "\\.elc?\\'" file)) - (tramp-error - v 'file-error - "File `%s' does not include a `.el' or `.elc' suffix" file))) - (unless noerror - (when (not (file-exists-p file)) - (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file))) - (if (not (file-exists-p file)) - nil - (let ((tramp-message-show-message (not nomessage))) - (with-progress-reporter v 0 (format "Loading %s" file) - (let ((local-copy (file-local-copy file))) - ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil. - (unwind-protect - (load local-copy noerror t t) - (delete-file local-copy))))) - t))) - -;; Localname manipulation functions that grok Tramp localnames... -(defun tramp-handle-file-name-as-directory (file) - "Like `file-name-as-directory' but aware of Tramp files." - ;; `file-name-as-directory' would be sufficient except localname is - ;; the empty string. - (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-host v) - (tramp-run-real-handler - 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))))) - -(defun tramp-handle-file-name-directory (file) - "Like `file-name-directory' but aware of Tramp files." - ;; Everything except the last filename thing is the directory. We - ;; cannot apply `with-parsed-tramp-file-name', because this expands - ;; the remote file name parts. This is a problem when we are in - ;; file name completion. - (let ((v (tramp-dissect-file-name file t))) - ;; Run the command on the localname portion only. - (tramp-make-tramp-file-name - (tramp-file-name-method v) - (tramp-file-name-user v) - (tramp-file-name-host v) - (tramp-run-real-handler - 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) - -(defun tramp-handle-file-name-nondirectory (file) - "Like `file-name-nondirectory' but aware of Tramp files." - (with-parsed-tramp-file-name file nil - (tramp-run-real-handler 'file-name-nondirectory (list localname)))) - -(defun tramp-handle-file-truename (filename &optional counter prev-dirs) - "Like `file-truename' for Tramp files." - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname "file-truename" - (let ((result nil)) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (cond - ;; Use GNU readlink --canonicalize-missing where available. - ((tramp-get-remote-readlink v) - (setq result - (tramp-send-command-and-read - v - (format "echo \"\\\"`%s --canonicalize-missing %s`\\\"\"" - (tramp-get-remote-readlink v) - (tramp-shell-quote-argument localname))))) - - ;; Use Perl implementation. - ((and (tramp-get-remote-perl v) - (tramp-get-connection-property v "perl-file-spec" nil) - (tramp-get-connection-property v "perl-cwd-realpath" nil)) - (tramp-maybe-send-script - v tramp-perl-file-truename "tramp_perl_file_truename") - (setq result - (tramp-send-command-and-read - v - (format "tramp_perl_file_truename %s" - (tramp-shell-quote-argument localname))))) - - ;; Do it yourself. We bind `directory-sep-char' here for - ;; XEmacs on Windows, which would otherwise use backslash. - (t (let* ((directory-sep-char ?/) - (steps (tramp-compat-split-string localname "/")) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (mapconcat 'identity - (append '("") (reverse result) (list thisstep)) - "/")) - (setq symlink-target - (nth 0 (file-attributes - (tramp-make-tramp-file-name - method user host - (mapconcat 'identity - (append '("") - (reverse result) - (list thisstep)) - "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string like - ;; "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (tramp-compat-split-string - symlink-target "/") - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (mapconcat 'identity (cons "" result) "/") - "/")) - (when (and is-dir (or (string= "" result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))))) - - (tramp-message v 4 "True name of `%s' is `%s'" filename result) - (tramp-make-tramp-file-name method user host result))))) - -;; Basic functions. - -(defun tramp-handle-file-exists-p (filename) - "Like `file-exists-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-exists-p" - (or (not (null (tramp-get-file-property - v localname "file-attributes-integer" nil))) - (not (null (tramp-get-file-property - v localname "file-attributes-string" nil))) - (zerop (tramp-send-command-and-check - v - (format - "%s %s" - (tramp-get-file-exists-command v) - (tramp-shell-quote-argument localname)))))))) - ;; Inodes don't exist for some file systems. Therefore we must ;; generate virtual ones. Used in `find-buffer-visiting'. The method ;; applied might be not so efficient (Ange-FTP uses hashes). But @@ -2798,1638 +1619,12 @@ target of the symlink differ." (defvar tramp-devices nil "Keeps virtual device numbers.") -;; CCC: This should check for an error condition and signal failure -;; when something goes wrong. -;; Daniel Pittman <daniel@danann.net> -(defun tramp-handle-file-attributes (filename &optional id-format) - "Like `file-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (with-parsed-tramp-file-name (expand-file-name filename) nil - (with-file-property v localname (format "file-attributes-%s" id-format) - (save-excursion - (tramp-convert-file-attributes - v - (cond - ((tramp-get-remote-stat v) - (tramp-do-file-attributes-with-stat v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-file-attributes-with-perl v localname id-format)) - (t - (tramp-do-file-attributes-with-ls v localname id-format))))))))) - -(defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) - "Implement `file-attributes' for Tramp files using the ls(1) command." - (let (symlinkp dirp - res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) - (tramp-message vec 5 "file attributes with ls: %s" localname) - (tramp-send-command - vec - (format "(%s %s || %s -h %s) && %s %s %s" - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-ls-command vec) - (if (eq id-format 'integer) "-ildn" "-ild") - (tramp-shell-quote-argument localname))) - ;; parse `ls -l' output ... - (with-current-buffer (tramp-get-buffer vec) - (when (> (buffer-size) 0) - (goto-char (point-min)) - ;; ... inode - (setq res-inode - (condition-case err - (read (current-buffer)) - (invalid-read-syntax - (when (and (equal (cadr err) - "Integer constant overflow in reader") - (string-match - "^[0-9]+\\([0-9][0-9][0-9][0-9][0-9]\\)\\'" - (car (cddr err)))) - (let* ((big (read (substring (car (cddr err)) 0 - (match-beginning 1)))) - (small (read (match-string 1 (car (cddr err))))) - (twiddle (/ small 65536))) - (cons (+ big twiddle) - (- small (* twiddle 65536)))))))) - ;; ... file mode flags - (setq res-filemodes (symbol-name (read (current-buffer)))) - ;; ... number links - (setq res-numlinks (read (current-buffer))) - ;; ... uid and gid - (setq res-uid (read (current-buffer))) - (setq res-gid (read (current-buffer))) - (if (eq id-format 'integer) - (progn - (unless (numberp res-uid) (setq res-uid -1)) - (unless (numberp res-gid) (setq res-gid -1))) - (progn - (unless (stringp res-uid) (setq res-uid (symbol-name res-uid))) - (unless (stringp res-gid) (setq res-gid (symbol-name res-gid))))) - ;; ... size - (setq res-size (read (current-buffer))) - ;; From the file modes, figure out other stuff. - (setq symlinkp (eq ?l (aref res-filemodes 0))) - (setq dirp (eq ?d (aref res-filemodes 0))) - ;; if symlink, find out file name pointed to - (when symlinkp - (search-forward "-> ") - (setq res-symlink-target - (buffer-substring (point) (tramp-compat-line-end-position)))) - ;; return data gathered - (list - ;; 0. t for directory, string (name linked to) for symbolic - ;; link, or nil. - (or dirp res-symlink-target) - ;; 1. Number of links to file. - res-numlinks - ;; 2. File uid. - res-uid - ;; 3. File gid. - res-gid - ;; 4. Last access time, as a list of two integers. First - ;; integer has high-order 16 bits of time, second has low 16 - ;; bits. - ;; 5. Last modification time, likewise. - ;; 6. Last status change time, likewise. - '(0 0) '(0 0) '(0 0) ;CCC how to find out? - ;; 7. Size in bytes (-1, if number is out of range). - res-size - ;; 8. File modes, as a string of ten letters or dashes as in ls -l. - res-filemodes - ;; 9. t if file's gid would change if file were deleted and - ;; recreated. Will be set in `tramp-convert-file-attributes' - t - ;; 10. inode number. - res-inode - ;; 11. Device number. Will be replaced by a virtual device number. - -1 - ))))) - -(defun tramp-do-file-attributes-with-perl - (vec localname &optional id-format) - "Implement `file-attributes' for Tramp files using a Perl script." - (tramp-message vec 5 "file attributes with perl: %s" localname) - (tramp-maybe-send-script - vec tramp-perl-file-attributes "tramp_perl_file_attributes") - (tramp-send-command-and-read - vec - (format "tramp_perl_file_attributes %s %s" - (tramp-shell-quote-argument localname) id-format))) - -(defun tramp-do-file-attributes-with-stat - (vec localname &optional id-format) - "Implement `file-attributes' for Tramp files using stat(1) command." - (tramp-message vec 5 "file attributes with stat: %s" localname) - (tramp-send-command-and-read - vec - (format - ;; On Opsware, pdksh (which is the true name of ksh there) doesn't - ;; parse correctly the sequence "((". Therefore, we add a space. - "( (%s %s || %s -h %s) && %s -c '( (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)' %s || echo nil)" - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%u" "\"%U\"") - (if (eq id-format 'integer) "%g" "\"%G\"") - (tramp-shell-quote-argument localname)))) - -(defun tramp-handle-set-visited-file-modtime (&optional time-list) - "Like `set-visited-file-modtime' for Tramp files." - (unless (buffer-file-name) - (error "Can't set-visited-file-modtime: buffer `%s' not visiting a file" - (buffer-name))) - (if time-list - (tramp-run-real-handler 'set-visited-file-modtime (list time-list)) - (let ((f (buffer-file-name)) - coding-system-used) - (with-parsed-tramp-file-name f nil - (let* ((attr (file-attributes f)) - ;; '(-1 65535) means file doesn't exists yet. - (modtime (or (nth 5 attr) '(-1 65535)))) - (when (boundp 'last-coding-system-used) - (setq coding-system-used (symbol-value 'last-coding-system-used))) - ;; We use '(0 0) as a don't-know value. See also - ;; `tramp-do-file-attributes-with-ls'. - (if (not (equal modtime '(0 0))) - (tramp-run-real-handler 'set-visited-file-modtime (list modtime)) - (progn - (tramp-send-command - v - (format "%s -ild %s" - (tramp-get-ls-command v) - (tramp-shell-quote-argument localname))) - (setq attr (buffer-substring (point) - (progn (end-of-line) (point))))) - (tramp-set-file-property - v localname "visited-file-modtime-ild" attr)) - (when (boundp 'last-coding-system-used) - (set 'last-coding-system-used coding-system-used)) - nil))))) - -;; This function makes the same assumption as -;; `tramp-handle-set-visited-file-modtime'. -(defun tramp-handle-verify-visited-file-modtime (buf) - "Like `verify-visited-file-modtime' for Tramp files. -At the time `verify-visited-file-modtime' calls this function, we -already know that the buffer is visiting a file and that -`visited-file-modtime' does not return 0. Do not call this -function directly, unless those two cases are already taken care -of." - (with-current-buffer buf - (let ((f (buffer-file-name))) - ;; There is no file visiting the buffer, or the buffer has no - ;; recorded last modification time, or there is no established - ;; connection. - (if (or (not f) - (eq (visited-file-modtime) 0) - (not (tramp-file-name-handler 'file-remote-p f nil 'connected))) - t - (with-parsed-tramp-file-name f nil - (tramp-flush-file-property v localname) - (let* ((attr (file-attributes f)) - (modtime (nth 5 attr)) - (mt (visited-file-modtime))) - - (cond - ;; File exists, and has a known modtime. - ((and attr (not (equal modtime '(0 0)))) - (< (abs (tramp-time-diff - modtime - ;; For compatibility, deal with both the old - ;; (HIGH . LOW) and the new (HIGH LOW) return - ;; values of `visited-file-modtime'. - (if (atom (cdr mt)) - (list (car mt) (cdr mt)) - mt))) - 2)) - ;; Modtime has the don't know value. - (attr - (tramp-send-command - v - (format "%s -ild %s" - (tramp-get-ls-command v) - (tramp-shell-quote-argument localname))) - (with-current-buffer (tramp-get-buffer v) - (setq attr (buffer-substring - (point) (progn (end-of-line) (point))))) - (equal - attr - (tramp-get-file-property - v localname "visited-file-modtime-ild" ""))) - ;; If file does not exist, say it is not modified if and - ;; only if that agrees with the buffer's record. - (t (equal mt '(-1 65535)))))))))) - -(defun tramp-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 (zerop (tramp-send-command-and-check - v - (format "chmod %s %s" - (tramp-decimal-to-octal mode) - (tramp-shell-quote-argument localname)))) - ;; FIXME: extract the proper text from chmod's stderr. - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) - -(defun tramp-handle-set-file-times (filename &optional time) - "Like `set-file-times' for Tramp files." - (zerop - (if (file-remote-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v localname) - (let ((time (if (or (null time) (equal time '(0 0))) - (current-time) - time)) - ;; With GNU Emacs, `format-time-string' has an optional - ;; parameter UNIVERSAL. This is preferred, because we - ;; could handle the case when the remote host is - ;; located in a different time zone as the local host. - (utc (not (featurep 'xemacs)))) - (tramp-send-command-and-check - v (format "%s touch -t %s %s" - (if utc "TZ=UTC; export TZ;" "") - (if utc - (format-time-string "%Y%m%d%H%M.%S" time t) - (format-time-string "%Y%m%d%H%M.%S" time)) - (tramp-shell-quote-argument localname))))) - - ;; We handle also the local part, because in older Emacsen, - ;; without `set-file-times', this function is an alias for this. - ;; We are local, so we don't need the UTC settings. - (tramp-local-call-process - "touch" nil nil nil "-t" - (format-time-string "%Y%m%d%H%M.%S" time) - (tramp-shell-quote-argument filename))))) - -(defun tramp-set-file-uid-gid (filename &optional uid gid) - "Set the ownership for FILENAME. -If UID and GID are provided, these values are used; otherwise uid -and gid of the corresponding user is taken. Both parameters must be integers." - ;; Modern Unices allow chown only for root. So we might need - ;; another implementation, see `dired-do-chown'. OTOH, it is mostly - ;; working with su(do)? when it is needed, so it shall succeed in - ;; the majority of cases. - ;; Don't modify `last-coding-system-used' by accident. - (let ((last-coding-system-used last-coding-system-used)) - (if (file-remote-p filename) - (with-parsed-tramp-file-name filename nil - (if (and (zerop (user-uid)) (tramp-local-host-p v)) - ;; If we are root on the local host, we can do it directly. - (tramp-set-file-uid-gid localname uid gid) - (let ((uid (or (and (integerp uid) uid) - (tramp-get-remote-uid v 'integer))) - (gid (or (and (integerp gid) gid) - (tramp-get-remote-gid v 'integer)))) - (tramp-send-command - v (format - "chown %d:%d %s" uid gid - (tramp-shell-quote-argument localname)))))) - - ;; We handle also the local part, because there doesn't exist - ;; `set-file-uid-gid'. On W32 "chown" might not work. - (let ((uid (or (and (integerp uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (integerp gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-local-call-process - "chown" nil nil nil - (format "%d:%d" uid gid) (tramp-shell-quote-argument filename)))))) - -(defun tramp-remote-selinux-p (vec) - "Check, whether SELINUX is enabled on the remote host." - (with-connection-property (tramp-get-connection-process vec) "selinux-p" - (let ((result (tramp-find-executable - vec "getenforce" (tramp-get-remote-path vec) t t))) - (and result - (string-equal - (tramp-send-command-and-read - vec (format "echo \\\"`%S`\\\"" result)) - "Enforcing"))))) - -(defun tramp-handle-file-selinux-context (filename) - "Like `file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-selinux-context" - (let ((context '(nil nil nil nil)) - (regexp (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)"))) - (when (and (tramp-remote-selinux-p v) - (zerop (tramp-send-command-and-check - v (format - "%s -d -Z %s" - (tramp-get-ls-command v) - (tramp-shell-quote-argument localname))))) - (with-current-buffer (tramp-get-connection-buffer v) - (goto-char (point-min)) - (when (re-search-forward regexp (tramp-compat-line-end-position) t) - (setq context (list (match-string 1) (match-string 2) - (match-string 3) (match-string 4)))))) - ;; Return the context. - context)))) - -(defun tramp-handle-set-file-selinux-context (filename context) - "Like `set-file-selinux-context' for Tramp files." - (with-parsed-tramp-file-name filename nil - (if (and (consp context) - (tramp-remote-selinux-p v) - (zerop (tramp-send-command-and-check - v (format "chcon %s %s %s %s %s" - (if (stringp (nth 0 context)) - (format "--user=%s" (nth 0 context)) "") - (if (stringp (nth 1 context)) - (format "--role=%s" (nth 1 context)) "") - (if (stringp (nth 2 context)) - (format "--type=%s" (nth 2 context)) "") - (if (stringp (nth 3 context)) - (format "--range=%s" (nth 3 context)) "") - (tramp-shell-quote-argument localname))))) - (tramp-set-file-property v localname "file-selinux-context" context) - (tramp-set-file-property v localname "file-selinux-context" 'undef))) - ;; We always return nil. - nil) - -;; Simple functions using the `test' command. - -(defun tramp-handle-file-executable-p (filename) - "Like `file-executable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-executable-p" - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?x) - (zerop (tramp-run-test "-x" filename)))))) - -(defun tramp-handle-file-readable-p (filename) - "Like `file-readable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-readable-p" - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?r) - (zerop (tramp-run-test "-r" filename)))))) - -;; When the remote shell is started, it looks for a shell which groks -;; tilde expansion. Here, we assume that all shells which grok tilde -;; expansion will also provide a `test' command which groks `-nt' (for -;; newer than). If this breaks, tell me about it and I'll try to do -;; something smarter about it. -(defun tramp-handle-file-newer-than-file-p (file1 file2) - "Like `file-newer-than-file-p' for Tramp files." - (cond ((not (file-exists-p file1)) - nil) - ((not (file-exists-p file2)) - t) - ;; We are sure both files exist at this point. - (t - (save-excursion - ;; We try to get the mtime of both files. If they are not - ;; equal to the "dont-know" value, then we subtract the times - ;; and obtain the result. - (let ((fa1 (file-attributes file1)) - (fa2 (file-attributes file2))) - (if (and (not (equal (nth 5 fa1) '(0 0))) - (not (equal (nth 5 fa2) '(0 0)))) - (> 0 (tramp-time-diff (nth 5 fa2) (nth 5 fa1))) - ;; If one of them is the dont-know value, then we can - ;; still try to run a shell command on the remote host. - ;; However, this only works if both files are Tramp - ;; files and both have the same method, same user, same - ;; host. - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "Files %s and %s must have same method, user, host" - file1 file2))) - (with-parsed-tramp-file-name file1 nil - (zerop (tramp-run-test2 - (tramp-get-test-nt-command v) file1 file2))))))))) - -;; Functions implemented using the basic functions above. - -(defun tramp-handle-file-modes (filename) - "Like `file-modes' for Tramp files." - (let ((truename (or (file-truename filename) filename))) - (when (file-exists-p truename) - (tramp-mode-string-to-int (nth 8 (file-attributes truename)))))) - (defun tramp-default-file-modes (filename) "Return file modes of FILENAME as integer. If the file modes of FILENAME cannot be determined, return the value of `default-file-modes', without execute permissions." (or (file-modes filename) - (logand (default-file-modes) (tramp-octal-to-decimal "0666")))) - -(defun tramp-handle-file-directory-p (filename) - "Like `file-directory-p' for Tramp files." - ;; Care must be taken that this function returns `t' for symlinks - ;; pointing to directories. Surely the most obvious implementation - ;; would be `test -d', but that returns false for such symlinks. - ;; CCC: Stefan Monnier says that `test -d' follows symlinks. And - ;; I now think he's right. So we could be using `test -d', couldn't - ;; we? - ;; - ;; Alternatives: `cd %s', `test -d %s' - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-directory-p" - (zerop (tramp-run-test "-d" filename))))) - -(defun tramp-handle-file-regular-p (filename) - "Like `file-regular-p' for Tramp files." - (and (file-exists-p filename) - (eq ?- (aref (nth 8 (file-attributes filename)) 0)))) - -(defun tramp-handle-file-symlink-p (filename) - "Like `file-symlink-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (let ((x (car (file-attributes filename)))) - (when (stringp x) - ;; When Tramp is running on VMS, then `file-name-absolute-p' - ;; might do weird things. - (if (file-name-absolute-p x) - (tramp-make-tramp-file-name method user host x) - x))))) - -(defun tramp-handle-file-writable-p (filename) - "Like `file-writable-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-writable-p" - (if (file-exists-p filename) - ;; Examine `file-attributes' cache to see if request can be - ;; satisfied without remote operation. - (or (tramp-check-cached-permissions v ?w) - (zerop (tramp-run-test "-w" filename))) - ;; If file doesn't exist, check if directory is writable. - (and (zerop (tramp-run-test - "-d" (file-name-directory filename))) - (zerop (tramp-run-test - "-w" (file-name-directory filename)))))))) - -(defun tramp-handle-file-ownership-preserved-p (filename) - "Like `file-ownership-preserved-p' for Tramp files." - (with-parsed-tramp-file-name filename nil - (with-file-property v localname "file-ownership-preserved-p" - (let ((attributes (file-attributes filename))) - ;; Return t if the file doesn't exist, since it's true that no - ;; information would be lost by an (attempted) delete and create. - (or (null attributes) - (= (nth 2 attributes) (tramp-get-remote-uid v 'integer))))))) - -;; Other file name ops. - -(defun tramp-handle-directory-file-name (directory) - "Like `directory-file-name' for Tramp files." - ;; If localname component of filename is "/", leave it unchanged. - ;; Otherwise, remove any trailing slash from localname component. - ;; Method, host, etc, are unchanged. Does it make sense to try - ;; to avoid parsing the filename? - (with-parsed-tramp-file-name directory nil - (if (and (not (zerop (length localname))) - (eq (aref localname (1- (length localname))) ?/) - (not (string= localname "/"))) - (substring directory 0 -1) - directory))) - -;; Directory listings. - -(defun tramp-handle-directory-files - (directory &optional full match nosort files-only) - "Like `directory-files' for Tramp files." - ;; FILES-ONLY is valid for XEmacs only. - (when (file-directory-p directory) - (setq directory (file-name-as-directory (expand-file-name directory))) - (let ((temp (nreverse (file-name-all-completions "" directory))) - result item) - - (while temp - (setq item (directory-file-name (pop temp))) - (when (and (or (null match) (string-match match item)) - (or (null files-only) - ;; Files only. - (and (equal files-only t) (file-regular-p item)) - ;; Directories only. - (file-directory-p item))) - (push (if full (concat directory item) item) - result))) - (if nosort result (sort result 'string<))))) - -(defun tramp-handle-directory-files-and-attributes - (directory &optional full match nosort id-format) - "Like `directory-files-and-attributes' for Tramp files." - (unless id-format (setq id-format 'integer)) - (when (file-directory-p directory) - (setq directory (expand-file-name directory)) - (let* ((temp - (copy-tree - (with-parsed-tramp-file-name directory nil - (with-file-property - v localname - (format "directory-files-and-attributes-%s" id-format) - (save-excursion - (mapcar - (lambda (x) - (cons (car x) - (tramp-convert-file-attributes v (cdr x)))) - (cond - ((tramp-get-remote-stat v) - (tramp-do-directory-files-and-attributes-with-stat - v localname id-format)) - ((tramp-get-remote-perl v) - (tramp-do-directory-files-and-attributes-with-perl - v localname id-format))))))))) - result item) - - (while temp - (setq item (pop temp)) - (when (or (null match) (string-match match (car item))) - (when full - (setcar item (expand-file-name (car item) directory))) - (push item result))) - - (if nosort - result - (sort result (lambda (x y) (string< (car x) (car y)))))))) - -(defun tramp-do-directory-files-and-attributes-with-perl - (vec localname &optional id-format) - "Implement `directory-files-and-attributes' for Tramp files using a Perl script." - (tramp-message vec 5 "directory-files-and-attributes with perl: %s" localname) - (tramp-maybe-send-script - vec tramp-perl-directory-files-and-attributes - "tramp_perl_directory_files_and_attributes") - (let ((object - (tramp-send-command-and-read - vec - (format "tramp_perl_directory_files_and_attributes %s %s" - (tramp-shell-quote-argument localname) id-format)))) - (when (stringp object) (tramp-error vec 'file-error object)) - object)) - -(defun tramp-do-directory-files-and-attributes-with-stat - (vec localname &optional id-format) - "Implement `directory-files-and-attributes' for Tramp files using stat(1) command." - (tramp-message vec 5 "directory-files-and-attributes with stat: %s" localname) - (tramp-send-command-and-read - vec - (format - (concat - ;; We must care about filenames with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, - ;; but it does not work on all remote systems. Therefore, we - ;; quote the filenames via sed. - "cd %s; echo \"(\"; (%s -a | sed -e s/\\$/\\\"/g -e s/^/\\\"/g | xargs " - "%s -c '(\"%%n\" (\"%%N\") %%h %s %s %%Xe0 %%Ye0 %%Ze0 %%se0 \"%%A\" t %%ie0 -1)'); " - "echo \")\"") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command vec) - (tramp-get-remote-stat vec) - (if (eq id-format 'integer) "%u" "\"%U\"") - (if (eq id-format 'integer) "%g" "\"%G\"")))) - -;; This function should return "foo/" for directories and "bar" for -;; files. -(defun tramp-handle-file-name-all-completions (filename directory) - "Like `file-name-all-completions' for Tramp files." - (unless (save-match-data (string-match "/" filename)) - (with-parsed-tramp-file-name (expand-file-name directory) nil - - (all-completions - filename - (mapcar - 'list - (or - ;; Try cache first - (and - ;; Ignore if expired - (or (not (integerp tramp-completion-reread-directory-timeout)) - (<= (tramp-time-diff - (current-time) - (tramp-get-file-property - v localname "last-completion" '(0 0 0))) - tramp-completion-reread-directory-timeout)) - - ;; Try cache entries for filename, filename with last - ;; character removed, filename with last two characters - ;; removed, ..., and finally the empty string - all - ;; concatenated to the local directory name - - ;; This is inefficient for very long filenames, pity - ;; `reduce' is not available... - (car - (apply - 'append - (mapcar - (lambda (x) - (let ((cache-hit - (tramp-get-file-property - v - (concat localname (substring filename 0 x)) - "file-name-all-completions" - nil))) - (when cache-hit (list cache-hit)))) - (tramp-compat-number-sequence (length filename) 0 -1))))) - - ;; Cache expired or no matching cache entry found so we need - ;; to perform a remote operation - (let (result) - ;; Get a list of directories and files, including reliably - ;; tagging the directories with a trailing '/'. Because I - ;; rock. --daniel@danann.net - - ;; Changed to perform `cd' in the same remote op and only - ;; get entries starting with `filename'. Capture any `cd' - ;; error messages. Ensure any `cd' and `echo' aliases are - ;; ignored. - (tramp-send-command - v - (if (tramp-get-remote-perl v) - (progn - (tramp-maybe-send-script - v tramp-perl-file-name-all-completions - "tramp_perl_file_name_all_completions") - (format "tramp_perl_file_name_all_completions %s %s %d" - (tramp-shell-quote-argument localname) - (tramp-shell-quote-argument filename) - (if (symbol-value - ;; `read-file-name-completion-ignore-case' - ;; is introduced with Emacs 22.1. - (if (boundp - 'read-file-name-completion-ignore-case) - 'read-file-name-completion-ignore-case - 'completion-ignore-case)) - 1 0))) - - (format (concat - "(\\cd %s 2>&1 && (%s %s -a 2>/dev/null" - ;; `ls' with wildcard might fail with `Argument - ;; list too long' error in some corner cases; if - ;; `ls' fails after `cd' succeeded, chances are - ;; that's the case, so let's retry without - ;; wildcard. This will return "too many" entries - ;; but that isn't harmful. - " || %s -a 2>/dev/null)" - " | while read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail") - (tramp-shell-quote-argument localname) - (tramp-get-ls-command v) - ;; When `filename' is empty, just `ls' without - ;; filename argument is more efficient than `ls *' - ;; for very large directories and might avoid the - ;; `Argument list too long' error. - ;; - ;; With and only with wildcard, we need to add - ;; `-d' to prevent `ls' from descending into - ;; sub-directories. - (if (zerop (length filename)) - "." - (concat (tramp-shell-quote-argument filename) "* -d")) - (tramp-get-ls-command v) - (tramp-get-test-command v)))) - - ;; Now grab the output. - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-max)) - - ;; Check result code, found in last line of output - (forward-line -1) - (if (looking-at "^fail$") - (progn - ;; Grab error message from line before last line - ;; (it was put there by `cd 2>&1') - (forward-line -1) - (tramp-error - v 'file-error - "tramp-handle-file-name-all-completions: %s" - (buffer-substring - (point) (tramp-compat-line-end-position)))) - ;; For peace of mind, if buffer doesn't end in `fail' - ;; then it should end in `ok'. If neither are in the - ;; buffer something went seriously wrong on the remote - ;; side. - (unless (looking-at "^ok$") - (tramp-error - v 'file-error - "\ -tramp-handle-file-name-all-completions: internal error accessing `%s': `%s'" - (tramp-shell-quote-argument localname) (buffer-string)))) - - (while (zerop (forward-line -1)) - (push (buffer-substring - (point) (tramp-compat-line-end-position)) - result))) - - ;; Because the remote op went through OK we know the - ;; directory we `cd'-ed to exists - (tramp-set-file-property - v localname "file-exists-p" t) - - ;; Because the remote op went through OK we know every - ;; file listed by `ls' exists. - (mapc (lambda (entry) - (tramp-set-file-property - v (concat localname entry) "file-exists-p" t)) - result) - - (tramp-set-file-property - v localname "last-completion" (current-time)) - - ;; Store result in the cache - (tramp-set-file-property - v (concat localname filename) - "file-name-all-completions" - result)))))))) - -(defun tramp-handle-file-name-completion - (filename directory &optional predicate) - "Like `file-name-completion' for Tramp files." - (unless (tramp-tramp-file-p directory) - (error - "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" - directory)) - (try-completion - filename - (mapcar 'list (file-name-all-completions filename directory)) - (when predicate - (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) - -;; cp, mv and ln - -(defun tramp-handle-add-name-to-file - (filename newname &optional ok-if-already-exists) - "Like `add-name-to-file' for Tramp files." - (unless (tramp-equal-remote filename newname) - (with-parsed-tramp-file-name - (if (tramp-tramp-file-p filename) filename newname) nil - (tramp-error - v 'file-error - "add-name-to-file: %s" - "only implemented for same method, same user, same host"))) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (let ((ln (when v1 (tramp-get-remote-ln v1)))) - (when (and (not ok-if-already-exists) - (file-exists-p newname) - (not (numberp ok-if-already-exists)) - (y-or-n-p - (format - "File %s already exists; make it a new name anyway? " - newname))) - (tramp-error - v2 'file-error - "add-name-to-file: file %s already exists" newname)) - (tramp-flush-file-property v2 (file-name-directory v2-localname)) - (tramp-flush-file-property v2 v2-localname) - (tramp-barf-unless-okay - v1 - (format "%s %s %s" ln (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname)) - "error with add-name-to-file, see buffer `%s' for details" - (buffer-name)))))) - -(defun tramp-handle-copy-file - (filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - (cond - ;; At least one file a Tramp file? - ((or (tramp-tramp-file-p filename) - (tramp-tramp-file-p newname)) - (tramp-do-copy-or-rename-file - 'copy filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context)) - ;; Compat section. - (preserve-selinux-context - (tramp-run-real-handler - 'copy-file - (list filename newname ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context))) - (preserve-uid-gid - (tramp-run-real-handler - 'copy-file - (list filename newname ok-if-already-exists keep-date preserve-uid-gid))) - (t - (tramp-run-real-handler - 'copy-file (list filename newname ok-if-already-exists keep-date))))) - -(defun tramp-handle-copy-directory (dirname newname &optional keep-date parents) - "Like `copy-directory' for Tramp files." - (let ((t1 (tramp-tramp-file-p dirname)) - (t2 (tramp-tramp-file-p newname))) - (with-parsed-tramp-file-name (if t1 dirname newname) nil - (if (and (tramp-get-method-parameter method 'tramp-copy-recursive) - ;; When DIRNAME and NEWNAME are remote, they must have - ;; the same method. - (or (null t1) (null t2) - (string-equal - (tramp-file-name-method (tramp-dissect-file-name dirname)) - (tramp-file-name-method (tramp-dissect-file-name newname))))) - ;; scp or rsync DTRT. - (progn - (setq dirname (directory-file-name (expand-file-name dirname)) - newname (directory-file-name (expand-file-name newname))) - (if (and (file-directory-p newname) - (not (string-equal (file-name-nondirectory dirname) - (file-name-nondirectory newname)))) - (setq newname - (expand-file-name - (file-name-nondirectory dirname) newname))) - (if (not (file-directory-p (file-name-directory newname))) - (make-directory (file-name-directory newname) parents)) - (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname keep-date)) - ;; We must do it file-wise. - (tramp-run-real-handler - 'copy-directory (list dirname newname keep-date parents))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname)))))) - -(defun tramp-handle-rename-file - (filename newname &optional ok-if-already-exists) - "Like `rename-file' for Tramp files." - ;; Check if both files are local -- invoke normal rename-file. - ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) - ;; At least one file a Tramp file? - (if (or (tramp-tramp-file-p filename) - (tramp-tramp-file-p newname)) - (tramp-do-copy-or-rename-file - 'rename filename newname ok-if-already-exists t t) - (tramp-run-real-handler - 'rename-file (list filename newname ok-if-already-exists)))) - -(defun tramp-do-copy-or-rename-file - (op filename newname &optional ok-if-already-exists keep-date - preserve-uid-gid preserve-selinux-context) - "Copy or rename a remote file. -OP must be `copy' or `rename' and indicates the operation to perform. -FILENAME specifies the file to copy or rename, NEWNAME is the name of -the new file (for copy) or the new name of the file (for rename). -OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. -KEEP-DATE means to make sure that NEWNAME has the same timestamp -as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep -the uid and gid if both files are on the same host. -PRESERVE-SELINUX-CONTEXT activates selinux commands. - -This function is invoked by `tramp-handle-copy-file' and -`tramp-handle-rename-file'. It is an error if OP is neither of `copy' -and `rename'. FILENAME and NEWNAME must be absolute file names." - (unless (memq op '(copy rename)) - (error "Unknown operation `%s', must be `copy' or `rename'" op)) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (context (and preserve-selinux-context - (apply 'file-selinux-context (list filename)))) - pr tm) - - (with-parsed-tramp-file-name (if t1 filename newname) nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error - v 'file-already-exists "File %s already exists" newname)) - - (with-progress-reporter - v 0 (format "%s %s to %s" - (if (eq op 'copy) "Copying" "Renaming") - filename newname) - - (cond - ;; Both are Tramp files. - ((and t1 t2) - (with-parsed-tramp-file-name filename v1 - (with-parsed-tramp-file-name newname v2 - (cond - ;; Shortcut: if method, host, user are the same for - ;; both files, we invoke `cp' or `mv' on the remote - ;; host directly. - ((tramp-equal-remote filename newname) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; Try out-of-band operation. - ((tramp-method-out-of-band-p - v1 (nth 7 (file-attributes filename))) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) - - ;; No shortcut was possible. So we copy the file - ;; first. If the operation was `rename', we go back - ;; and delete the original file (if the copy was - ;; successful). The approach is simple-minded: we - ;; create a new buffer, insert the contents of the - ;; source file into it, then write out the buffer to - ;; the target file. The advantage is that it doesn't - ;; matter which filename handlers are used for the - ;; source and target file. - (t - (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))))) - - ;; One file is a Tramp file, the other one is local. - ((or t1 t2) - (cond - ;; Fast track on local machine. - ((tramp-local-host-p v) - (tramp-do-copy-or-rename-file-directly - op filename newname - ok-if-already-exists keep-date preserve-uid-gid)) - - ;; If the Tramp file has an out-of-band method, the - ;; corresponding copy-program can be invoked. - ((tramp-method-out-of-band-p v (nth 7 (file-attributes filename))) - (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) - - ;; Use the inline method via a Tramp buffer. - (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) - - (t - ;; One of them must be a Tramp file. - (error "Tramp implementation says this cannot happen"))) - - ;; Handle `preserve-selinux-context'. - (when context (apply 'set-file-selinux-context (list newname context))) - - ;; In case of `rename', we must flush the cache of the source file. - (when (and t1 (eq op 'rename)) - (with-parsed-tramp-file-name filename v1 - (tramp-flush-file-property v1 (file-name-directory localname)) - (tramp-flush-file-property v1 localname))) - - ;; When newname did exist, we have wrong cached values. - (when t2 - (with-parsed-tramp-file-name newname v2 - (tramp-flush-file-property v2 (file-name-directory localname)) - (tramp-flush-file-property v2 localname))))))) - -(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) - "Use an Emacs buffer to copy or rename a file. -First arg OP is either `copy' or `rename' and indicates the operation. -FILENAME is the source file, NEWNAME the target file. -KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." - (with-temp-buffer - ;; We must disable multibyte, because binary data shall not be - ;; converted. - (set-buffer-multibyte nil) - (let ((coding-system-for-read 'binary) - (jka-compr-inhibit t)) - (insert-file-contents-literally filename)) - ;; We don't want the target file to be compressed, so we let-bind - ;; `jka-compr-inhibit' to t. - (let ((coding-system-for-write 'binary) - (jka-compr-inhibit t)) - (write-region (point-min) (point-max) newname))) - ;; KEEP-DATE handling. - (when keep-date (set-file-times newname (nth 5 (file-attributes filename)))) - ;; Set the mode. - (set-file-modes newname (tramp-default-file-modes filename)) - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) (delete-file filename))) - -(defun tramp-do-copy-or-rename-file-directly - (op filename newname ok-if-already-exists keep-date preserve-uid-gid) - "Invokes `cp' or `mv' on the remote system. -OP must be one of `copy' or `rename', indicating `cp' or `mv', -respectively. FILENAME specifies the file to copy or rename, -NEWNAME is the name of the new file (for copy) or the new name of -the file (for rename). Both files must reside on the same host. -KEEP-DATE means to make sure that NEWNAME has the same timestamp -as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep -the uid and gid from FILENAME." - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (file-times (nth 5 (file-attributes filename))) - (file-modes (tramp-default-file-modes filename))) - (with-parsed-tramp-file-name (if t1 filename newname) nil - (let* ((cmd (cond ((and (eq op 'copy) preserve-uid-gid) "cp -f -p") - ((eq op 'copy) "cp -f") - ((eq op 'rename) "mv -f") - (t (tramp-error - v 'file-error - "Unknown operation `%s', must be `copy' or `rename'" - op)))) - (localname1 - (if t1 - (tramp-file-name-handler 'file-remote-p filename 'localname) - filename)) - (localname2 - (if t2 - (tramp-file-name-handler 'file-remote-p newname 'localname) - newname)) - (prefix (file-remote-p (if t1 filename newname))) - cmd-result) - - (cond - ;; Both files are on a remote host, with same user. - ((and t1 t2) - (setq cmd-result - (tramp-send-command-and-check - v - (format "%s %s %s" cmd - (tramp-shell-quote-argument localname1) - (tramp-shell-quote-argument localname2)))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (unless - (or - (and keep-date - ;; Mask cp -f error. - (re-search-forward - tramp-operation-not-permitted-regexp nil t)) - (zerop cmd-result)) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (buffer-name))))) - - ;; We are on the local host. - ((or t1 t2) - (cond - ;; We can do it directly. - ((let (file-name-handler-alist) - (and (file-readable-p localname1) - (file-writable-p (file-name-directory localname2)) - (or (file-directory-p localname2) - (file-writable-p localname2)))) - (if (eq op 'copy) - (tramp-compat-copy-file - localname1 localname2 ok-if-already-exists - keep-date preserve-uid-gid) - (tramp-run-real-handler - 'rename-file (list localname1 localname2 ok-if-already-exists)))) - - ;; We can do it directly with `tramp-send-command' - ((and (file-readable-p (concat prefix localname1)) - (file-writable-p - (file-name-directory (concat prefix localname2))) - (or (file-directory-p (concat prefix localname2)) - (file-writable-p (concat prefix localname2)))) - (tramp-do-copy-or-rename-file-directly - op (concat prefix localname1) (concat prefix localname2) - ok-if-already-exists keep-date t) - ;; We must change the ownership to the local user. - (tramp-set-file-uid-gid - (concat prefix localname2) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - - ;; We need a temporary file in between. - (t - ;; Create the temporary file. - (let ((tmpfile (tramp-compat-make-temp-file localname1))) - (unwind-protect - (progn - (cond - (t1 - (or - (zerop - (tramp-send-command-and-check - v (format - "%s %s %s" cmd - (tramp-shell-quote-argument localname1) - (tramp-shell-quote-argument tmpfile)))) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (tramp-get-buffer v))) - ;; We must change the ownership as remote user. - ;; Since this does not work reliable, we also - ;; give read permissions. - (set-file-modes - (concat prefix tmpfile) (tramp-octal-to-decimal "0777")) - (tramp-set-file-uid-gid - (concat prefix tmpfile) - (tramp-get-local-uid 'integer) - (tramp-get-local-gid 'integer))) - (t2 - (if (eq op 'copy) - (tramp-compat-copy-file - localname1 tmpfile t - keep-date preserve-uid-gid) - (tramp-run-real-handler - 'rename-file - (list localname1 tmpfile t))) - ;; We must change the ownership as local user. - ;; Since this does not work reliable, we also - ;; give read permissions. - (set-file-modes tmpfile (tramp-octal-to-decimal "0777")) - (tramp-set-file-uid-gid - tmpfile - (tramp-get-remote-uid v 'integer) - (tramp-get-remote-gid v 'integer)))) - - ;; Move the temporary file to its destination. - (cond - (t2 - (or - (zerop - (tramp-send-command-and-check - v (format - "cp -f -p %s %s" - (tramp-shell-quote-argument tmpfile) - (tramp-shell-quote-argument localname2)))) - (tramp-error-with-buffer - nil v 'file-error - "Copying directly failed, see buffer `%s' for details." - (tramp-get-buffer v)))) - (t1 - (tramp-run-real-handler - 'rename-file - (list tmpfile localname2 ok-if-already-exists))))) - - ;; Save exit. - (condition-case nil - (delete-file tmpfile) - (error))))))))) - - ;; Set the time and mode. Mask possible errors. - (condition-case nil - (when keep-date - (set-file-times newname file-times) - (set-file-modes newname file-modes)) - (error))))) - -(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) - "Invoke rcp program to copy. -The method used must be an out-of-band method." - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - copy-program copy-args copy-env copy-keep-date port spec - source target) - - (with-parsed-tramp-file-name (if t1 filename newname) nil - (if (and t1 t2) - - ;; Both are Tramp files. We shall optimize it, when the - ;; methods for filename and newname are the same. - (let* ((dir-flag (file-directory-p filename)) - (tmpfile (tramp-compat-make-temp-file localname dir-flag))) - (if dir-flag - (setq tmpfile - (expand-file-name - (file-name-nondirectory newname) tmpfile))) - (unwind-protect - (progn - (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile keep-date) - (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname keep-date)) - ;; Save exit. - (condition-case nil - (if dir-flag - (tramp-compat-delete-directory - (expand-file-name ".." tmpfile) 'recursive) - (delete-file tmpfile)) - (error)))) - - ;; Expand hops. Might be necessary for gateway methods. - (setq v (car (tramp-compute-multi-hops v))) - (aset v 3 localname) - - ;; Check which ones of source and target are Tramp files. - (setq source (if t1 (tramp-make-copy-program-file-name v) filename) - target (funcall - (if (and (file-directory-p filename) - (string-equal - (file-name-nondirectory filename) - (file-name-nondirectory newname))) - 'file-name-directory - 'identity) - (if t2 (tramp-make-copy-program-file-name v) newname))) - - ;; Check for port number. Until now, there's no need for handling - ;; like method, user, host. - (setq host (tramp-file-name-real-host v) - port (tramp-file-name-port v) - port (or (and port (number-to-string port)) "")) - - ;; Compose copy command. - (setq spec (format-spec-make - ?h host ?u user ?p port - ?t (tramp-get-connection-property - (tramp-get-connection-process v) "temp-file" "") - ?k (if keep-date " " "")) - copy-program (tramp-get-method-parameter - method 'tramp-copy-program) - copy-keep-date (tramp-get-method-parameter - method 'tramp-copy-keep-date) - copy-args - (delq - nil - (mapcar - (lambda (x) - (setq - x - ;; " " is indication for keep-date argument. - (delete " " (mapcar (lambda (y) (format-spec y spec)) x))) - (unless (member "" x) (mapconcat 'identity x " "))) - (tramp-get-method-parameter method 'tramp-copy-args))) - copy-env - (delq - nil - (mapcar - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) - (tramp-get-method-parameter method 'tramp-copy-env)))) - - ;; Check for program. - (when (and (fboundp 'executable-find) - (not (let ((default-directory - (tramp-compat-temporary-file-directory))) - (executable-find copy-program)))) - (tramp-error - v 'file-error "Cannot find copy program: %s" copy-program)) - - ;; Set variables for computing the prompt for reading - ;; password. - (setq tramp-current-method (tramp-file-name-method v) - tramp-current-user (tramp-file-name-user v) - tramp-current-host (tramp-file-name-host v)) - - (unwind-protect - (with-temp-buffer - ;; The default directory must be remote. - (let ((default-directory - (file-name-directory (if t1 filename newname))) - (process-environment (copy-sequence process-environment))) - ;; Set the transfer process properties. - (tramp-set-connection-property - v "process-name" (buffer-name (current-buffer))) - (tramp-set-connection-property - v "process-buffer" (current-buffer)) - (while copy-env - (tramp-message v 5 "%s=\"%s\"" (car copy-env) (cadr copy-env)) - (setenv (pop copy-env) (pop copy-env))) - - ;; Use an asynchronous process. By this, password can - ;; be handled. The default directory must be local, in - ;; order to apply the correct `copy-program'. We don't - ;; set a timeout, because the copying of large files can - ;; last longer than 60 secs. - (let ((p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (apply 'start-process - (tramp-get-connection-property - v "process-name" nil) - (tramp-get-connection-property - v "process-buffer" nil) - copy-program - (append copy-args (list source target)))))) - (tramp-message - v 6 "%s" (mapconcat 'identity (process-command p) " ")) - (tramp-set-process-query-on-exit-flag p nil) - (tramp-process-actions p v tramp-actions-copy-out-of-band)))) - - ;; Reset the transfer process properties. - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil)) - - ;; Handle KEEP-DATE argument. - (when (and keep-date (not copy-keep-date)) - (set-file-times newname (nth 5 (file-attributes filename)))) - - ;; Set the mode. - (unless (and keep-date copy-keep-date) - (ignore-errors - (set-file-modes newname (tramp-default-file-modes filename))))) - - ;; If the operation was `rename', delete the original file. - (unless (eq op 'copy) - (if (file-regular-p filename) - (delete-file filename) - (tramp-compat-delete-directory filename 'recursive)))))) - -(defun tramp-handle-make-directory (dir &optional parents) - "Like `make-directory' for Tramp files." - (setq dir (expand-file-name dir)) - (with-parsed-tramp-file-name dir nil - (tramp-flush-directory-property v (file-name-directory localname)) - (save-excursion - (tramp-barf-unless-okay - v - (format "%s %s" - (if parents "mkdir -p" "mkdir") - (tramp-shell-quote-argument localname)) - "Couldn't make directory %s" dir)))) - -(defun tramp-handle-delete-directory (directory &optional recursive) - "Like `delete-directory' for Tramp files." - (setq directory (expand-file-name directory)) - (with-parsed-tramp-file-name directory nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) - (unless (zerop (tramp-send-command-and-check - v - (format - "%s %s" - (if recursive "rm -rf" "rmdir") - (tramp-shell-quote-argument localname)))) - (tramp-error v 'file-error "Couldn't delete %s" directory)))) - -(defun tramp-handle-delete-file (filename &optional trash) - "Like `delete-file' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - (unless - (zerop - (tramp-send-command-and-check - v (format "%s %s" - (or (and trash (tramp-get-remote-trash v)) "rm -f") - (tramp-shell-quote-argument localname)))) - (tramp-error v 'file-error "Couldn't delete %s" filename)))) - -;; Dired. - -;; CCC: This does not seem to be enough. Something dies when -;; we try and delete two directories under Tramp :/ -(defun tramp-handle-dired-recursive-delete-directory (filename) - "Recursively delete the directory given. -This is like `dired-recursive-delete-directory' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; Run a shell command 'rm -r <localname>' - ;; Code shamelessly stolen from the dired implementation and, um, hacked :) - (unless (file-exists-p filename) - (tramp-error v 'file-error "No such directory: %s" filename)) - ;; Which is better, -r or -R? (-r works for me <daniel@danann.net>) - (tramp-send-command - v - (format "rm -rf %s" (tramp-shell-quote-argument localname)) - ;; Don't read the output, do it explicitely. - nil t) - ;; Wait for the remote system to return to us... - ;; This might take a while, allow it plenty of time. - (tramp-wait-for-output (tramp-get-connection-process v) 120) - ;; Make sure that it worked... - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-directory-property v localname) - (and (file-exists-p filename) - (tramp-error - v 'file-error "Failed to recursively delete %s" filename)))) - -(defun tramp-handle-dired-compress-file (file &rest ok-flag) - "Like `dired-compress-file' for Tramp files." - ;; OK-FLAG is valid for XEmacs only, but not implemented. - ;; Code stolen mainly from dired-aux.el. - (with-parsed-tramp-file-name file nil - (tramp-flush-file-property v localname) - (save-excursion - (let ((suffixes - (if (not (featurep 'xemacs)) - ;; Emacs case - (symbol-value 'dired-compress-file-suffixes) - ;; XEmacs has `dired-compression-method-alist', which is - ;; transformed into `dired-compress-file-suffixes' structure. - (mapcar - (lambda (x) - (list (concat (regexp-quote (nth 1 x)) "\\'") - nil - (mapconcat 'identity (nth 3 x) " "))) - (symbol-value 'dired-compression-method-alist)))) - suffix) - ;; See if any suffix rule matches this file name. - (while suffixes - (let (case-fold-search) - (if (string-match (car (car suffixes)) localname) - (setq suffix (car suffixes) suffixes nil)) - (setq suffixes (cdr suffixes)))) - - (cond ((file-symlink-p file) - nil) - ((and suffix (nth 2 suffix)) - ;; We found an uncompression rule. - (with-progress-reporter v 0 (format "Uncompressing %s" file) - (when (zerop - (tramp-send-command-and-check - v (concat (nth 2 suffix) " " - (tramp-shell-quote-argument localname)))) - ;; `dired-remove-file' is not defined in XEmacs. - (tramp-compat-funcall 'dired-remove-file file) - (string-match (car suffix) file) - (concat (substring file 0 (match-beginning 0)))))) - (t - ;; We don't recognize the file as compressed, so compress it. - ;; Try gzip. - (with-progress-reporter v 0 (format "Compressing %s" file) - (when (zerop - (tramp-send-command-and-check - v (concat "gzip -f " - (tramp-shell-quote-argument localname)))) - ;; `dired-remove-file' is not defined in XEmacs. - (tramp-compat-funcall 'dired-remove-file file) - (cond ((file-exists-p (concat file ".gz")) - (concat file ".gz")) - ((file-exists-p (concat file ".z")) - (concat file ".z")) - (t nil)))))))))) - -(defun tramp-handle-dired-uncache (dir &optional dir-p) - "Like `dired-uncache' for Tramp files." - ;; DIR-P is valid for XEmacs only. - (with-parsed-tramp-file-name - (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil - (tramp-flush-directory-property v localname))) - -;; Pacify byte-compiler. The function is needed on XEmacs only. I'm -;; not sure at all that this is the right way to do it, but let's hope -;; it works for now, and wait for a guru to point out the Right Way to -;; achieve this. -;;(eval-when-compile -;; (unless (fboundp 'dired-insert-set-properties) -;; (fset 'dired-insert-set-properties 'ignore))) -;; Gerd suggests this: -(eval-when-compile (require 'dired)) -;; Note that dired is required at run-time, too, when it is needed. -;; It is only needed on XEmacs for the function -;; `dired-insert-set-properties'. - -(defun tramp-handle-insert-directory - (filename switches &optional wildcard full-directory-p) - "Like `insert-directory' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - (if (and (featurep 'ls-lisp) - (not (symbol-value 'ls-lisp-use-insert-directory-program))) - (tramp-run-real-handler - 'insert-directory (list filename switches wildcard full-directory-p)) - (when (stringp switches) - (setq switches (split-string switches))) - (when (and (member "--dired" switches) - (not (tramp-get-ls-command-with-dired v))) - (setq switches (delete "--dired" switches))) - (when wildcard - (setq wildcard (tramp-run-real-handler - 'file-name-nondirectory (list localname))) - (setq localname (tramp-run-real-handler - 'file-name-directory (list localname)))) - (unless full-directory-p - (setq switches (add-to-list 'switches "-d" 'append))) - (setq switches (mapconcat 'tramp-shell-quote-argument switches " ")) - (when wildcard - (setq switches (concat switches " " wildcard))) - (tramp-message - v 4 "Inserting directory `ls %s %s', wildcard %s, fulldir %s" - switches filename (if wildcard "yes" "no") - (if full-directory-p "yes" "no")) - ;; If `full-directory-p', we just say `ls -l FILENAME'. - ;; Else we chdir to the parent directory, then say `ls -ld BASENAME'. - (if full-directory-p - (tramp-send-command - v - (format "%s %s %s 2>/dev/null" - (tramp-get-ls-command v) - switches - (if wildcard - localname - (tramp-shell-quote-argument (concat localname "."))))) - (tramp-barf-unless-okay - v - (format "cd %s" (tramp-shell-quote-argument - (tramp-run-real-handler - 'file-name-directory (list localname)))) - "Couldn't `cd %s'" - (tramp-shell-quote-argument - (tramp-run-real-handler 'file-name-directory (list localname)))) - (tramp-send-command - v - (format "%s %s %s" - (tramp-get-ls-command v) - switches - (if (or wildcard - (zerop (length - (tramp-run-real-handler - 'file-name-nondirectory (list localname))))) - "" - (tramp-shell-quote-argument - (tramp-run-real-handler - 'file-name-nondirectory (list localname))))))) - (let ((beg (point))) - ;; We cannot use `insert-buffer-substring' because the Tramp - ;; buffer changes its contents before insertion due to calling - ;; `expand-file' and alike. - (insert - (with-current-buffer (tramp-get-buffer v) - (buffer-string))) - - ;; Check for "--dired" output. - (forward-line -2) - (when (looking-at "//SUBDIRED//") - (forward-line -1)) - (when (looking-at "//DIRED//\\s-+") - (let ((databeg (match-end 0)) - (end (tramp-compat-line-end-position))) - ;; Now read the numeric positions of file names. - (goto-char databeg) - (while (< (point) end) - (let ((start (+ beg (read (current-buffer)))) - (end (+ beg (read (current-buffer))))) - (if (memq (char-after end) '(?\n ?\ )) - ;; End is followed by \n or by " -> ". - (put-text-property start end 'dired-filename t)))))) - ;; Remove trailing lines. - (goto-char (tramp-compat-line-beginning-position)) - (while (looking-at "//") - (forward-line 1) - (delete-region (match-beginning 0) (point))) - - ;; The inserted file could be from somewhere else. - (when (and (not wildcard) (not full-directory-p)) - (goto-char (point-max)) - (when (file-symlink-p filename) - (goto-char (search-backward "->" beg 'noerror))) - (search-backward - (if (zerop (length (file-name-nondirectory filename))) - "." - (file-name-nondirectory filename)) - beg 'noerror) - (replace-match (file-relative-name filename) t)) - - (goto-char (point-max)))))) - -(defun tramp-handle-unhandled-file-name-directory (filename) - "Like `unhandled-file-name-directory' for Tramp files." - ;; With Emacs 23, we could simply return `nil'. But we must keep it - ;; for backward compatibility. - (expand-file-name "~/")) - -;; Canonicalization of file names. - -(defun tramp-handle-expand-file-name (name &optional dir) - "Like `expand-file-name' for Tramp files. -If the localname part of the given filename starts with \"/../\" then -the result will be a local, non-Tramp, filename." - ;; 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-connectable-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. This needs a shell which - ;; groks tilde expansion! The function `tramp-find-shell' is - ;; supposed to find such a shell on the remote host. Please - ;; tell me about it when this doesn't work on your system. - (when (string-match "\\`\\(~[^/]*\\)\\(.*\\)\\'" localname) - (let ((uname (match-string 1 localname)) - (fname (match-string 2 localname))) - ;; We cannot simply apply "~/", because under sudo "~/" is - ;; expanded to the local user home directory but to the - ;; root home directory. On the other hand, using always - ;; the default user name for tilde expansion is not - ;; appropriate either, because ssh and companions might - ;; use a user name from the config file. - (when (and (string-equal uname "~") - (string-match "\\`su\\(do\\)?\\'" method)) - (setq uname (concat uname user))) - (setq uname - (with-connection-property v uname - (tramp-send-command - v (format "cd %s; pwd" (tramp-shell-quote-argument uname))) - (with-current-buffer (tramp-get-buffer v) - (goto-char (point-min)) - (buffer-substring - (point) (tramp-compat-line-end-position))))) - (setq localname (concat uname fname)))) - ;; There might be a double slash, for example when "~/" - ;; expands to "/". Remove this. - (while (string-match "//" localname) - (setq localname (replace-match "/" t t localname))) - ;; No tilde characters in file name, do normal - ;; `expand-file-name' (this does "/./" and "/../"). We bind - ;; `directory-sep-char' here for XEmacs on Windows, which would - ;; otherwise use backslash. `default-directory' is bound, - ;; because on Windows there would be problems with UNC shares or - ;; Cygwin mounts. - (let ((directory-sep-char ?/) - (default-directory (tramp-compat-temporary-file-directory))) - (tramp-make-tramp-file-name - method user host - (tramp-drop-volume-letter - (tramp-run-real-handler - 'expand-file-name (list localname)))))))) + (logand (default-file-modes) (tramp-compat-octal-to-decimal "0666")))) (defun tramp-replace-environment-variables (filename) "Replace environment variables in FILENAME. @@ -4446,38 +1641,6 @@ Return the string with the replaced variables." t nil filename))) filename))) -(defun tramp-handle-substitute-in-file-name (filename) - "Like `substitute-in-file-name' for Tramp files. -\"//\" and \"/~\" substitute only in the local filename part. -If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at -beginning of local filename are not substituted." - ;; First, we must replace environment variables. - (setq filename (tramp-replace-environment-variables filename)) - (with-parsed-tramp-file-name filename nil - (if (equal tramp-syntax 'url) - ;; We need to check localname only. The other parts cannot contain - ;; "//" or "/~". - (if (and (> (length localname) 1) - (or (string-match "//" localname) - (string-match "/~" localname 1))) - (tramp-run-real-handler 'substitute-in-file-name (list filename)) - (tramp-make-tramp-file-name - (when method (substitute-in-file-name method)) - (when user (substitute-in-file-name user)) - (when host (substitute-in-file-name host)) - (when localname - (tramp-run-real-handler - 'substitute-in-file-name (list localname))))) - ;; Ignore in LOCALNAME everything before "//" or "/~". - (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) - (setq filename - (concat (file-remote-p filename) - (replace-match "\\1" nil nil localname))) - ;; "/m:h:~" does not work for completion. We use "/m:h:~/". - (when (string-match "~$" filename) - (setq filename (concat filename "/")))) - (tramp-run-real-handler 'substitute-in-file-name (list filename))))) - ;; In XEmacs, electricity is implemented via a key map for ?/ and ?~, ;; which calls corresponding functions (see minibuf.el). (when (fboundp 'minibuffer-electric-separator) @@ -4507,411 +1670,6 @@ beginning of local filename are not substituted." '(minibuffer-electric-separator minibuffer-electric-tilde))) - -;;; Remote commands: - -(defun tramp-handle-executable-find (command) - "Like `executable-find' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - (tramp-find-executable v command (tramp-get-remote-path v) t))) - -(defun tramp-process-sentinel (proc event) - "Flush file caches." - (unless (memq (process-status proc) '(run open)) - (let ((vec (tramp-get-connection-property proc "vector" nil))) - (when vec - (tramp-message vec 5 "Sentinel called: `%s' `%s'" proc event) - (tramp-flush-directory-property vec ""))))) - -;; We use BUFFER also as connection buffer during setup. Because of -;; this, its original contents must be saved, and restored once -;; connection has been setup. -(defun tramp-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - (with-parsed-tramp-file-name default-directory nil - ;; When PROGRAM is nil, we just provide a tty. - (let ((command - (when (stringp program) - (format "cd %s; exec %s" - (tramp-shell-quote-argument localname) - (mapconcat 'tramp-shell-quote-argument - (cons program args) " ")))) - (tramp-process-connection-type - (or (null program) tramp-process-connection-type)) - (bmp (and (buffer-live-p buffer) (buffer-modified-p buffer))) - (name1 name) - (i 0)) - (unwind-protect - (save-excursion - (save-restriction - (unless buffer - ;; BUFFER can be nil. We use a temporary buffer. - (setq buffer (generate-new-buffer tramp-temp-buffer-name))) - (while (get-process name1) - ;; NAME must be unique as process name. - (setq i (1+ i) - name1 (format "%s<%d>" name i))) - (setq name name1) - ;; Set the new process properties. - (tramp-set-connection-property v "process-name" name) - (tramp-set-connection-property v "process-buffer" buffer) - ;; Activate narrowing in order to save BUFFER contents. - ;; Clear also the modification time; otherwise we might - ;; be interrupted by `verify-visited-file-modtime'. - (with-current-buffer (tramp-get-connection-buffer v) - (let ((buffer-undo-list t)) - (clear-visited-file-modtime) - (narrow-to-region (point-max) (point-max)) - (if command - ;; Send the command. - (tramp-send-command v command nil t) ; nooutput - ;; Check, whether a pty is associated. - (tramp-maybe-open-connection v) - (unless (process-get - (tramp-get-connection-process v) 'remote-tty) - (tramp-error - v 'file-error - "pty association is not supported for `%s'" name))))) - (let ((p (tramp-get-connection-process v))) - ;; Set sentinel and query flag for this process. - (tramp-set-connection-property p "vector" v) - (set-process-sentinel p 'tramp-process-sentinel) - (tramp-set-process-query-on-exit-flag p t) - ;; Return process. - p))) - ;; Save exit. - (with-current-buffer (tramp-get-connection-buffer v) - (if (string-match tramp-temp-buffer-name (buffer-name)) - (progn - (set-process-buffer (tramp-get-connection-process v) nil) - (kill-buffer (current-buffer))) - (set-buffer-modified-p bmp))) - (tramp-set-connection-property v "process-name" nil) - (tramp-set-connection-property v "process-buffer" nil))))) - -(defun tramp-handle-process-file - (program &optional infile destination display &rest args) - "Like `process-file' for Tramp files." - ;; The implementation is not complete yet. - (when (and (numberp destination) (zerop destination)) - (error "Implementation does not handle immediate return")) - - (with-parsed-tramp-file-name default-directory nil - (let (command input tmpinput stderr tmpstderr outbuf ret) - ;; Compute command. - (setq command (mapconcat 'tramp-shell-quote-argument - (cons program args) " ")) - ;; Determine input. - (if (null infile) - (setq input "/dev/null") - (setq infile (expand-file-name infile)) - (if (tramp-equal-remote default-directory infile) - ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) - ;; INFILE must be copied to remote host. - (setq input (tramp-make-tramp-temp-file v) - tmpinput (tramp-make-tramp-file-name method user host input)) - (copy-file infile tmpinput t))) - (when input (setq command (format "%s <%s" command input))) - - ;; Determine output. - (cond - ;; Just a buffer. - ((bufferp destination) - (setq outbuf destination)) - ;; A buffer name. - ((stringp destination) - (setq outbuf (get-buffer-create destination))) - ;; (REAL-DESTINATION ERROR-DESTINATION) - ((consp destination) - ;; output. - (cond - ((bufferp (car destination)) - (setq outbuf (car destination))) - ((stringp (car destination)) - (setq outbuf (get-buffer-create (car destination)))) - ((car destination) - (setq outbuf (current-buffer)))) - ;; stderr. - (cond - ((stringp (cadr destination)) - (setcar (cdr destination) (expand-file-name (cadr destination))) - (if (tramp-equal-remote default-directory (cadr destination)) - ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) - ;; stderr must be copied to remote host. The temporary - ;; file must be deleted after execution. - (setq stderr (tramp-make-tramp-temp-file v) - tmpstderr (tramp-make-tramp-file-name - method user host stderr)))) - ;; stderr to be discarded. - ((null (cadr destination)) - (setq stderr "/dev/null")))) - ;; 't - (destination - (setq outbuf (current-buffer)))) - (when stderr (setq command (format "%s 2>%s" command stderr))) - - ;; Send the command. It might not return in time, so we protect - ;; it. Call it in a subshell, in order to preserve working - ;; directory. - (condition-case nil - (unwind-protect - (setq ret - (tramp-send-command-and-check - v (format "\\cd %s; %s" - (tramp-shell-quote-argument localname) - command) - t t)) - ;; We should show the output anyway. - (when outbuf - (with-current-buffer outbuf - (insert - (with-current-buffer (tramp-get-connection-buffer v) - (buffer-string)))) - (when display (display-buffer outbuf)))) - ;; When the user did interrupt, we should do it also. We use - ;; return code -1 as marker. - (quit - (kill-buffer (tramp-get-connection-buffer v)) - (setq ret -1)) - ;; Handle errors. - (error - (kill-buffer (tramp-get-connection-buffer v)) - (setq ret 1))) - - ;; Provide error file. - (when tmpstderr (rename-file tmpstderr (cadr destination) t)) - - ;; Cleanup. We remove all file cache values for the connection, - ;; because the remote process could have changed them. - (when tmpinput (delete-file tmpinput)) - - ;; `process-file-side-effects' has been introduced with GNU - ;; Emacs 23.2. If set to `nil', no remote file will be changed - ;; by `program'. If it doesn't exist, we assume its default - ;; value 't'. - (unless (and (boundp 'process-file-side-effects) - (not (symbol-value 'process-file-side-effects))) - (tramp-flush-directory-property v "")) - - ;; Return exit status. - (if (equal ret -1) - (keyboard-quit) - ret)))) - -(defun tramp-local-call-process - (program &optional infile destination display &rest args) - "Calls `call-process' on the local host. -This is needed because for some Emacs flavors Tramp has -defadviced `call-process' to behave like `process-file'. The -Lisp error raised when PROGRAM is nil is trapped also, returning 1." - (let ((default-directory - (if (file-remote-p default-directory) - (tramp-compat-temporary-file-directory) - default-directory))) - (if (executable-find program) - (apply 'call-process program infile destination display args) - 1))) - -(defun tramp-handle-call-process-region - (start end program &optional delete buffer display &rest args) - "Like `call-process-region' for Tramp files." - (let ((tmpfile (tramp-compat-make-temp-file ""))) - (write-region start end tmpfile) - (when delete (delete-region start end)) - (unwind-protect - (apply 'call-process program tmpfile buffer display args) - (delete-file tmpfile)))) - -(defun tramp-handle-shell-command - (command &optional output-buffer error-buffer) - "Like `shell-command' for Tramp files." - (let* ((asynchronous (string-match "[ \t]*&[ \t]*\\'" command)) - ;; We cannot use `shell-file-name' and `shell-command-switch', - ;; they are variables of the local host. - (args (list - (tramp-get-method-parameter - (tramp-file-name-method - (tramp-dissect-file-name default-directory)) - 'tramp-remote-sh) - "-c" (substring command 0 asynchronous))) - current-buffer-p - (output-buffer - (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) - (output-buffer - (setq current-buffer-p t) - (current-buffer)) - (t (get-buffer-create - (if asynchronous - "*Async Shell Command*" - "*Shell Command Output*"))))) - (error-buffer - (cond - ((bufferp error-buffer) error-buffer) - ((stringp error-buffer) (get-buffer-create error-buffer)))) - (buffer - (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer (tramp-make-tramp-temp-file v))) - output-buffer)) - (p (get-buffer-process output-buffer))) - - ;; Check whether there is another process running. Tramp does not - ;; support 2 (asynchronous) processes in parallel. - (when p - (if (yes-or-no-p "A command is running. Kill it? ") - (condition-case nil - (kill-process p) - (error nil)) - (error "Shell command in progress"))) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) - (with-current-buffer output-buffer - (setq buffer-read-only nil) - (erase-buffer))) - - (if (and (not current-buffer-p) (integerp asynchronous)) - (prog1 - ;; Run the process. - (apply 'start-file-process "*Async Shell*" buffer args) - ;; Display output. - (pop-to-buffer output-buffer) - (setq mode-line-process '(":%s")) - (require 'shell) (shell-mode)) - - (prog1 - ;; Run the process. - (apply 'process-file (car args) nil buffer nil (cdr args)) - ;; Insert error messages if they were separated. - (when (listp buffer) - (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) - (if current-buffer-p - ;; This is like exchange-point-and-mark, but doesn't - ;; activate the mark. It is cleaner to avoid activation, - ;; even though the command loop would deactivate the mark - ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) - ;; There's some output, display it. - (when (with-current-buffer output-buffer (> (point-max) (point-min))) - (if (functionp 'display-message-or-buffer) - (tramp-compat-funcall 'display-message-or-buffer output-buffer) - (pop-to-buffer output-buffer)))))))) - -;; File Editing. - -(defvar tramp-handle-file-local-copy-hook nil - "Normal hook to be run at the end of `tramp-handle-file-local-copy'.") - -(defun tramp-handle-file-local-copy (filename) - "Like `file-local-copy' for Tramp files." - - (with-parsed-tramp-file-name filename nil - (unless (file-exists-p filename) - (tramp-error - v 'file-error - "Cannot make local copy of non-existing file `%s'" filename)) - - (let* ((size (nth 7 (file-attributes filename))) - (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) - (loc-dec (tramp-get-inline-coding v "local-decoding" size)) - (tmpfile (tramp-compat-make-temp-file filename))) - - (condition-case err - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (copy-file filename tmpfile t t)) - - ;; Use inline encoding for file transfer. - (rem-enc - (save-excursion - (with-progress-reporter - v 3 (format "Encoding remote file %s" filename) - (tramp-barf-unless-okay - v (format rem-enc (tramp-shell-quote-argument localname)) - "Encoding remote file failed")) - - (if (functionp loc-dec) - ;; If local decoding is a function, we call it. We - ;; must disable multibyte, because - ;; `uudecode-decode-region' doesn't handle it - ;; correctly. - (with-temp-buffer - (set-buffer-multibyte nil) - (insert-buffer-substring (tramp-get-buffer v)) - (with-progress-reporter - v 3 (format "Decoding remote file %s with function %s" - filename loc-dec) - (funcall loc-dec (point-min) (point-max)) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfile)))) - - ;; If tramp-decoding-function is not defined for this - ;; method, we invoke tramp-decoding-command instead. - (let ((tmpfile2 (tramp-compat-make-temp-file filename))) - ;; Unset `file-name-handler-alist'. Otherwise, - ;; epa-file gets confused. - (let (file-name-handler-alist - (coding-system-for-write 'binary)) - (write-region (point-min) (point-max) tmpfile2)) - (with-progress-reporter - v 3 (format "Decoding remote file %s with command %s" - filename loc-dec) - (unwind-protect - (tramp-call-local-coding-command - loc-dec tmpfile2 tmpfile) - (delete-file tmpfile2))))) - - ;; Set proper permissions. - (set-file-modes tmpfile (tramp-default-file-modes filename)) - ;; Set local user ownership. - (tramp-set-file-uid-gid tmpfile))) - - ;; Oops, I don't know what to do. - (t (tramp-error - v 'file-error "Wrong method specification for `%s'" method))) - - ;; Error handling. - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - (run-hooks 'tramp-handle-file-local-copy-hook) - tmpfile))) - -(defun tramp-handle-file-remote-p (filename &optional identification connected) - "Like `file-remote-p' for Tramp files." - (let ((tramp-verbose 3)) - (when (tramp-tramp-file-p filename) - (let* ((v (tramp-dissect-file-name filename)) - (p (tramp-get-connection-process v)) - (c (and p (processp p) (memq (process-status p) '(run open))))) - ;; We expand the file name only, if there is already a connection. - (with-parsed-tramp-file-name - (if c (expand-file-name filename) filename) nil - (and (or (not connected) c) - (cond - ((eq identification 'method) method) - ((eq identification 'user) user) - ((eq identification 'host) host) - ((eq identification 'localname) localname) - (t (tramp-make-tramp-file-name method user host ""))))))))) - (defun tramp-find-file-name-coding-system-alist (filename tmpname) "Like `find-operation-coding-system' for Tramp filenames. Tramp's `insert-file-contents' and `write-region' work over @@ -4927,535 +1685,6 @@ coding system might not be determined. This function repairs it." (add-to-list 'result (cons (regexp-quote tmpname) (cdr elt)) 'append))))) -(defun tramp-handle-insert-file-contents - (filename &optional visit beg end replace) - "Like `insert-file-contents' for Tramp files." - (barf-if-buffer-read-only) - (setq filename (expand-file-name filename)) - (let (result local-copy remote-copy) - (with-parsed-tramp-file-name filename nil - (unwind-protect - (if (not (file-exists-p filename)) - ;; We don't raise a Tramp error, because it might be - ;; suppressed, like in `find-file-noselect-1'. - (signal 'file-error - (list "File not found on remote host" filename)) - - (if (and (tramp-local-host-p v) - (let (file-name-handler-alist) - (file-readable-p localname))) - ;; Short track: if we are on the local host, we can - ;; run directly. - (setq result - (tramp-run-real-handler - 'insert-file-contents - (list localname visit beg end replace))) - - ;; When we shall insert only a part of the file, we copy - ;; this part. - (when (or beg end) - (setq remote-copy (tramp-make-tramp-temp-file v)) - (tramp-send-command - v - (cond - ((and beg end) - (format "tail -c +%d %s | head -c +%d >%s" - (1+ beg) (tramp-shell-quote-argument localname) - (- end beg) remote-copy)) - (beg - (format "tail -c +%d %s >%s" - (1+ beg) (tramp-shell-quote-argument localname) - remote-copy)) - (end - (format "head -c +%d %s >%s" - (1+ end) (tramp-shell-quote-argument localname) - remote-copy))))) - - ;; `insert-file-contents-literally' takes care to avoid - ;; calling jka-compr. By let-binding - ;; `inhibit-file-name-operation', we propagate that care - ;; to the `file-local-copy' operation. - (setq local-copy - (let ((inhibit-file-name-operation - (when (eq inhibit-file-name-operation - 'insert-file-contents) - 'file-local-copy))) - (cond - ((stringp remote-copy) - (file-local-copy - (tramp-make-tramp-file-name - method user host remote-copy))) - ((stringp tramp-temp-buffer-file-name) - (copy-file filename tramp-temp-buffer-file-name 'ok) - tramp-temp-buffer-file-name) - (t (file-local-copy filename))))) - - ;; When the file is not readable for the owner, it - ;; cannot be inserted, even it is redable for the group - ;; or for everybody. - (set-file-modes local-copy (tramp-octal-to-decimal "0600")) - - (when (and (null remote-copy) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - ;; We keep the local file for performance reasons, - ;; useful for "rsync". - (setq tramp-temp-buffer-file-name local-copy) - (put 'tramp-temp-buffer-file-name 'permanent-local t)) - - (with-progress-reporter - v 3 (format "Inserting local temp file `%s'" local-copy) - ;; We must ensure that `file-coding-system-alist' - ;; matches `local-copy'. - (let ((file-coding-system-alist - (tramp-find-file-name-coding-system-alist - filename local-copy))) - (setq result - (insert-file-contents - local-copy nil nil nil replace)))))) - - ;; Save exit. - (progn - (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) - (set-visited-file-modtime) - (set-buffer-modified-p nil) - ;; For root, preserve owner and group when editing files. - (when (string-equal (file-remote-p filename 'user) "root") - (set (make-local-variable 'backup-by-copying-when-mismatch) t))) - (when (and (stringp local-copy) - (or remote-copy (null tramp-temp-buffer-file-name))) - (delete-file local-copy)) - (when (stringp remote-copy) - (delete-file - (tramp-make-tramp-file-name method user host remote-copy)))))) - - ;; Result. - (list (expand-file-name filename) - (cadr result)))) - -;; This is needed for XEmacs only. Code stolen from files.el. -(defun tramp-handle-insert-file-contents-literally - (filename &optional visit beg end replace) - "Like `insert-file-contents-literally' for Tramp files." - (let ((format-alist nil) - (after-insert-file-functions nil) - (coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion) - (find-buffer-file-type-function - (if (fboundp 'find-buffer-file-type) - (symbol-function 'find-buffer-file-type) - nil)) - (inhibit-file-name-handlers '(jka-compr-handler image-file-handler)) - (inhibit-file-name-operation 'insert-file-contents)) - (unwind-protect - (progn - (fset 'find-buffer-file-type (lambda (filename) t)) - (insert-file-contents filename visit beg end replace)) - ;; Save exit. - (if find-buffer-file-type-function - (fset 'find-buffer-file-type find-buffer-file-type-function) - (fmakunbound 'find-buffer-file-type))))) - -(defun tramp-handle-find-backup-file-name (filename) - "Like `find-backup-file-name' for Tramp files." - (with-parsed-tramp-file-name filename nil - ;; We set both variables. It doesn't matter whether it is - ;; Emacs or XEmacs. - (let ((backup-directory-alist - ;; Emacs case. - (when (boundp 'backup-directory-alist) - (if (symbol-value 'tramp-backup-directory-alist) - (mapcar - (lambda (x) - (cons - (car x) - (if (and (stringp (cdr x)) - (file-name-absolute-p (cdr x)) - (not (tramp-file-name-p (cdr x)))) - (tramp-make-tramp-file-name method user host (cdr x)) - (cdr x)))) - (symbol-value 'tramp-backup-directory-alist)) - (symbol-value 'backup-directory-alist)))) - - (bkup-backup-directory-info - ;; XEmacs case. - (when (boundp 'bkup-backup-directory-info) - (if (symbol-value 'tramp-bkup-backup-directory-info) - (mapcar - (lambda (x) - (nconc - (list (car x)) - (list - (if (and (stringp (car (cdr x))) - (file-name-absolute-p (car (cdr x))) - (not (tramp-file-name-p (car (cdr x))))) - (tramp-make-tramp-file-name - method user host (car (cdr x))) - (car (cdr x)))) - (cdr (cdr x)))) - (symbol-value 'tramp-bkup-backup-directory-info)) - (symbol-value 'bkup-backup-directory-info))))) - - (tramp-run-real-handler 'find-backup-file-name (list filename))))) - -(defun tramp-handle-make-auto-save-file-name () - "Like `make-auto-save-file-name' for Tramp files. -Returns a file name in `tramp-auto-save-directory' for autosaving this file." - (let ((tramp-auto-save-directory tramp-auto-save-directory) - (buffer-file-name - (tramp-subst-strs-in-string - '(("_" . "|") - ("/" . "_a") - (":" . "_b") - ("|" . "__") - ("[" . "_l") - ("]" . "_r")) - (buffer-file-name)))) - ;; File name must be unique. This is ensured with Emacs 22 (see - ;; UNIQUIFY element of `auto-save-file-name-transforms'); but for - ;; all other cases we must do it ourselves. - (when (boundp 'auto-save-file-name-transforms) - (mapc - (lambda (x) - (when (and (string-match (car x) buffer-file-name) - (not (car (cddr x)))) - (setq tramp-auto-save-directory - (or tramp-auto-save-directory - (tramp-compat-temporary-file-directory))))) - (symbol-value 'auto-save-file-name-transforms))) - ;; Create directory. - (when tramp-auto-save-directory - (setq buffer-file-name - (expand-file-name buffer-file-name tramp-auto-save-directory)) - (unless (file-exists-p tramp-auto-save-directory) - (make-directory tramp-auto-save-directory t))) - ;; Run plain `make-auto-save-file-name'. There might be an advice when - ;; it is not a magic file name operation (since Emacs 22). - ;; We must deactivate it temporarily. - (if (not (ad-is-active 'make-auto-save-file-name)) - (tramp-run-real-handler 'make-auto-save-file-name nil) - ;; else - (ad-deactivate 'make-auto-save-file-name) - (prog1 - (tramp-run-real-handler 'make-auto-save-file-name nil) - (ad-activate 'make-auto-save-file-name))))) - -(defvar tramp-handle-write-region-hook nil - "Normal hook to be run at the end of `tramp-handle-write-region'.") - -;; CCC grok LOCKNAME -(defun tramp-handle-write-region - (start end filename &optional append visit lockname confirm) - "Like `write-region' for Tramp files." - (setq filename (expand-file-name filename)) - (with-parsed-tramp-file-name filename nil - ;; Following part commented out because we don't know what to do about - ;; file locking, and it does not appear to be a problem to ignore it. - ;; Ange-ftp ignores it, too. - ;; (when (and lockname (stringp lockname)) - ;; (setq lockname (expand-file-name lockname))) - ;; (unless (or (eq lockname nil) - ;; (string= lockname filename)) - ;; (error - ;; "tramp-handle-write-region: LOCKNAME must be nil or equal FILENAME")) - - ;; XEmacs takes a coding system as the seventh argument, not `confirm'. - (when (and (not (featurep 'xemacs)) confirm (file-exists-p filename)) - (unless (y-or-n-p (format "File %s exists; overwrite anyway? " filename)) - (tramp-error v 'file-error "File not overwritten"))) - - (let ((uid (or (nth 2 (tramp-compat-file-attributes filename 'integer)) - (tramp-get-remote-uid v 'integer))) - (gid (or (nth 3 (tramp-compat-file-attributes filename 'integer)) - (tramp-get-remote-gid v 'integer)))) - - (if (and (tramp-local-host-p v) - ;; `file-writable-p' calls `file-expand-file-name'. We - ;; cannot use `tramp-run-real-handler' therefore. - (let (file-name-handler-alist) - (and - (file-writable-p (file-name-directory localname)) - (or (file-directory-p localname) - (file-writable-p localname))))) - ;; Short track: if we are on the local host, we can run directly. - (tramp-run-real-handler - 'write-region - (list start end localname append 'no-message lockname confirm)) - - (let ((modes (save-excursion (tramp-default-file-modes filename))) - ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp - ;; file. At the end of the function, we set - ;; `last-coding-system-used' to this saved value. This - ;; way, any intermediary coding systems used while - ;; talking to the remote shell or suchlike won't hose - ;; this variable. This approach was snarfed from - ;; ange-ftp.el. - coding-system-used - ;; Write region into a tmp file. This isn't really - ;; needed if we use an encoding function, but currently - ;; we use it always because this makes the logic - ;; simpler. - (tmpfile (or tramp-temp-buffer-file-name - (tramp-compat-make-temp-file filename)))) - - ;; If `append' is non-nil, we copy the file locally, and let - ;; the native `write-region' implementation do the job. - (when append (copy-file filename tmpfile 'ok)) - - ;; We say `no-message' here because we don't want the - ;; visited file modtime data to be clobbered from the temp - ;; file. We call `set-visited-file-modtime' ourselves later - ;; on. We must ensure that `file-coding-system-alist' - ;; matches `tmpfile'. - (let (file-name-handler-alist - (file-coding-system-alist - (tramp-find-file-name-coding-system-alist filename tmpfile))) - (condition-case err - (tramp-run-real-handler - 'write-region - (list start end tmpfile append 'no-message lockname confirm)) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Now, `last-coding-system-used' has the right value. Remember it. - (when (boundp 'last-coding-system-used) - (setq coding-system-used - (symbol-value 'last-coding-system-used)))) - - ;; The permissions of the temporary file should be set. If - ;; filename does not exist (eq modes nil) it has been - ;; renamed to the backup file. This case `save-buffer' - ;; handles permissions. - ;; Ensure, that it is still readable. - (when modes - (set-file-modes - tmpfile (logior (or modes 0) (tramp-octal-to-decimal "0400")))) - - ;; This is a bit lengthy due to the different methods - ;; possible for file transfer. First, we check whether the - ;; method uses an rcp program. If so, we call it. - ;; Otherwise, both encoding and decoding command must be - ;; specified. However, if the method _also_ specifies an - ;; encoding function, then that is used for encoding the - ;; contents of the tmp file. - (let* ((size (nth 7 (file-attributes tmpfile))) - (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) - (loc-enc (tramp-get-inline-coding v "local-encoding" size))) - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p v size)) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. - (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. - (unwind-protect - (with-temp-buffer - (set-buffer-multibyte nil) - ;; Use encoding function or command. - (if (functionp loc-enc) - (with-progress-reporter - v 3 (format "Encoding region using function `%s'" - loc-enc) - (let ((coding-system-for-read 'binary)) - (insert-file-contents-literally tmpfile)) - ;; The following `let' is a workaround for the - ;; base64.el that comes with pgnus-0.84. If - ;; both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (funcall loc-enc (point-min) (point-max)))) - - (with-progress-reporter - v 3 (format "Encoding region using command `%s'" - loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc tmpfile t)) - (tramp-error - v 'file-error - (concat "Cannot write to `%s', " - "local encoding command `%s' failed") - filename loc-enc)))) - - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (with-progress-reporter - v 3 - (format "Decoding region into remote file %s" filename) - (goto-char (point-max)) - (unless (bolp) (newline)) - (tramp-send-command - v - (format - (concat rem-dec " <<'EOF'\n%sEOF") - (tramp-shell-quote-argument localname) - (buffer-string))) - (tramp-barf-unless-okay - v nil - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-local-call-process "cksum" tmpfile t)) - ;; cksum runs remotely. - (zerop - (tramp-send-command-and-check - v - (format - "cksum <%s" - (tramp-shell-quote-argument localname)))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) - (tramp-error - v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") - filename rem-dec))))) - - ;; Save exit. - (delete-file tmpfile))) - - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an rcp program") - method)))) - - ;; Make `last-coding-system-used' have the right value. - (when coding-system-used - (set 'last-coding-system-used coding-system-used)))) - - (tramp-flush-file-property v (file-name-directory localname)) - (tramp-flush-file-property v localname) - - ;; We must protect `last-coding-system-used', now we have set it - ;; to its correct value. - (let (last-coding-system-used (need-chown t)) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (let ((file-attr (file-attributes filename))) - (set-visited-file-modtime - ;; We must pass modtime explicitely, because filename can - ;; be different from (buffer-file-name), f.e. if - ;; `file-precious-flag' is set. - (nth 5 file-attr)) - (when (and (eq (nth 2 file-attr) uid) - (eq (nth 3 file-attr) gid)) - (setq need-chown nil)))) - - ;; Set the ownership. - (when need-chown - (tramp-set-file-uid-gid filename uid gid)) - (when (or (eq visit t) (null visit) (stringp visit)) - (tramp-message v 0 "Wrote %s" filename)) - (run-hooks 'tramp-handle-write-region-hook))))) - -(defvar tramp-vc-registered-file-names nil - "List used to collect file names, which are checked during `vc-registered'.") - -;; VC backends check for the existence of various different special -;; files. This is very time consuming, because every single check -;; requires a remote command (the file cache must be invalidated). -;; Therefore, we apply a kind of optimization. We install the file -;; name handler `tramp-vc-file-name-handler', which does nothing but -;; remembers all file names for which `file-exists-p' or -;; `file-readable-p' has been applied. A first run of `vc-registered' -;; is performed. Afterwards, a script is applied for all collected -;; file names, using just one remote command. The result of this -;; script is used to fill the file cache with actual values. Now we -;; can reset the file name handlers, and we make a second run of -;; `vc-registered', which returns the expected result without sending -;; any other remote command. -(defun tramp-handle-vc-registered (file) - "Like `vc-registered' for Tramp files." - (with-temp-message "" - (with-parsed-tramp-file-name file nil - (with-progress-reporter - v 3 (format "Checking `vc-registered' for %s" file) - - ;; There could be new files, created by the vc backend. We - ;; cannot reuse the old cache entries, therefore. - (let (tramp-vc-registered-file-names - (tramp-cache-inhibit-cache (current-time)) - (file-name-handler-alist - `((,tramp-file-name-regexp . tramp-vc-file-name-handler)))) - - ;; Here we collect only file names, which need an operation. - (tramp-run-real-handler 'vc-registered (list file)) - (tramp-message v 10 "\n%s" tramp-vc-registered-file-names) - - ;; Send just one command, in order to fill the cache. - (when tramp-vc-registered-file-names - (tramp-maybe-send-script - v - (format tramp-vc-registered-read-file-names - (tramp-get-file-exists-command v) - (format "%s -r" (tramp-get-test-command v))) - "tramp_vc_registered_read_file_names") - - (dolist - (elt - (tramp-send-command-and-read - v - (format - "tramp_vc_registered_read_file_names <<'EOF'\n%s\nEOF\n" - (mapconcat 'tramp-shell-quote-argument - tramp-vc-registered-file-names - "\n")))) - - (tramp-set-file-property - v (car elt) (cadr elt) (cadr (cdr elt)))))) - - ;; Second run. Now all `file-exists-p' or `file-readable-p' - ;; calls shall be answered from the file cache. We unset - ;; `process-file-side-effects' in order to keep the cache when - ;; `process-file' calls appear. - (let (process-file-side-effects) - (tramp-run-real-handler 'vc-registered (list file))))))) - ;;;###autoload (progn (defun tramp-run-real-handler (operation args) "Invoke normal file name handler for OPERATION. @@ -5616,8 +1845,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (condition-case err (apply foreign operation args) - ;; Trace that somebody has interrupted the - ;; operation. + ;; Trace, that somebody has interrupted the operation. (quit (let (tramp-message-show-message) (tramp-message @@ -5675,48 +1903,6 @@ preventing reentrant calls of Tramp.") Together with `tramp-locked', this implements a locking mechanism preventing reentrant calls of Tramp.") -(defun tramp-sh-file-name-handler (operation &rest args) - "Invoke remote-shell Tramp file name handler. -Fall back to normal file name handler if no Tramp handler exists." - (when (and tramp-locked (not tramp-locker)) - (setq tramp-locked nil) - (signal 'file-error (list "Forbidden reentrant call of Tramp"))) - (let ((tl tramp-locked)) - (unwind-protect - (progn - (setq tramp-locked t) - (let ((tramp-locker t)) - (save-match-data - (let ((fn (assoc operation tramp-file-name-handler-alist))) - (if fn - (apply (cdr fn) args) - (tramp-run-real-handler operation args)))))) - (setq tramp-locked tl)))) - -(defun tramp-vc-file-name-handler (operation &rest args) - "Invoke special file name handler, which collects files to be handled." - (save-match-data - (let ((filename - (tramp-replace-environment-variables - (apply 'tramp-file-name-for-operation operation args))) - (fn (assoc operation tramp-file-name-handler-alist))) - (with-parsed-tramp-file-name filename nil - (cond - ;; That's what we want: file names, for which checks are - ;; applied. We assume, that VC uses only `file-exists-p' and - ;; `file-readable-p' checks; otherwise we must extend the - ;; list. We do not perform any action, but return nil, in - ;; order to keep `vc-registered' running. - ((and fn (memq operation '(file-exists-p file-readable-p))) - (add-to-list 'tramp-vc-registered-file-names localname 'append) - nil) - ;; Tramp file name handlers like `expand-file-name'. They - ;; must still work. - (fn - (save-match-data (apply (cdr fn) args))) - ;; Default file name handlers, we don't care. - (t (tramp-run-real-handler operation args))))))) - ;;;###autoload (progn (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler. @@ -5775,9 +1961,29 @@ Falls back to normal file name handler if no Tramp file name handler exists." ;; `tramp-file-name-handler' must be registered before evaluation of ;; site-start and init files, because there might exist remote files ;; already, f.e. files kept via recentf-mode. -;;;###autoload(tramp-register-file-name-handlers) +;;;###autoload (tramp-register-file-name-handlers) +(defun tramp-exists-file-name-handler (operation &rest args) + "Check, whether OPERATION runs a file name handler." + ;; The file name handler is determined on base of either an + ;; argument, `buffer-file-name', or `default-directory'. + (ignore-errors + (let* ((buffer-file-name "/") + (default-directory "/") + (fnha file-name-handler-alist) + (check-file-name-operation operation) + (file-name-handler-alist + (list + (cons "/" + (lambda (operation &rest args) + "Returns OPERATION if it is the one to be checked." + (if (equal check-file-name-operation operation) + operation + (let ((file-name-handler-alist fnha)) + (apply operation args)))))))) + (equal (apply operation args) operation)))) + ;;;###autoload (defun tramp-unload-file-name-handlers () (setq file-name-handler-alist @@ -5810,6 +2016,7 @@ should never be set globally, the intention is to let-bind it.") ;; Tramp file name syntax. Maybe another variable should be introduced ;; overwriting this check in such cases. Or we change Tramp file name ;; syntax in order to avoid ambiguities, like in XEmacs ... +;;;###tramp-autoload (defun tramp-completion-mode-p () "Check, whether method / user name / host name completion is active." (or @@ -5914,12 +2121,11 @@ not in completion mode." ;; Complete local parts. (append result1 - (condition-case nil - (apply (if (tramp-connectable-p fullname) - 'tramp-completion-run-real-handler - 'tramp-run-real-handler) - 'file-name-all-completions (list (list filename directory))) - (error nil))))) + (ignore-errors + (apply (if (tramp-connectable-p fullname) + 'tramp-completion-run-real-handler + 'tramp-run-real-handler) + 'file-name-all-completions (list (list filename directory))))))) ;; Method, host name and user name completion for a file. ;;;###autoload @@ -6162,7 +2368,7 @@ Either user or host may be nil." (concat "^\\(" tramp-host-regexp "\\)" "\\([ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (append (list (match-string 3) (match-string 1))))) (widen) @@ -6189,7 +2395,7 @@ User is always nil." User is always nil." (let ((result) (regexp (concat "^\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) @@ -6218,7 +2424,7 @@ User is always nil." User is always nil." (let ((result) (regexp (concat "^[ \t]*Host[ \t]+" "\\(" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) @@ -6279,7 +2485,7 @@ User is always nil." (let ((result) (regexp (concat "^\\(" tramp-ipv6-regexp "\\|" tramp-host-regexp "\\)"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) @@ -6314,7 +2520,7 @@ Host is always \"localhost\"." Host is always \"localhost\"." (let ((result) (regexp (concat "^\\(" tramp-user-regexp "\\):"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (list (match-string 1) "localhost"))) (widen) @@ -6344,7 +2550,7 @@ User may be nil." (concat "^[ \t]*machine[ \t]+" "\\(" tramp-host-regexp "\\)" "\\([ \t]+login[ \t]+" "\\(" tramp-user-regexp "\\)" "\\)?"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (list (match-string 3) (match-string 1)))) (widen) @@ -6359,7 +2565,7 @@ User is always nil." (let ((default-directory (tramp-compat-temporary-file-directory)) res) (with-temp-buffer - (when (zerop (tramp-local-call-process "reg" nil t nil "query" registry)) + (when (zerop (tramp-compat-call-process "reg" nil t nil "query" registry)) (goto-char (point-min)) (while (not (eobp)) (push (tramp-parse-putty-group registry) res)))) @@ -6370,333 +2576,387 @@ User is always nil." User is always nil." (let ((result) (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) - (narrow-to-region (point) (tramp-compat-line-end-position)) + (narrow-to-region (point) (point-at-eol)) (when (re-search-forward regexp nil t) (setq result (list nil (match-string 1)))) (widen) (forward-line 1) result)) -;;; Internal Functions: +;;; Common file name handler functions for different backends: -(defun tramp-maybe-send-script (vec script name) - "Define in remote shell function NAME implemented as SCRIPT. -Only send the definition if it has not already been done." - (let* ((p (tramp-get-connection-process vec)) - (scripts (tramp-get-connection-property p "scripts" nil))) - (unless (member name scripts) - (with-progress-reporter vec 5 (format "Sending script `%s'" name) - ;; The script could contain a call of Perl. This is masked with `%s'. - (tramp-send-command-and-check - vec - (format "%s () {\n%s\n}" name - (format script (tramp-get-remote-perl vec)))) - (tramp-set-connection-property p "scripts" (cons name scripts)))))) - -(defun tramp-set-auto-save () - (when (and ;; ange-ftp has its own auto-save mechanism - (eq (tramp-find-foreign-file-name-handler (buffer-file-name)) - 'tramp-sh-file-name-handler) - auto-save-default) - (auto-save-mode 1))) -(add-hook 'find-file-hooks 'tramp-set-auto-save t) -(add-hook 'tramp-unload-hook - (lambda () - (remove-hook 'find-file-hooks 'tramp-set-auto-save))) +(defvar tramp-handle-file-local-copy-hook nil + "Normal hook to be run at the end of `tramp-*-handle-file-local-copy'.") + +(defvar tramp-handle-write-region-hook nil + "Normal hook to be run at the end of `tramp-*-handle-write-region'.") + +(defun tramp-handle-directory-file-name (directory) + "Like `directory-file-name' for Tramp files." + ;; If localname component of filename is "/", leave it unchanged. + ;; Otherwise, remove any trailing slash from localname component. + ;; Method, host, etc, are unchanged. Does it make sense to try + ;; to avoid parsing the filename? + (with-parsed-tramp-file-name directory nil + (if (and (not (zerop (length localname))) + (eq (aref localname (1- (length localname))) ?/) + (not (string= localname "/"))) + (substring directory 0 -1) + directory))) + +(defun tramp-handle-directory-files + (directory &optional full match nosort files-only) + "Like `directory-files' for Tramp files." + ;; FILES-ONLY is valid for XEmacs only. + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let ((temp (nreverse (file-name-all-completions "" directory))) + result item) + + (while temp + (setq item (directory-file-name (pop temp))) + (when (and (or (null match) (string-match match item)) + (or (null files-only) + ;; Files only. + (and (equal files-only t) (file-regular-p item)) + ;; Directories only. + (file-directory-p item))) + (push (if full (concat directory item) item) + result))) + (if nosort result (sort result 'string<))))) + +(defun tramp-handle-directory-files-and-attributes + (directory &optional full match nosort id-format) + "Like `directory-files-and-attributes' for Tramp files." + (mapcar + (lambda (x) + (cons x (tramp-compat-file-attributes + (if full x (expand-file-name x directory)) id-format))) + (directory-files directory full match nosort))) + +(defun tramp-handle-dired-uncache (dir &optional dir-p) + "Like `dired-uncache' for Tramp files." + ;; DIR-P is valid for XEmacs only. + (with-parsed-tramp-file-name + (if (or dir-p (file-directory-p dir)) dir (file-name-directory dir)) nil + (tramp-flush-directory-property v localname))) + +(defun tramp-handle-file-exists-p (filename) + "Like `file-exists-p' for Tramp files." + (not (null (file-attributes filename)))) -(defun tramp-run-test (switch filename) - "Run `test' on the remote system, given a SWITCH and a FILENAME. -Returns the exit code of the `test' program." +(defun tramp-handle-file-modes (filename) + "Like `file-modes' for Tramp files." + (let ((truename (or (file-truename filename) filename))) + (when (file-exists-p truename) + (tramp-mode-string-to-int (nth 8 (file-attributes truename)))))) + +;; Localname manipulation functions that grok Tramp localnames... +(defun tramp-handle-file-name-as-directory (file) + "Like `file-name-as-directory' but aware of Tramp files." + ;; `file-name-as-directory' would be sufficient except localname is + ;; the empty string. + (let ((v (tramp-dissect-file-name file t))) + ;; Run the command on the localname portion only. + (tramp-make-tramp-file-name + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v) + (tramp-run-real-handler + 'file-name-as-directory (list (or (tramp-file-name-localname v) "")))))) + +(defun tramp-handle-file-name-completion + (filename directory &optional predicate) + "Like `file-name-completion' for Tramp files." + (unless (tramp-tramp-file-p directory) + (error + "tramp-handle-file-name-completion invoked on non-tramp directory `%s'" + directory)) + (try-completion + filename + (mapcar 'list (file-name-all-completions filename directory)) + (when predicate + (lambda (x) (funcall predicate (expand-file-name (car x) directory)))))) + +(defun tramp-handle-file-name-directory (file) + "Like `file-name-directory' but aware of Tramp files." + ;; Everything except the last filename thing is the directory. We + ;; cannot apply `with-parsed-tramp-file-name', because this expands + ;; the remote file name parts. This is a problem when we are in + ;; file name completion. + (let ((v (tramp-dissect-file-name file t))) + ;; Run the command on the localname portion only. + (tramp-make-tramp-file-name + (tramp-file-name-method v) + (tramp-file-name-user v) + (tramp-file-name-host v) + (tramp-run-real-handler + 'file-name-directory (list (or (tramp-file-name-localname v) "")))))) + +(defun tramp-handle-file-name-nondirectory (file) + "Like `file-name-nondirectory' but aware of Tramp files." + (with-parsed-tramp-file-name file nil + (tramp-run-real-handler 'file-name-nondirectory (list localname)))) + +(defun tramp-handle-file-newer-than-file-p (file1 file2) + "Like `file-newer-than-file-p' for Tramp files." + (cond + ((not (file-exists-p file1)) nil) + ((not (file-exists-p file2)) t) + (t (tramp-time-less-p (nth 5 (file-attributes file2)) + (nth 5 (file-attributes file1)))))) + +(defun tramp-handle-file-regular-p (filename) + "Like `file-regular-p' for Tramp files." + (and (file-exists-p filename) + (eq ?- (aref (nth 8 (file-attributes filename)) 0)))) + +(defun tramp-handle-file-remote-p (filename &optional identification connected) + "Like `file-remote-p' for Tramp files." + (let ((tramp-verbose 3)) + (when (tramp-tramp-file-p filename) + (let* ((v (tramp-dissect-file-name filename)) + (p (tramp-get-connection-process v)) + (c (and p (processp p) (memq (process-status p) '(run open))))) + ;; We expand the file name only, if there is already a connection. + (with-parsed-tramp-file-name + (if c (expand-file-name filename) filename) nil + (and (or (not connected) c) + (cond + ((eq identification 'method) method) + ((eq identification 'user) user) + ((eq identification 'host) host) + ((eq identification 'localname) localname) + (t (tramp-make-tramp-file-name method user host ""))))))))) + +(defun tramp-handle-file-symlink-p (filename) + "Like `file-symlink-p' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-send-command-and-check - v - (format - "%s %s %s" - (tramp-get-test-command v) - switch - (tramp-shell-quote-argument localname))))) - -(defun tramp-run-test2 (format-string file1 file2) - "Run `test'-like program on the remote system, given FILE1, FILE2. -FORMAT-STRING contains the program name, switches, and place holders. -Returns the exit code of the `test' program. Barfs if the methods, -hosts, or files, disagree." - (unless (tramp-equal-remote file1 file2) - (with-parsed-tramp-file-name (if (tramp-tramp-file-p file1) file1 file2) nil - (tramp-error - v 'file-error - "tramp-run-test2 only implemented for same method, user, host"))) - (with-parsed-tramp-file-name file1 v1 - (with-parsed-tramp-file-name file1 v2 - (tramp-send-command-and-check - v1 - (format format-string - (tramp-shell-quote-argument v1-localname) - (tramp-shell-quote-argument v2-localname)))))) + (let ((x (car (file-attributes filename)))) + (when (stringp x) + ;; When Tramp is running on VMS, then `file-name-absolute-p' + ;; might do weird things. + (if (file-name-absolute-p x) + (tramp-make-tramp-file-name method user host x) + x))))) -(defun tramp-buffer-name (vec) - "A name for the connection buffer VEC." - ;; We must use `tramp-file-name-real-host', because for gateway - ;; methods the default port will be expanded later on, which would - ;; tamper the name. - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (host (tramp-file-name-real-host vec))) - (if (not (zerop (length user))) - (format "*tramp/%s %s@%s*" method user host) - (format "*tramp/%s %s*" method host)))) +(defun tramp-handle-find-backup-file-name (filename) + "Like `find-backup-file-name' for Tramp files." + (with-parsed-tramp-file-name filename nil + ;; We set both variables. It doesn't matter whether it is + ;; Emacs or XEmacs. + (let ((backup-directory-alist + ;; Emacs case. + (when (boundp 'backup-directory-alist) + (if (symbol-value 'tramp-backup-directory-alist) + (mapcar + (lambda (x) + (cons + (car x) + (if (and (stringp (cdr x)) + (file-name-absolute-p (cdr x)) + (not (tramp-file-name-p (cdr x)))) + (tramp-make-tramp-file-name method user host (cdr x)) + (cdr x)))) + (symbol-value 'tramp-backup-directory-alist)) + (symbol-value 'backup-directory-alist)))) -(defun tramp-delete-temp-file-function () - "Remove temporary files related to current buffer." - (when (stringp tramp-temp-buffer-file-name) - (condition-case nil - (delete-file tramp-temp-buffer-file-name) - (error nil)))) + (bkup-backup-directory-info + ;; XEmacs case. + (when (boundp 'bkup-backup-directory-info) + (if (symbol-value 'tramp-bkup-backup-directory-info) + (mapcar + (lambda (x) + (nconc + (list (car x)) + (list + (if (and (stringp (car (cdr x))) + (file-name-absolute-p (car (cdr x))) + (not (tramp-file-name-p (car (cdr x))))) + (tramp-make-tramp-file-name + method user host (car (cdr x))) + (car (cdr x)))) + (cdr (cdr x)))) + (symbol-value 'tramp-bkup-backup-directory-info)) + (symbol-value 'bkup-backup-directory-info))))) -(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function) -(add-hook 'tramp-cache-unload-hook - (lambda () - (remove-hook 'kill-buffer-hook - 'tramp-delete-temp-file-function))) + (tramp-run-real-handler 'find-backup-file-name (list filename))))) -(defun tramp-get-buffer (vec) - "Get the connection buffer to be used for VEC." - (or (get-buffer (tramp-buffer-name vec)) - (with-current-buffer (get-buffer-create (tramp-buffer-name vec)) - (setq buffer-undo-list t) - (setq default-directory - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - "/")) - (current-buffer)))) +(defun tramp-handle-insert-file-contents + (filename &optional visit beg end replace) + "Like `insert-file-contents' for Tramp files." + (barf-if-buffer-read-only) + (setq filename (expand-file-name filename)) + (let (result local-copy remote-copy) + (with-parsed-tramp-file-name filename nil + (unwind-protect + (if (not (file-exists-p filename)) + ;; We don't raise a Tramp error, because it might be + ;; suppressed, like in `find-file-noselect-1'. + (signal 'file-error + (list "File not found on remote host" filename)) -(defun tramp-get-connection-buffer (vec) - "Get the connection buffer to be used for VEC. -In case a second asynchronous communication has been started, it is different -from `tramp-get-buffer'." - (or (tramp-get-connection-property vec "process-buffer" nil) - (tramp-get-buffer vec))) + (if (and (tramp-local-host-p v) + (let (file-name-handler-alist) + (file-readable-p localname))) + ;; Short track: if we are on the local host, we can + ;; run directly. + (setq result + (tramp-run-real-handler + 'insert-file-contents + (list localname visit beg end replace))) -(defun tramp-get-connection-process (vec) - "Get the connection process to be used for VEC. -In case a second asynchronous communication has been started, it is different -from the default one." - (get-process - (or (tramp-get-connection-property vec "process-name" nil) - (tramp-buffer-name vec)))) + ;; When we shall insert only a part of the file, we copy + ;; this part. + (when (or beg end) + (setq remote-copy (tramp-make-tramp-temp-file v)) + ;; This is defined in tramp-sh.el. Let's assume this + ;; is loaded already. + (tramp-compat-funcall 'tramp-send-command + v + (cond + ((and beg end) + (format "tail -c +%d %s | head -c +%d >%s" + (1+ beg) (tramp-shell-quote-argument localname) + (- end beg) remote-copy)) + (beg + (format "tail -c +%d %s >%s" + (1+ beg) (tramp-shell-quote-argument localname) + remote-copy)) + (end + (format "head -c +%d %s >%s" + (1+ end) (tramp-shell-quote-argument localname) + remote-copy))))) -(defun tramp-debug-buffer-name (vec) - "A name for the debug buffer for VEC." - ;; We must use `tramp-file-name-real-host', because for gateway - ;; methods the default port will be expanded later on, which would - ;; tamper the name. - (let ((method (tramp-file-name-method vec)) - (user (tramp-file-name-user vec)) - (host (tramp-file-name-real-host vec))) - (if (not (zerop (length user))) - (format "*debug tramp/%s %s@%s*" method user host) - (format "*debug tramp/%s %s*" method host)))) + ;; `insert-file-contents-literally' takes care to avoid + ;; calling jka-compr. By let-binding + ;; `inhibit-file-name-operation', we propagate that care + ;; to the `file-local-copy' operation. + (setq local-copy + (let ((inhibit-file-name-operation + (when (eq inhibit-file-name-operation + 'insert-file-contents) + 'file-local-copy))) + (cond + ((stringp remote-copy) + (file-local-copy + (tramp-make-tramp-file-name + method user host remote-copy))) + ((stringp tramp-temp-buffer-file-name) + (copy-file filename tramp-temp-buffer-file-name 'ok) + tramp-temp-buffer-file-name) + (t (file-local-copy filename))))) -(defconst tramp-debug-outline-regexp - "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ [a-z0-9-]+ (\\([0-9]+\\)) #") + ;; When the file is not readable for the owner, it + ;; cannot be inserted, even if it is readable for the + ;; group or for everybody. + (set-file-modes local-copy (tramp-compat-octal-to-decimal "0600")) -(defun tramp-get-debug-buffer (vec) - "Get the debug buffer for VEC." - (with-current-buffer - (get-buffer-create (tramp-debug-buffer-name vec)) - (when (bobp) - (setq buffer-undo-list t) - ;; Activate `outline-mode'. This runs `text-mode-hook' and - ;; `outline-mode-hook'. We must prevent that local processes - ;; die. Yes: I've seen `flyspell-mode', which starts "ispell". - ;; Furthermore, `outline-regexp' must have the correct value - ;; already, because it is used by `font-lock-compile-keywords'. - (let ((default-directory (tramp-compat-temporary-file-directory)) - (outline-regexp tramp-debug-outline-regexp)) - (outline-mode)) - (set (make-local-variable 'outline-regexp) tramp-debug-outline-regexp) - (set (make-local-variable 'outline-level) 'tramp-outline-level)) - (current-buffer))) + (when (and (null remote-copy) + (tramp-get-method-parameter + method 'tramp-copy-keep-tmpfile)) + ;; We keep the local file for performance reasons, + ;; useful for "rsync". + (setq tramp-temp-buffer-file-name local-copy)) -(defun tramp-outline-level () - "Return the depth to which a statement is nested in the outline. -Point must be at the beginning of a header line. + (with-progress-reporter + v 3 (format "Inserting local temp file `%s'" local-copy) + ;; We must ensure that `file-coding-system-alist' + ;; matches `local-copy'. + (let ((file-coding-system-alist + (tramp-find-file-name-coding-system-alist + filename local-copy))) + (setq result + (insert-file-contents + local-copy nil nil nil replace)))))) -The outline level is equal to the verbosity of the Tramp message." - (1+ (string-to-number (match-string 1)))) + ;; Save exit. + (progn + (when visit + (setq buffer-file-name filename) + (setq buffer-read-only (not (file-writable-p filename))) + (set-visited-file-modtime) + (set-buffer-modified-p nil)) + (when (and (stringp local-copy) + (or remote-copy (null tramp-temp-buffer-file-name))) + (delete-file local-copy)) + (when (stringp remote-copy) + (delete-file + (tramp-make-tramp-file-name method user host remote-copy)))))) -(defun tramp-find-executable - (vec progname dirlist &optional ignore-tilde ignore-path) - "Searches for PROGNAME in $PATH and all directories mentioned in DIRLIST. -First arg VEC specifies the connection, PROGNAME is the program -to search for, and DIRLIST gives the list of directories to -search. If IGNORE-TILDE is non-nil, directory names starting -with `~' will be ignored. If IGNORE-PATH is non-nil, searches -only in DIRLIST. + ;; Result. + (list (expand-file-name filename) + (cadr result)))) -Returns the absolute file name of PROGNAME, if found, and nil otherwise. +(defun tramp-handle-load (file &optional noerror nomessage nosuffix must-suffix) + "Like `load' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name file) nil + (unless nosuffix + (cond ((file-exists-p (concat file ".elc")) + (setq file (concat file ".elc"))) + ((file-exists-p (concat file ".el")) + (setq file (concat file ".el"))))) + (when must-suffix + ;; The first condition is always true for absolute file names. + ;; Included for safety's sake. + (unless (or (file-name-directory file) + (string-match "\\.elc?\\'" file)) + (tramp-error + v 'file-error + "File `%s' does not include a `.el' or `.elc' suffix" file))) + (unless noerror + (when (not (file-exists-p file)) + (tramp-error v 'file-error "Cannot load nonexistent file `%s'" file))) + (if (not (file-exists-p file)) + nil + (let ((tramp-message-show-message (not nomessage))) + (with-progress-reporter v 0 (format "Loading %s" file) + (let ((local-copy (file-local-copy file))) + ;; MUST-SUFFIX doesn't exist on XEmacs, so let it default to nil. + (unwind-protect + (load local-copy noerror t t) + (delete-file local-copy))))) + t))) -This function expects to be in the right *tramp* buffer." - (with-current-buffer (tramp-get-connection-buffer vec) - (let (result) - ;; Check whether the executable is in $PATH. "which(1)" does not - ;; report always a correct error code; therefore we check the - ;; number of words it returns. - (unless ignore-path - (tramp-send-command vec (format "which \\%s | wc -w" progname)) - (goto-char (point-min)) - (if (looking-at "^\\s-*1$") - (setq result (concat "\\" progname)))) - (unless result - (when ignore-tilde - ;; Remove all ~/foo directories from dirlist. In XEmacs, - ;; `remove' is in CL, and we want to avoid CL dependencies. - (let (newdl d) - (while dirlist - (setq d (car dirlist)) - (setq dirlist (cdr dirlist)) - (unless (char-equal ?~ (aref d 0)) - (setq newdl (cons d newdl)))) - (setq dirlist (nreverse newdl)))) - (tramp-send-command - vec - (format (concat "while read d; " - "do if test -x $d/%s -a -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'EOF'\n" - "%s\nEOF") - progname progname progname (mapconcat 'identity dirlist "\n"))) - (goto-char (point-max)) - (when (search-backward "tramp_executable " nil t) - (skip-chars-forward "^ ") - (skip-chars-forward " ") - (setq result (buffer-substring - (point) (tramp-compat-line-end-position))))) - result))) - -(defun tramp-set-remote-path (vec) - "Sets the remote environment PATH to existing directories. -I.e., for each directory in `tramp-remote-path', it is tested -whether it exists and if so, it is added to the environment -variable PATH." - (tramp-message vec 5 (format "Setting $PATH environment variable")) - (tramp-send-command - vec (format "PATH=%s; export PATH" - (mapconcat 'identity (tramp-get-remote-path vec) ":")))) - -;; ------------------------------------------------------------ -;; -- Communication with external shell -- -;; ------------------------------------------------------------ - -(defun tramp-find-file-exists-command (vec) - "Find a command on the remote host for checking if a file exists. -Here, we are looking for a command which has zero exit status if the -file exists and nonzero exit status otherwise." - (let ((existing "/") - (nonexisting - (tramp-shell-quote-argument "/ this file does not exist ")) - result) - ;; The algorithm is as follows: we try a list of several commands. - ;; For each command, we first run `$cmd /' -- this should return - ;; true, as the root directory always exists. And then we run - ;; `$cmd /this\ file\ does\ not\ exist ', hoping that the file indeed - ;; does not exist. This should return false. We use the first - ;; command we find that seems to work. - ;; The list of commands to try is as follows: - ;; `ls -d' This works on most systems, but NetBSD 1.4 - ;; has a bug: `ls' always returns zero exit - ;; status, even for files which don't exist. - ;; `test -e' Some Bourne shells have a `test' builtin - ;; which does not know the `-e' option. - ;; `/bin/test -e' For those, the `test' binary on disk normally - ;; provides the option. Alas, the binary - ;; is sometimes `/bin/test' and sometimes it's - ;; `/usr/bin/test'. - ;; `/usr/bin/test -e' In case `/bin/test' does not exist. - (unless (or - (and (setq result (format "%s -e" (tramp-get-test-command vec))) - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting))))) - (and (setq result "/bin/test -e") - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting))))) - (and (setq result "/usr/bin/test -e") - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting))))) - (and (setq result (format "%s -d" (tramp-get-ls-command vec))) - (zerop (tramp-send-command-and-check - vec (format "%s %s" result existing))) - (not (zerop (tramp-send-command-and-check - vec (format "%s %s" result nonexisting)))))) - (tramp-error - vec 'file-error "Couldn't find command to check if file exists")) - result)) +(defun tramp-handle-substitute-in-file-name (filename) + "Like `substitute-in-file-name' for Tramp files. +\"//\" and \"/~\" substitute only in the local filename part. +If the URL Tramp syntax is chosen, \"//\" as method delimeter and \"/~\" at +beginning of local filename are not substituted." + ;; First, we must replace environment variables. + (setq filename (tramp-replace-environment-variables filename)) + (with-parsed-tramp-file-name filename nil + (if (equal tramp-syntax 'url) + ;; We need to check localname only. The other parts cannot contain + ;; "//" or "/~". + (if (and (> (length localname) 1) + (or (string-match "//" localname) + (string-match "/~" localname 1))) + (tramp-run-real-handler 'substitute-in-file-name (list filename)) + (tramp-make-tramp-file-name + (when method (substitute-in-file-name method)) + (when user (substitute-in-file-name user)) + (when host (substitute-in-file-name host)) + (when localname + (tramp-run-real-handler + 'substitute-in-file-name (list localname))))) + ;; Ignore in LOCALNAME everything before "//" or "/~". + (when (and (stringp localname) (string-match ".+?/\\(/\\|~\\)" localname)) + (setq filename + (concat (file-remote-p filename) + (replace-match "\\1" nil nil localname))) + ;; "/m:h:~" does not work for completion. We use "/m:h:~/". + (when (string-match "~$" filename) + (setq filename (concat filename "/")))) + (tramp-run-real-handler 'substitute-in-file-name (list filename))))) -(defun tramp-open-shell (vec shell) - "Opens shell SHELL." - (with-progress-reporter vec 5 (format "Opening remote shell `%s'" shell) - ;; Find arguments for this shell. - (let ((tramp-end-of-output tramp-initial-end-of-output) - (alist tramp-sh-extra-args) - item extra-args) - (while (and alist (null extra-args)) - (setq item (pop alist)) - (when (string-match (car item) shell) - (setq extra-args (cdr item)))) - (when extra-args (setq shell (concat shell " " extra-args))) - (tramp-send-command - vec (format "exec env ENV='' PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s" - (shell-quote-argument tramp-end-of-output) shell) - t)) - ;; Setting prompts. - (tramp-send-command - vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) - (tramp-send-command vec "PS2=''" t) - (tramp-send-command vec "PS3=''" t) - (tramp-send-command vec "PROMPT_COMMAND=''" t))) - -(defun tramp-find-shell (vec) - "Opens a shell on the remote host which groks tilde expansion." - (unless (tramp-get-connection-property vec "remote-shell" nil) - (let (shell) - (with-current-buffer (tramp-get-buffer vec) - (tramp-send-command vec "echo ~root" t) - (cond - ((or (string-match "^~root$" (buffer-string)) - ;; The default shell (ksh93) of OpenSolaris is buggy. - (string-equal (tramp-get-connection-property vec "uname" "") - "SunOS 5.11")) - (setq shell - (or (tramp-find-executable - vec "bash" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "ksh" (tramp-get-remote-path vec) t t))) - (unless shell - (tramp-error - vec 'file-error - "Couldn't find a shell which groks tilde expansion")) - (tramp-message - vec 5 "Starting remote shell `%s' for tilde expansion" shell) - (tramp-open-shell vec shell)) - - (t (tramp-message - vec 5 "Remote `%s' groks tilde expansion, good" - (tramp-set-connection-property - vec "remote-shell" - (tramp-get-method-parameter - (tramp-file-name-method vec) 'tramp-remote-sh))))))))) - -;; ------------------------------------------------------------ -;; -- Functions for establishing connection -- -;; ------------------------------------------------------------ +(defun tramp-handle-unhandled-file-name-directory (filename) + "Like `unhandled-file-name-directory' for Tramp files." + ;; With Emacs 23, we could simply return `nil'. But we must keep it + ;; for backward compatibility. + (expand-file-name "~/")) + +;;; Functions for establishing connection: ;; The following functions are actions to be taken when seeing certain ;; prompts from the remote host. See the variable @@ -6795,7 +3055,7 @@ The terminal type can be configured with `tramp-terminal-type'." (throw 'tramp-action 'process-died)))) (t nil))) -;; Functions for processing the actions. +;;; Functions for processing the actions: (defun tramp-process-one-action (proc vec actions) "Wait for output from the shell and perform one action." @@ -6819,7 +3079,7 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-process-actions (proc vec actions &optional timeout) "Perform actions until success or TIMEOUT." ;; Preserve message for `progress-reporter'. - (with-temp-message "" + (tramp-compat-with-temp-message "" ;; Enable auth-source and password-cache. (tramp-set-connection-property vec "first-password-request" t) (save-restriction @@ -6844,7 +3104,7 @@ The terminal type can be configured with `tramp-terminal-type'." ((eq exit 'process-died) "Process died") (t "Login failed")))))))) -;; Utility functions. +:;; Utility functions: (defun tramp-accept-process-output (&optional proc timeout timeout-msecs) "Like `accept-process-output' for Tramp processes. @@ -6928,17 +3188,6 @@ nil." (tramp-error proc 'file-error "[[Regexp `%s' not found]]" regexp))) found))) -(defun tramp-barf-if-no-shell-prompt (proc timeout &rest error-args) - "Wait for shell prompt and barf if none appears. -Looks at process PROC to see if a shell prompt appears in TIMEOUT -seconds. If not, it produces an error message with the given ERROR-ARGS." - (unless - (tramp-wait-for-regexp - proc timeout - (format - "\\(%s\\|%s\\)\\'" shell-prompt-pattern tramp-shell-prompt-pattern)) - (apply 'tramp-error-with-buffer nil proc 'file-error error-args))) - ;; We don't call `tramp-send-string' in order to hide the password ;; from the debug buffer, and because end-of-line handling of the ;; string. @@ -6951,831 +3200,6 @@ seconds. If not, it produces an error message with the given ERROR-ARGS." 'tramp-password-end-of-line) tramp-default-password-end-of-line)))) -(defun tramp-open-connection-setup-interactive-shell (proc vec) - "Set up an interactive shell. -Mainly sets the prompt and the echo correctly. PROC is the shell -process to set up. VEC specifies the connection." - (let ((tramp-end-of-output tramp-initial-end-of-output)) - ;; It is useful to set the prompt in the following command because - ;; some people have a setting for $PS1 which /bin/sh doesn't know - ;; about and thus /bin/sh will display a strange prompt. For - ;; example, if $PS1 has "${CWD}" in the value, then ksh will - ;; display the current working directory but /bin/sh will display - ;; a dollar sign. The following command line sets $PS1 to a sane - ;; value, and works under Bourne-ish shells as well as csh-like - ;; shells. Daniel Pittman reports that the unusual positioning of - ;; the single quotes makes it work under `rc', too. We also unset - ;; the variable $ENV because that is read by some sh - ;; implementations (eg, bash when called as sh) on startup; this - ;; way, we avoid the startup file clobbering $PS1. $PROMP_COMMAND - ;; is another way to set the prompt in /bin/bash, it must be - ;; discarded as well. - (tramp-open-shell - vec - (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-remote-sh)) - - ;; Disable echo. - (tramp-message vec 5 "Setting up remote shell environment") - (tramp-send-command vec "stty -inlcr -echo kill '^U' erase '^H'" t) - ;; Check whether the echo has really been disabled. Some - ;; implementations, like busybox of embedded GNU/Linux, don't - ;; support disabling. - (tramp-send-command vec "echo foo" t) - (with-current-buffer (process-buffer proc) - (goto-char (point-min)) - (when (looking-at "echo foo") - (tramp-set-connection-property proc "remote-echo" t) - (tramp-message vec 5 "Remote echo still on. Ok.") - ;; Make sure backspaces and their echo are enabled and no line - ;; width magic interferes with them. - (tramp-send-command vec "stty icanon erase ^H cols 32767" t)))) - - (tramp-message vec 5 "Setting shell prompt") - (tramp-send-command - vec (format "PS1=%s" (shell-quote-argument tramp-end-of-output)) t) - (tramp-send-command vec "PS2=''" t) - (tramp-send-command vec "PS3=''" t) - (tramp-send-command vec "PROMPT_COMMAND=''" t) - - ;; Try to set up the coding system correctly. - ;; CCC this can't be the right way to do it. Hm. - (tramp-message vec 5 "Determining coding system") - (tramp-send-command vec "echo foo ; echo bar" t) - (with-current-buffer (process-buffer proc) - (goto-char (point-min)) - (if (featurep 'mule) - ;; Use MULE to select the right EOL convention for communicating - ;; with the process. - (let* ((cs (or (tramp-compat-funcall 'process-coding-system proc) - (cons 'undecided 'undecided))) - cs-decode cs-encode) - (when (symbolp cs) (setq cs (cons cs cs))) - (setq cs-decode (car cs)) - (setq cs-encode (cdr cs)) - (unless cs-decode (setq cs-decode 'undecided)) - (unless cs-encode (setq cs-encode 'undecided)) - (setq cs-encode (tramp-coding-system-change-eol-conversion - cs-encode 'unix)) - (when (search-forward "\r" nil t) - (setq cs-decode (tramp-coding-system-change-eol-conversion - cs-decode 'dos))) - (tramp-compat-funcall - 'set-buffer-process-coding-system cs-decode cs-encode) - (tramp-message - vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode)) - ;; Look for ^M and do something useful if found. - (when (search-forward "\r" nil t) - ;; We have found a ^M but cannot frob the process coding system - ;; because we're running on a non-MULE Emacs. Let's try - ;; stty, instead. - (tramp-send-command vec "stty -onlcr" t)))) - - (tramp-send-command vec "set +o vi +o emacs" t) - - ;; Check whether the output of "uname -sr" has been changed. If - ;; yes, this is a strong indication that we must expire all - ;; connection properties. We start again with - ;; `tramp-maybe-open-connection', it will be catched there. - (tramp-message vec 5 "Checking system information") - (let ((old-uname (tramp-get-connection-property vec "uname" nil)) - (new-uname - (tramp-set-connection-property - vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) - (when (and (stringp old-uname) (not (string-equal old-uname new-uname))) - (with-current-buffer (tramp-get-debug-buffer vec) - ;; Keep the debug buffer. - (rename-buffer - (generate-new-buffer-name tramp-temp-buffer-name) 'unique) - (tramp-compat-funcall 'tramp-cleanup-connection vec) - (if (= (point-min) (point-max)) - (kill-buffer nil) - (rename-buffer (tramp-debug-buffer-name vec) 'unique)) - ;; We call `tramp-get-buffer' in order to keep the debug buffer. - (tramp-get-buffer vec) - (tramp-message - vec 3 - "Connection reset, because remote host changed from `%s' to `%s'" - old-uname new-uname) - (throw 'uname-changed (tramp-maybe-open-connection vec))))) - - ;; Check whether the remote host suffers from buggy - ;; `send-process-string'. This is known for FreeBSD (see comment in - ;; `send_process', file process.c). I've tested sending 624 bytes - ;; successfully, sending 625 bytes failed. Emacs makes a hack when - ;; this host type is detected locally. It cannot handle remote - ;; hosts, though. - (with-connection-property proc "chunksize" - (cond - ((and (integerp tramp-chunksize) (> tramp-chunksize 0)) - tramp-chunksize) - (t - (tramp-message - vec 5 "Checking remote host type for `send-process-string' bug") - (if (string-match - "^FreeBSD" (tramp-get-connection-property vec "uname" "")) - 500 0)))) - - ;; Set remote PATH variable. - (tramp-set-remote-path vec) - - ;; Search for a good shell before searching for a command which - ;; checks if a file exists. This is done because Tramp wants to use - ;; "test foo; echo $?" to check if various conditions hold, and - ;; there are buggy /bin/sh implementations which don't execute the - ;; "echo $?" part if the "test" part has an error. In particular, - ;; the OpenSolaris /bin/sh is a problem. There are also other - ;; problems with /bin/sh of OpenSolaris, like redirection of stderr - ;; in function declarations, or changing HISTFILE in place. - ;; Therefore, OpenSolaris' /bin/sh is replaced by bash, when - ;; detected. - (tramp-find-shell vec) - - ;; Disable unexpected output. - (tramp-send-command vec "mesg n; biff n" t) - - ;; IRIX64 bash expands "!" even when in single quotes. This - ;; destroys our shell functions, we must disable it. See - ;; <http://stackoverflow.com/questions/3291692/irix-bash-shell-expands-expression-in-single-quotes-yet-shouldnt>. - (when (string-match "^IRIX64" (tramp-get-connection-property vec "uname" "")) - (tramp-send-command vec "set +H" t)) - - ;; On BSD-like systems, ?\t is expanded to spaces. Suppress this. - (when (string-match "BSD\\|Darwin" - (tramp-get-connection-property vec "uname" "")) - (tramp-send-command vec "stty -oxtabs" t)) - - ;; Set `remote-tty' process property. - (ignore-errors - (let ((tty (tramp-send-command-and-read vec "echo \\\"`tty`\\\""))) - (unless (zerop (length tty)) (process-put proc 'remote-tty tty)))) - - ;; Dump stty settings in the traces. - (when (>= tramp-verbose 9) - (tramp-send-command vec "stty -a" t)) - - ;; Set the environment. - (tramp-message vec 5 "Setting default environment") - - (let ((env (copy-sequence tramp-remote-process-environment)) - unset item) - (while env - (setq item (tramp-compat-split-string (car env) "=")) - (setcdr item (mapconcat 'identity (cdr item) "=")) - (if (and (stringp (cdr item)) (not (string-equal (cdr item) ""))) - (tramp-send-command - vec (format "%s=%s; export %s" (car item) (cdr item) (car item)) t) - (push (car item) unset)) - (setq env (cdr env))) - (when unset - (tramp-send-command - vec (format "unset %s" (mapconcat 'identity unset " ")) t)))) - -;; CCC: We should either implement a Perl version of base64 encoding -;; and decoding. Then we just use that in the last item. The other -;; alternative is to use the Perl version of UU encoding. But then -;; we need a Lisp version of uuencode. -;; -;; Old text from documentation of tramp-methods: -;; Using a uuencode/uudecode inline method is discouraged, please use one -;; of the base64 methods instead since base64 encoding is much more -;; reliable and the commands are more standardized between the different -;; Unix versions. But if you can't use base64 for some reason, please -;; note that the default uudecode command does not work well for some -;; Unices, in particular AIX and Irix. For AIX, you might want to use -;; the following command for uudecode: -;; -;; sed '/^begin/d;/^[` ]$/d;/^end/d' | iconv -f uucode -t ISO8859-1 -;; -;; For Irix, no solution is known yet. - -(defconst tramp-local-coding-commands - '((b64 base64-encode-region base64-decode-region) - (uu tramp-uuencode-region uudecode-decode-region) - (pack - "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" - "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) - "List of local coding commands for inline transfer. -Each item is a list that looks like this: - -\(FORMAT ENCODING DECODING\) - -FORMAT is symbol describing the encoding/decoding format. It can be -`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. - -ENCODING and DECODING can be strings, giving commands, or symbols, -giving functions. If they are strings, then they can contain -the \"%s\" format specifier. If that specifier is present, the input -filename will be put into the command line at that spot. If the -specifier is not present, the input should be read from standard -input. - -If they are functions, they will be called with two arguments, start -and end of region, and are expected to replace the region contents -with the encoded or decoded results, respectively.") - -(defconst tramp-remote-coding-commands - '((b64 "base64" "base64 -d -i") - ;; "-i" is more robust with older base64 from GNU coreutils. - ;; However, I don't know whether all base64 versions do supports - ;; this option. - (b64 "base64" "base64 -d") - (b64 "mimencode -b" "mimencode -u -b") - (b64 "mmencode -b" "mmencode -u -b") - (b64 "recode data..base64" "recode base64..data") - (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) - (b64 tramp-perl-encode tramp-perl-decode) - (uu "uuencode xxx" "uudecode -o /dev/stdout") - (uu "uuencode xxx" "uudecode -o -") - (uu "uuencode xxx" "uudecode -p") - (uu "uuencode xxx" tramp-uudecode) - (pack - "perl -e 'binmode STDIN; binmode STDOUT; print pack(q{u*}, join q{}, <>)'" - "perl -e 'binmode STDIN; binmode STDOUT; print unpack(q{u*}, join q{}, <>)'")) - "List of remote coding commands for inline transfer. -Each item is a list that looks like this: - -\(FORMAT ENCODING DECODING\) - -FORMAT is symbol describing the encoding/decoding format. It can be -`b64' for base64 encoding, `uu' for uu encoding, or `pack' for simple packing. - -ENCODING and DECODING can be strings, giving commands, or symbols, -giving variables. If they are strings, then they can contain -the \"%s\" format specifier. If that specifier is present, the input -filename will be put into the command line at that spot. If the -specifier is not present, the input should be read from standard -input. - -If they are variables, this variable is a string containing a Perl -implementation for this functionality. This Perl program will be transferred -to the remote host, and it is available as shell function with the same name.") - -(defun tramp-find-inline-encoding (vec) - "Find an inline transfer encoding that works. -Goes through the list `tramp-local-coding-commands' and -`tramp-remote-coding-commands'." - (save-excursion - (let ((local-commands tramp-local-coding-commands) - (magic "xyzzy") - loc-enc loc-dec rem-enc rem-dec litem ritem found) - (while (and local-commands (not found)) - (setq litem (pop local-commands)) - (catch 'wont-work-local - (let ((format (nth 0 litem)) - (remote-commands tramp-remote-coding-commands)) - (setq loc-enc (nth 1 litem)) - (setq loc-dec (nth 2 litem)) - ;; If the local encoder or decoder is a string, the - ;; corresponding command has to work locally. - (if (not (stringp loc-enc)) - (tramp-message - vec 5 "Checking local encoding function `%s'" loc-enc) - (tramp-message - vec 5 "Checking local encoding command `%s' for sanity" loc-enc) - (unless (zerop (tramp-call-local-coding-command - loc-enc nil nil)) - (throw 'wont-work-local nil))) - (if (not (stringp loc-dec)) - (tramp-message - vec 5 "Checking local decoding function `%s'" loc-dec) - (tramp-message - vec 5 "Checking local decoding command `%s' for sanity" loc-dec) - (unless (zerop (tramp-call-local-coding-command - loc-dec nil nil)) - (throw 'wont-work-local nil))) - ;; Search for remote coding commands with the same format - (while (and remote-commands (not found)) - (setq ritem (pop remote-commands)) - (catch 'wont-work-remote - (when (equal format (nth 0 ritem)) - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - ;; Check if remote encoding and decoding commands can be - ;; called remotely with null input and output. This makes - ;; sure there are no syntax errors and the command is really - ;; found. Note that we do not redirect stdout to /dev/null, - ;; for two reasons: when checking the decoding command, we - ;; actually check the output it gives. And also, when - ;; redirecting "mimencode" output to /dev/null, then as root - ;; it might change the permissions of /dev/null! - (when (not (stringp rem-enc)) - (let ((name (symbol-name rem-enc))) - (while (string-match (regexp-quote "-") name) - (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-enc) name) - (setq rem-enc name))) - (tramp-message - vec 5 - "Checking remote encoding command `%s' for sanity" rem-enc) - (unless (zerop (tramp-send-command-and-check - vec (format "%s </dev/null" rem-enc) t)) - (throw 'wont-work-remote nil)) - - (when (not (stringp rem-dec)) - (let ((name (symbol-name rem-dec))) - (while (string-match (regexp-quote "-") name) - (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-dec) name) - (setq rem-dec name))) - (tramp-message - vec 5 - "Checking remote decoding command `%s' for sanity" rem-dec) - (unless (zerop (tramp-send-command-and-check - vec - (format "echo %s | %s | %s" - magic rem-enc rem-dec) - t)) - (throw 'wont-work-remote nil)) - - (with-current-buffer (tramp-get-buffer vec) - (goto-char (point-min)) - (unless (looking-at (regexp-quote magic)) - (throw 'wont-work-remote nil))) - - ;; `rem-enc' and `rem-dec' could be a string meanwhile. - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq found t))))))) - - ;; Did we find something? - (unless found - (tramp-error - vec 'file-error "Couldn't find an inline transfer encoding")) - - ;; Set connection properties. - (tramp-message vec 5 "Using local encoding `%s'" loc-enc) - (tramp-set-connection-property vec "local-encoding" loc-enc) - (tramp-message vec 5 "Using local decoding `%s'" loc-dec) - (tramp-set-connection-property vec "local-decoding" loc-dec) - (tramp-message vec 5 "Using remote encoding `%s'" rem-enc) - (tramp-set-connection-property vec "remote-encoding" rem-enc) - (tramp-message vec 5 "Using remote decoding `%s'" rem-dec) - (tramp-set-connection-property vec "remote-decoding" rem-dec)))) - -(defun tramp-call-local-coding-command (cmd input output) - "Call the local encoding or decoding command. -If CMD contains \"%s\", provide input file INPUT there in command. -Otherwise, INPUT is passed via standard input. -INPUT can also be nil which means `/dev/null'. -OUTPUT can be a string (which specifies a filename), or t (which -means standard output and thus the current buffer), or nil (which -means discard it)." - (tramp-local-call-process - tramp-encoding-shell - (when (and input (not (string-match "%s" cmd))) input) - (if (eq output t) t nil) - nil - tramp-encoding-command-switch - (concat - (if (string-match "%s" cmd) (format cmd input) cmd) - (if (stringp output) (concat "> " output) "")))) - -(defconst tramp-inline-compress-commands - '(("gzip" "gzip -d") - ("bzip2" "bzip2 -d") - ("compress" "compress -d")) - "List of compress and decompress commands for inline transfer. -Each item is a list that looks like this: - -\(COMPRESS DECOMPRESS\) - -COMPRESS or DECOMPRESS are strings with the respective commands.") - -(defun tramp-find-inline-compress (vec) - "Find an inline transfer compress command that works. -Goes through the list `tramp-inline-compress-commands'." - (save-excursion - (let ((commands tramp-inline-compress-commands) - (magic "xyzzy") - item compress decompress - found) - (while (and commands (not found)) - (catch 'next - (setq item (pop commands) - compress (nth 0 item) - decompress (nth 1 item)) - (tramp-message - vec 5 - "Checking local compress command `%s', `%s' for sanity" - compress decompress) - (unless (zerop (tramp-call-local-coding-command - (format "echo %s | %s | %s" - magic compress decompress) nil nil)) - (throw 'next nil)) - (tramp-message - vec 5 - "Checking remote compress command `%s', `%s' for sanity" - compress decompress) - (unless (zerop (tramp-send-command-and-check - vec (format "echo %s | %s | %s" - magic compress decompress) t)) - (throw 'next nil)) - (setq found t))) - - ;; Did we find something? - (if found - (progn - ;; Set connection properties. - (tramp-message - vec 5 "Using inline transfer compress command `%s'" compress) - (tramp-set-connection-property vec "inline-compress" compress) - (tramp-message - vec 5 "Using inline transfer decompress command `%s'" decompress) - (tramp-set-connection-property vec "inline-decompress" decompress)) - - (tramp-set-connection-property vec "inline-compress" nil) - (tramp-set-connection-property vec "inline-decompress" nil) - (tramp-message - vec 2 "Couldn't find an inline transfer compress command"))))) - -(defun tramp-compute-multi-hops (vec) - "Expands VEC according to `tramp-default-proxies-alist'. -Gateway hops are already opened." - (let ((target-alist `(,vec)) - (choices tramp-default-proxies-alist) - item proxy) - - ;; Look for proxy hosts to be passed. - (while choices - (setq item (pop choices) - proxy (eval (nth 2 item))) - (when (and - ;; host - (string-match (or (eval (nth 0 item)) "") - (or (tramp-file-name-host (car target-alist)) "")) - ;; user - (string-match (or (eval (nth 1 item)) "") - (or (tramp-file-name-user (car target-alist)) ""))) - (if (null proxy) - ;; No more hops needed. - (setq choices nil) - ;; Replace placeholders. - (setq proxy - (format-spec - proxy - (format-spec-make - ?u (or (tramp-file-name-user (car target-alist)) "") - ?h (or (tramp-file-name-host (car target-alist)) "")))) - (with-parsed-tramp-file-name proxy l - ;; Add the hop. - (add-to-list 'target-alist l) - ;; Start next search. - (setq choices tramp-default-proxies-alist))))) - - ;; Handle gateways. - (when (and (boundp 'tramp-gw-tunnel-method) - (string-match (format - "^\\(%s\\|%s\\)$" - (symbol-value 'tramp-gw-tunnel-method) - (symbol-value 'tramp-gw-socks-method)) - (tramp-file-name-method (car target-alist)))) - (let ((gw (pop target-alist)) - (hop (pop target-alist))) - ;; Is the method prepared for gateways? - (unless (tramp-get-method-parameter - (tramp-file-name-method hop) 'tramp-default-port) - (tramp-error - vec 'file-error - "Method `%s' is not supported for gateway access." - (tramp-file-name-method hop))) - ;; Add default port if needed. - (unless - (string-match - tramp-host-with-port-regexp (tramp-file-name-host hop)) - (aset hop 2 - (concat - (tramp-file-name-host hop) tramp-prefix-port-format - (number-to-string - (tramp-get-method-parameter - (tramp-file-name-method hop) 'tramp-default-port))))) - ;; Open the gateway connection. - (add-to-list - 'target-alist - (vector - (tramp-file-name-method hop) (tramp-file-name-user hop) - (tramp-compat-funcall 'tramp-gw-open-connection vec gw hop) nil)) - ;; For the password prompt, we need the correct values. - ;; Therefore, we must remember the gateway vector. But we - ;; cannot do it as connection property, because it shouldn't - ;; be persistent. And we have no started process yet either. - (tramp-set-file-property (car target-alist) "" "gateway" hop))) - - ;; Foreign and out-of-band methods are not supported for multi-hops. - (when (cdr target-alist) - (setq choices target-alist) - (while choices - (setq item (pop choices)) - (when - (or - (not - (tramp-get-method-parameter - (tramp-file-name-method item) 'tramp-login-program)) - (tramp-get-method-parameter - (tramp-file-name-method item) 'tramp-copy-program)) - (tramp-error - vec 'file-error - "Method `%s' is not supported for multi-hops." - (tramp-file-name-method item))))) - - ;; In case the host name is not used for the remote shell - ;; command, the user could be misguided by applying a random - ;; hostname. - (let* ((v (car target-alist)) - (method (tramp-file-name-method v)) - (host (tramp-file-name-host v))) - (unless - (or - ;; There are multi-hops. - (cdr target-alist) - ;; The host name is used for the remote shell command. - (member - '("%h") (tramp-get-method-parameter method 'tramp-login-args)) - ;; The host is local. We cannot use `tramp-local-host-p' - ;; here, because it opens a connection as well. - (string-match tramp-local-host-regexp host)) - (tramp-error - v 'file-error - "Host `%s' looks like a remote host, `%s' can only use the local host" - host method))) - - ;; Result. - target-alist)) - -(defun tramp-maybe-open-connection (vec) - "Maybe open a connection VEC. -Does not do anything if a connection is already open, but re-opens the -connection if a previous connection has died for some reason." - (catch 'uname-changed - (let ((p (tramp-get-connection-process vec)) - (process-name (tramp-get-connection-property vec "process-name" nil)) - (process-environment (copy-sequence process-environment))) - - ;; If too much time has passed since last command was sent, look - ;; whether process is still alive. If it isn't, kill it. When - ;; using ssh, it can sometimes happen that the remote end has - ;; hung up but the local ssh client doesn't recognize this until - ;; it tries to send some data to the remote end. So that's why - ;; we try to send a command from time to time, then look again - ;; whether the process is really alive. - (condition-case nil - (when (and (> (tramp-time-diff - (current-time) - (tramp-get-connection-property - p "last-cmd-time" '(0 0 0))) - 60) - p (processp p) (memq (process-status p) '(run open))) - (tramp-send-command vec "echo are you awake" t t) - (unless (and (memq (process-status p) '(run open)) - (tramp-wait-for-output p 10)) - ;; The error will be catched locally. - (tramp-error vec 'file-error "Awake did fail"))) - (file-error - (tramp-flush-connection-property vec) - (tramp-flush-connection-property p) - (delete-process p) - (setq p nil))) - - ;; New connection must be opened. - (unless (and p (processp p) (memq (process-status p) '(run open))) - - ;; We call `tramp-get-buffer' in order to get a debug buffer for - ;; messages from the beginning. - (tramp-get-buffer vec) - (with-progress-reporter - vec 3 - (if (zerop (length (tramp-file-name-user vec))) - (format "Opening connection for %s using %s" - (tramp-file-name-host vec) - (tramp-file-name-method vec)) - (format "Opening connection for %s@%s using %s" - (tramp-file-name-user vec) - (tramp-file-name-host vec) - (tramp-file-name-method vec))) - - ;; Start new process. - (when (and p (processp p)) - (delete-process p)) - (setenv "TERM" tramp-terminal-type) - (setenv "LC_ALL" "C") - (setenv "PROMPT_COMMAND") - (setenv "PS1" tramp-initial-end-of-output) - (let* ((target-alist (tramp-compute-multi-hops vec)) - (process-connection-type tramp-process-connection-type) - (process-adaptive-read-buffering nil) - (coding-system-for-read nil) - ;; This must be done in order to avoid our file name handler. - (p (let ((default-directory - (tramp-compat-temporary-file-directory))) - (start-process - (or process-name (tramp-buffer-name vec)) - (tramp-get-connection-buffer vec) - tramp-encoding-shell)))) - - (tramp-message - vec 6 "%s" (mapconcat 'identity (process-command p) " ")) - - ;; Check whether process is alive. - (tramp-set-process-query-on-exit-flag p nil) - (tramp-barf-if-no-shell-prompt - p 60 "Couldn't find local shell prompt %s" tramp-encoding-shell) - - ;; Now do all the connections as specified. - (while target-alist - (let* ((hop (car target-alist)) - (l-method (tramp-file-name-method hop)) - (l-user (tramp-file-name-user hop)) - (l-host (tramp-file-name-host hop)) - (l-port nil) - (login-program - (tramp-get-method-parameter - l-method 'tramp-login-program)) - (login-args - (tramp-get-method-parameter l-method 'tramp-login-args)) - (async-args - (tramp-get-method-parameter l-method 'tramp-async-args)) - (gw-args - (tramp-get-method-parameter l-method 'tramp-gw-args)) - (gw (tramp-get-file-property hop "" "gateway" nil)) - (g-method (and gw (tramp-file-name-method gw))) - (g-user (and gw (tramp-file-name-user gw))) - (g-host (and gw (tramp-file-name-host gw))) - (command login-program) - ;; We don't create the temporary file. In fact, - ;; it is just a prefix for the ControlPath option - ;; of ssh; the real temporary file has another - ;; name, and it is created and protected by ssh. - ;; It is also removed by ssh, when the connection - ;; is closed. - (tmpfile - (tramp-set-connection-property - p "temp-file" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) - spec) - - ;; Add arguments for asynchrononous processes. - (when (and process-name async-args) - (setq login-args (append async-args login-args))) - - ;; Add gateway arguments if necessary. - (when (and gw gw-args) - (setq login-args (append gw-args login-args))) - - ;; Check for port number. Until now, there's no need - ;; for handling like method, user, host. - (when (string-match tramp-host-with-port-regexp l-host) - (setq l-port (match-string 2 l-host) - l-host (match-string 1 l-host))) - - ;; Set variables for computing the prompt for reading - ;; password. They can also be derived from a gateway. - (setq tramp-current-method (or g-method l-method) - tramp-current-user (or g-user l-user) - tramp-current-host (or g-host l-host)) - - ;; Replace login-args place holders. - (setq - l-host (or l-host "") - l-user (or l-user "") - l-port (or l-port "") - spec (format-spec-make - ?h l-host ?u l-user ?p l-port ?t tmpfile) - command - (concat - ;; We do not want to see the trailing local prompt in - ;; `start-file-process'. - (unless (memq system-type '(windows-nt)) "exec ") - command " " - (mapconcat - (lambda (x) - (setq x (mapcar (lambda (y) (format-spec y spec)) x)) - (unless (member "" x) (mapconcat 'identity x " "))) - login-args " ") - ;; Local shell could be a Windows COMSPEC. It - ;; doesn't know the ";" syntax, but we must exit - ;; always for `start-file-process'. "exec" does not - ;; work either. - (if (memq system-type '(windows-nt)) " && exit || exit"))) - - ;; Send the command. - (tramp-message vec 3 "Sending command `%s'" command) - (tramp-send-command vec command t t) - (tramp-process-actions p vec tramp-actions-before-shell 60) - (tramp-message - vec 3 "Found remote shell prompt on `%s'" l-host)) - ;; Next hop. - (setq target-alist (cdr target-alist))) - - ;; Make initial shell settings. - (tramp-open-connection-setup-interactive-shell p vec))))))) - -(defun tramp-send-command (vec command &optional neveropen nooutput) - "Send the COMMAND to connection VEC. -Erases temporary buffer before sending the command. If optional -arg NEVEROPEN is non-nil, never try to open the connection. This -is meant to be used from `tramp-maybe-open-connection' only. The -function waits for output unless NOOUTPUT is set." - (unless neveropen (tramp-maybe-open-connection vec)) - (let ((p (tramp-get-connection-process vec))) - (when (tramp-get-connection-property p "remote-echo" nil) - ;; We mark the command string that it can be erased in the output buffer. - (tramp-set-connection-property p "check-remote-echo" t) - (setq command (format "%s%s%s" tramp-echo-mark command tramp-echo-mark))) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (unless nooutput (tramp-wait-for-output p)))) - -(defun tramp-wait-for-output (proc &optional timeout) - "Wait for output from remote command." - (unless (buffer-live-p (process-buffer proc)) - (delete-process proc) - (tramp-error proc 'file-error "Process `%s' not available, try again" proc)) - (with-current-buffer (process-buffer proc) - (let* (;; Initially, `tramp-end-of-output' is "#$ ". There might - ;; be leading escape sequences, which must be ignored. - (regexp (format "[^#$\n]*%s\r?$" (regexp-quote tramp-end-of-output))) - ;; Sometimes, the commands do not return a newline but a - ;; null byte before the shell prompt, for example "git - ;; ls-files -c -z ...". - (regexp1 (format "\\(^\\|\000\\)%s" regexp)) - (found (tramp-wait-for-regexp proc timeout regexp1))) - (if found - (let (buffer-read-only) - ;; A simple-minded busybox has sent " ^H" sequences. - ;; Delete them. - (goto-char (point-min)) - (when (re-search-forward - "^\\(.\b\\)+$" (tramp-compat-line-end-position) t) - (forward-line 1) - (delete-region (point-min) (point))) - ;; Delete the prompt. - (goto-char (point-max)) - (re-search-backward regexp nil t) - (delete-region (point) (point-max))) - (if timeout - (tramp-error - proc 'file-error - "[[Remote prompt `%s' not found in %d secs]]" - tramp-end-of-output timeout) - (tramp-error - proc 'file-error - "[[Remote prompt `%s' not found]]" tramp-end-of-output))) - ;; Return value is whether end-of-output sentinel was found. - found))) - -(defun tramp-send-command-and-check - (vec command &optional subshell dont-suppress-err) - "Run COMMAND and check its exit status. -Sends `echo $?' along with the COMMAND for checking the exit status. If -COMMAND is nil, just sends `echo $?'. Returns the exit status found. - -If the optional argument SUBSHELL is non-nil, the command is -executed in a subshell, ie surrounded by parentheses. If -DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." - (tramp-send-command - vec - (concat (if subshell "( " "") - command - (if command (if dont-suppress-err "; " " 2>/dev/null; ") "") - "echo tramp_exit_status $?" - (if subshell " )" ""))) - (with-current-buffer (tramp-get-connection-buffer vec) - (goto-char (point-max)) - (unless (re-search-backward "tramp_exit_status [0-9]+" nil t) - (tramp-error - vec 'file-error "Couldn't find exit status of `%s'" command)) - (skip-chars-forward "^ ") - (prog1 - (read (current-buffer)) - (let (buffer-read-only) (delete-region (match-beginning 0) (point-max)))))) - -(defun tramp-barf-unless-okay (vec command fmt &rest args) - "Run COMMAND, check exit status, throw error if exit status not okay. -Similar to `tramp-send-command-and-check' but accepts two more arguments -FMT and ARGS which are passed to `error'." - (unless (zerop (tramp-send-command-and-check vec command)) - (apply 'tramp-error vec 'file-error fmt args))) - -(defun tramp-send-command-and-read (vec command) - "Run COMMAND and return the output, which must be a Lisp expression. -In case there is no valid Lisp expression, it raises an error" - (tramp-barf-unless-okay vec command "`%s' returns with error" command) - (with-current-buffer (tramp-get-connection-buffer vec) - ;; Read the expression. - (goto-char (point-min)) - (condition-case nil - (prog1 (read (current-buffer)) - ;; Error handling. - (when (re-search-forward "\\S-" (tramp-compat-line-end-position) t) - (error nil))) - (error (tramp-error - vec 'file-error - "`%s' does not return a valid Lisp expression: `%s'" - command (buffer-string)))))) - ;; It seems that Tru64 Unix does not like it if long strings are sent ;; to it in one go. (This happens when sending the Perl ;; `file-attributes' implementation, for instance.) Therefore, we @@ -7818,6 +3242,56 @@ the remote host use line-endings as defined in the variable (setq pos (+ pos chunksize)))) (process-send-string p string))))) +(defun tramp-get-inode (vec) + "Returns the virtual inode number. +If it doesn't exist, generate a new one." + (let ((string (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + ""))) + (unless (assoc string tramp-inodes) + (add-to-list 'tramp-inodes + (list string (length tramp-inodes)))) + (nth 1 (assoc string tramp-inodes)))) + +(defun tramp-get-device (vec) + "Returns the virtual device number. +If it doesn't exist, generate a new one." + (let ((string (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + ""))) + (unless (assoc string tramp-devices) + (add-to-list 'tramp-devices + (list string (length tramp-devices)))) + (cons -1 (nth 1 (assoc string tramp-devices))))) + +(defun tramp-equal-remote (file1 file2) + "Check, whether the remote parts of FILE1 and FILE2 are identical. +The check depends on method, user and host name of the files. If +one of the components is missing, the default values are used. +The local file name parts of FILE1 and FILE2 are not taken into +account. + +Example: + + (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\") + +would yield `t'. On the other hand, the following check results in nil: + + (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")" + (and (stringp (file-remote-p file1)) + (stringp (file-remote-p file2)) + (string-equal (file-remote-p file1) (file-remote-p file2)))) + +(defun tramp-get-method-parameter (method param) + "Return the method parameter PARAM. +If the `tramp-methods' entry does not exist, return nil." + (let ((entry (assoc param (assoc method tramp-methods)))) + (when entry (cadr entry)))) + (defun tramp-mode-string-to-int (mode-string) "Converts a ten-letter `drwxrwxrwx'-style mode string into mode bits." (let* (case-fold-search @@ -7834,454 +3308,61 @@ the remote host use line-endings as defined in the variable (save-match-data (logior (cond - ((char-equal owner-read ?r) (tramp-octal-to-decimal "00400")) + ((char-equal owner-read ?r) (tramp-compat-octal-to-decimal "00400")) ((char-equal owner-read ?-) 0) (t (error "Second char `%c' must be one of `r-'" owner-read))) (cond - ((char-equal owner-write ?w) (tramp-octal-to-decimal "00200")) + ((char-equal owner-write ?w) (tramp-compat-octal-to-decimal "00200")) ((char-equal owner-write ?-) 0) (t (error "Third char `%c' must be one of `w-'" owner-write))) (cond ((char-equal owner-execute-or-setid ?x) - (tramp-octal-to-decimal "00100")) + (tramp-compat-octal-to-decimal "00100")) ((char-equal owner-execute-or-setid ?S) - (tramp-octal-to-decimal "04000")) + (tramp-compat-octal-to-decimal "04000")) ((char-equal owner-execute-or-setid ?s) - (tramp-octal-to-decimal "04100")) + (tramp-compat-octal-to-decimal "04100")) ((char-equal owner-execute-or-setid ?-) 0) (t (error "Fourth char `%c' must be one of `xsS-'" owner-execute-or-setid))) (cond - ((char-equal group-read ?r) (tramp-octal-to-decimal "00040")) + ((char-equal group-read ?r) (tramp-compat-octal-to-decimal "00040")) ((char-equal group-read ?-) 0) (t (error "Fifth char `%c' must be one of `r-'" group-read))) (cond - ((char-equal group-write ?w) (tramp-octal-to-decimal "00020")) + ((char-equal group-write ?w) (tramp-compat-octal-to-decimal "00020")) ((char-equal group-write ?-) 0) (t (error "Sixth char `%c' must be one of `w-'" group-write))) (cond ((char-equal group-execute-or-setid ?x) - (tramp-octal-to-decimal "00010")) + (tramp-compat-octal-to-decimal "00010")) ((char-equal group-execute-or-setid ?S) - (tramp-octal-to-decimal "02000")) + (tramp-compat-octal-to-decimal "02000")) ((char-equal group-execute-or-setid ?s) - (tramp-octal-to-decimal "02010")) + (tramp-compat-octal-to-decimal "02010")) ((char-equal group-execute-or-setid ?-) 0) (t (error "Seventh char `%c' must be one of `xsS-'" group-execute-or-setid))) (cond ((char-equal other-read ?r) - (tramp-octal-to-decimal "00004")) + (tramp-compat-octal-to-decimal "00004")) ((char-equal other-read ?-) 0) (t (error "Eighth char `%c' must be one of `r-'" other-read))) (cond - ((char-equal other-write ?w) (tramp-octal-to-decimal "00002")) + ((char-equal other-write ?w) (tramp-compat-octal-to-decimal "00002")) ((char-equal other-write ?-) 0) (t (error "Nineth char `%c' must be one of `w-'" other-write))) (cond ((char-equal other-execute-or-sticky ?x) - (tramp-octal-to-decimal "00001")) + (tramp-compat-octal-to-decimal "00001")) ((char-equal other-execute-or-sticky ?T) - (tramp-octal-to-decimal "01000")) + (tramp-compat-octal-to-decimal "01000")) ((char-equal other-execute-or-sticky ?t) - (tramp-octal-to-decimal "01001")) + (tramp-compat-octal-to-decimal "01001")) ((char-equal other-execute-or-sticky ?-) 0) (t (error "Tenth char `%c' must be one of `xtT-'" other-execute-or-sticky))))))) -(defun tramp-convert-file-attributes (vec attr) - "Convert file-attributes ATTR generated by perl script, stat or ls. -Convert file mode bits to string and set virtual device number. -Return ATTR." - (when attr - ;; Convert last access time. - (unless (listp (nth 4 attr)) - (setcar (nthcdr 4 attr) - (list (floor (nth 4 attr) 65536) - (floor (mod (nth 4 attr) 65536))))) - ;; Convert last modification time. - (unless (listp (nth 5 attr)) - (setcar (nthcdr 5 attr) - (list (floor (nth 5 attr) 65536) - (floor (mod (nth 5 attr) 65536))))) - ;; Convert last status change time. - (unless (listp (nth 6 attr)) - (setcar (nthcdr 6 attr) - (list (floor (nth 6 attr) 65536) - (floor (mod (nth 6 attr) 65536))))) - ;; Convert file size. - (when (< (nth 7 attr) 0) - (setcar (nthcdr 7 attr) -1)) - (when (and (floatp (nth 7 attr)) - (<= (nth 7 attr) (tramp-compat-most-positive-fixnum))) - (setcar (nthcdr 7 attr) (round (nth 7 attr)))) - ;; Convert file mode bits to string. - (unless (stringp (nth 8 attr)) - (setcar (nthcdr 8 attr) (tramp-file-mode-from-int (nth 8 attr))) - (when (stringp (car attr)) - (aset (nth 8 attr) 0 ?l))) - ;; Convert directory indication bit. - (when (string-match "^d" (nth 8 attr)) - (setcar attr t)) - ;; Convert symlink from `tramp-do-file-attributes-with-stat'. - (when (consp (car attr)) - (if (and (stringp (caar attr)) - (string-match ".+ -> .\\(.+\\)." (caar attr))) - (setcar attr (match-string 1 (caar attr))) - (setcar attr nil))) - ;; Set file's gid change bit. - (setcar (nthcdr 9 attr) - (if (numberp (nth 3 attr)) - (not (= (nth 3 attr) - (tramp-get-remote-gid vec 'integer))) - (not (string-equal - (nth 3 attr) - (tramp-get-remote-gid vec 'string))))) - ;; Convert inode. - (unless (listp (nth 10 attr)) - (setcar (nthcdr 10 attr) - (condition-case nil - (cons (floor (nth 10 attr) 65536) - (floor (mod (nth 10 attr) 65536))) - ;; Inodes can be incredible huge. We must hide this. - (error (tramp-get-inode vec))))) - ;; Set virtual device number. - (setcar (nthcdr 11 attr) - (tramp-get-device vec)) - attr)) - -(defun tramp-check-cached-permissions (vec access) - "Check `file-attributes' caches for VEC. -Return t if according to the cache access type ACCESS is known to -be granted." - (let ((result nil) - (offset (cond - ((eq ?r access) 1) - ((eq ?w access) 2) - ((eq ?x access) 3)))) - (dolist (suffix '("string" "integer") result) - (setq - result - (or - result - (let ((file-attr - (tramp-get-file-property - vec (tramp-file-name-localname vec) - (concat "file-attributes-" suffix) nil)) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil))) - (and - file-attr - (or - ;; Not a symlink - (eq t (car file-attr)) - (null (car file-attr))) - (or - ;; World accessible. - (eq access (aref (nth 8 file-attr) (+ offset 6))) - ;; User accessible and owned by user. - (and - (eq access (aref (nth 8 file-attr) offset)) - (equal remote-uid (nth 2 file-attr))) - ;; Group accessible and owned by user's - ;; principal group. - (and - (eq access (aref (nth 8 file-attr) (+ offset 3))) - (equal remote-gid (nth 3 file-attr))))))))))) - -(defun tramp-get-inode (vec) - "Returns the virtual inode number. -If it doesn't exist, generate a new one." - (let ((string (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - ""))) - (unless (assoc string tramp-inodes) - (add-to-list 'tramp-inodes - (list string (length tramp-inodes)))) - (nth 1 (assoc string tramp-inodes)))) - -(defun tramp-get-device (vec) - "Returns the virtual device number. -If it doesn't exist, generate a new one." - (let ((string (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - ""))) - (unless (assoc string tramp-devices) - (add-to-list 'tramp-devices - (list string (length tramp-devices)))) - (cons -1 (nth 1 (assoc string tramp-devices))))) - -(defun tramp-file-mode-from-int (mode) - "Turn an integer representing a file mode into an ls(1)-like string." - (let ((type (cdr (assoc (logand (lsh mode -12) 15) tramp-file-mode-type-map))) - (user (logand (lsh mode -6) 7)) - (group (logand (lsh mode -3) 7)) - (other (logand (lsh mode -0) 7)) - (suid (> (logand (lsh mode -9) 4) 0)) - (sgid (> (logand (lsh mode -9) 2) 0)) - (sticky (> (logand (lsh mode -9) 1) 0))) - (setq user (tramp-file-mode-permissions user suid "s")) - (setq group (tramp-file-mode-permissions group sgid "s")) - (setq other (tramp-file-mode-permissions other sticky "t")) - (concat type user group other))) - -(defun tramp-file-mode-permissions (perm suid suid-text) - "Convert a permission bitset into a string. -This is used internally by `tramp-file-mode-from-int'." - (let ((r (> (logand perm 4) 0)) - (w (> (logand perm 2) 0)) - (x (> (logand perm 1) 0))) - (concat (or (and r "r") "-") - (or (and w "w") "-") - (or (and suid x suid-text) ; suid, execute - (and suid (upcase suid-text)) ; suid, !execute - (and x "x") "-")))) ; !suid - -(defun tramp-decimal-to-octal (i) - "Return a string consisting of the octal digits of I. -Not actually used. Use `(format \"%o\" i)' instead?" - (cond ((< i 0) (error "Cannot convert negative number to octal")) - ((not (integerp i)) (error "Cannot convert non-integer to octal")) - ((zerop i) "0") - (t (concat (tramp-decimal-to-octal (/ i 8)) - (number-to-string (% i 8)))))) - -;; Kudos to Gerd Moellmann for this suggestion. -(defun tramp-octal-to-decimal (ostr) - "Given a string of octal digits, return a decimal number." - (let ((x (or ostr ""))) - ;; `save-match' is in `tramp-mode-string-to-int' which calls this. - (unless (string-match "\\`[0-7]*\\'" x) - (error "Non-octal junk in string `%s'" x)) - (string-to-number ostr 8))) - -(defun tramp-shell-case-fold (string) - "Converts STRING to shell glob pattern which ignores case." - (mapconcat - (lambda (c) - (if (equal (downcase c) (upcase c)) - (vector c) - (format "[%c%c]" (downcase c) (upcase c)))) - string - "")) - - -;; ------------------------------------------------------------ -;; -- Tramp file names -- -;; ------------------------------------------------------------ -;; Conversion functions between external representation and -;; internal data structure. Convenience functions for internal -;; data structure. - -(defun tramp-file-name-p (vec) - "Check, whether VEC is a Tramp object." - (and (vectorp vec) (= 4 (length vec)))) - -(defun tramp-file-name-method (vec) - "Return method component of VEC." - (and (tramp-file-name-p vec) (aref vec 0))) - -(defun tramp-file-name-user (vec) - "Return user component of VEC." - (and (tramp-file-name-p vec) (aref vec 1))) - -(defun tramp-file-name-host (vec) - "Return host component of VEC." - (and (tramp-file-name-p vec) (aref vec 2))) - -(defun tramp-file-name-localname (vec) - "Return localname component of VEC." - (and (tramp-file-name-p vec) (aref vec 3))) - -;; The user part of a Tramp file name vector can be of kind -;; "user%domain". Sometimes, we must extract these parts. -(defun tramp-file-name-real-user (vec) - "Return the user name of VEC without domain." - (save-match-data - (let ((user (tramp-file-name-user vec))) - (if (and (stringp user) - (string-match tramp-user-with-domain-regexp user)) - (match-string 1 user) - user)))) - -(defun tramp-file-name-domain (vec) - "Return the domain name of VEC." - (save-match-data - (let ((user (tramp-file-name-user vec))) - (and (stringp user) - (string-match tramp-user-with-domain-regexp user) - (match-string 2 user))))) - -;; The host part of a Tramp file name vector can be of kind -;; "host#port". Sometimes, we must extract these parts. -(defun tramp-file-name-real-host (vec) - "Return the host name of VEC without port." - (save-match-data - (let ((host (tramp-file-name-host vec))) - (if (and (stringp host) - (string-match tramp-host-with-port-regexp host)) - (match-string 1 host) - host)))) - -(defun tramp-file-name-port (vec) - "Return the port number of VEC." - (save-match-data - (let ((host (tramp-file-name-host vec))) - (and (stringp host) - (string-match tramp-host-with-port-regexp host) - (string-to-number (match-string 2 host)))))) - -(defun tramp-tramp-file-p (name) - "Return t if NAME is a string with Tramp file name syntax." - (save-match-data - (and (stringp name) (string-match tramp-file-name-regexp name)))) - -(defun tramp-find-method (method user host) - "Return the right method string to use. -This is METHOD, if non-nil. Otherwise, do a lookup in -`tramp-default-method-alist'." - (or method - (let ((choices tramp-default-method-alist) - lmethod item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or host "")) - (string-match (or (nth 1 item) "") (or user ""))) - (setq lmethod (nth 2 item)) - (setq choices nil))) - lmethod) - tramp-default-method)) - -(defun tramp-find-user (method user host) - "Return the right user string to use. -This is USER, if non-nil. Otherwise, do a lookup in -`tramp-default-user-alist'." - (or user - (let ((choices tramp-default-user-alist) - luser item) - (while choices - (setq item (pop choices)) - (when (and (string-match (or (nth 0 item) "") (or method "")) - (string-match (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) - luser) - tramp-default-user)) - -(defun tramp-find-host (method user host) - "Return the right host string to use. -This is HOST, if non-nil. Otherwise, it is `tramp-default-host'." - (or (and (> (length host) 0) host) - tramp-default-host)) - -(defun tramp-dissect-file-name (name &optional nodefault) - "Return a `tramp-file-name' structure. -The structure consists of remote method, remote user, remote host -and localname (file name on remote host). If NODEFAULT is -non-nil, the file name parts are not expanded to their default -values." - (save-match-data - (let ((match (string-match (nth 0 tramp-file-name-structure) name))) - (unless match (error "Not a Tramp file name: %s" name)) - (let ((method (match-string (nth 1 tramp-file-name-structure) name)) - (user (match-string (nth 2 tramp-file-name-structure) name)) - (host (match-string (nth 3 tramp-file-name-structure) name)) - (localname (match-string (nth 4 tramp-file-name-structure) name))) - (when (member method '("multi" "multiu")) - (error - "`%s' method is no longer supported, see (info \"(tramp)Multi-hops\")" - method)) - (when host - (when (string-match tramp-prefix-ipv6-regexp host) - (setq host (replace-match "" nil t host))) - (when (string-match tramp-postfix-ipv6-regexp host) - (setq host (replace-match "" nil t host)))) - (if nodefault - (vector method user host localname) - (vector - (tramp-find-method method user host) - (tramp-find-user method user host) - (tramp-find-host method user host) - localname)))))) - -(defun tramp-equal-remote (file1 file2) - "Check, whether the remote parts of FILE1 and FILE2 are identical. -The check depends on method, user and host name of the files. If -one of the components is missing, the default values are used. -The local file name parts of FILE1 and FILE2 are not taken into -account. - -Example: - - (tramp-equal-remote \"/ssh::/etc\" \"/<your host name>:/home\") - -would yield `t'. On the other hand, the following check results in nil: - - (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\")" - (and (stringp (file-remote-p file1)) - (stringp (file-remote-p file2)) - (string-equal (file-remote-p file1) (file-remote-p file2)))) - -(defun tramp-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME." - (concat tramp-prefix-format - (when (not (zerop (length method))) - (concat method tramp-postfix-method-format)) - (when (not (zerop (length user))) - (concat user tramp-postfix-user-format)) - (when host - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host)) - tramp-postfix-host-format - (when localname localname))) - -(defun tramp-completion-make-tramp-file-name (method user host localname) - "Constructs a Tramp file name from METHOD, USER, HOST and LOCALNAME. -It must not be a complete Tramp file name, but as long as there are -necessary only. This function will be used in file name completion." - (concat tramp-prefix-format - (when (not (zerop (length method))) - (concat method tramp-postfix-method-format)) - (when (not (zerop (length user))) - (concat user tramp-postfix-user-format)) - (when (not (zerop (length host))) - (concat - (if (string-match tramp-ipv6-regexp host) - (concat tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) - host) - tramp-postfix-host-format)) - (when localname localname))) - -(defun tramp-make-copy-program-file-name (vec) - "Create a file name suitable to be passed to `rcp' and workalikes." - (let ((user (tramp-file-name-user vec)) - (host (tramp-file-name-real-host vec)) - (localname (tramp-shell-quote-argument - (tramp-file-name-localname vec)))) - (if (not (zerop (length user))) - (format "%s@%s:%s" user host localname) - (format "%s:%s" host localname)))) - -(defun tramp-method-out-of-band-p (vec size) - "Return t if this is an out-of-band method, nil otherwise." - (and - ;; It shall be an out-of-band method. - (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program) - ;; Either the file size is large enough, or (in rare cases) there - ;; does not exist a remote encoding. - (or (null tramp-copy-size-limit) - (> size tramp-copy-size-limit) - (null (tramp-get-inline-coding vec "remote-encoding" size))))) - (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise." ;; We cannot use `tramp-file-name-real-host'. A port is an @@ -8304,385 +3385,57 @@ necessary only. This function will be used in file name completion." (tramp-compat-temporary-file-directory))) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) - (zerop (tramp-get-remote-uid vec 'integer)))))) - -;; Variables local to connection. - -(defun tramp-get-remote-path (vec) - (with-connection-property - ;; When `tramp-own-remote-path' is in `tramp-remote-path', we - ;; cache the result for the session only. Otherwise, the result - ;; is cached persistently. - (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) - vec) - "remote-path" - (let* ((remote-path (copy-tree tramp-remote-path)) - (elt1 (memq 'tramp-default-remote-path remote-path)) - (elt2 (memq 'tramp-own-remote-path remote-path)) - (default-remote-path - (when elt1 - (condition-case nil - (tramp-send-command-and-read - vec "echo \\\"`getconf PATH`\\\"") - ;; Default if "getconf" is not available. - (error - (tramp-message - vec 3 - "`getconf PATH' not successful, using default value \"%s\"." - "/bin:/usr/bin") - "/bin:/usr/bin")))) - (own-remote-path - (when elt2 - (condition-case nil - (tramp-send-command-and-read vec "echo \\\"$PATH\\\"") - ;; Default if "getconf" is not available. - (error - (tramp-message - vec 3 "$PATH not set, ignoring `tramp-own-remote-path'.") - nil))))) - - ;; Replace place holder `tramp-default-remote-path'. - (when elt1 - (setcdr elt1 - (append - (tramp-compat-split-string default-remote-path ":") - (cdr elt1))) - (setq remote-path (delq 'tramp-default-remote-path remote-path))) - - ;; Replace place holder `tramp-own-remote-path'. - (when elt2 - (setcdr elt2 - (append - (tramp-compat-split-string own-remote-path ":") - (cdr elt2))) - (setq remote-path (delq 'tramp-own-remote-path remote-path))) + ;; This is defined in tramp-sh.el. Let's assume this is + ;; loaded already. + (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer)))))) - ;; Remove double entries. - (setq elt1 remote-path) - (while (consp elt1) - (while (and (car elt1) (setq elt2 (member (car elt1) (cdr elt1)))) - (setcar elt2 nil)) - (setq elt1 (cdr elt1))) - - ;; Remove non-existing directories. - (delq - nil - (mapcar - (lambda (x) - (and - (stringp x) - (file-directory-p - (tramp-make-tramp-file-name - (tramp-file-name-method vec) - (tramp-file-name-user vec) - (tramp-file-name-host vec) - x)) - x)) - remote-path))))) - -(defun tramp-get-remote-tmpdir (vec) - (with-connection-property vec "tmp-directory" - (let ((dir (tramp-shell-quote-argument "/tmp"))) - (if (and (zerop - (tramp-send-command-and-check - vec (format "%s -d %s" (tramp-get-test-command vec) dir))) - (zerop - (tramp-send-command-and-check - vec (format "%s -w %s" (tramp-get-test-command vec) dir)))) - dir - (tramp-error vec 'file-error "Directory %s not accessible" dir))))) - -(defun tramp-get-ls-command (vec) - (with-connection-property vec "ls" - (tramp-message vec 5 "Finding a suitable `ls' command") - (or - (catch 'ls-found - (dolist (cmd '("ls" "gnuls" "gls")) - (let ((dl (tramp-get-remote-path vec)) - result) - (while (and dl (setq result (tramp-find-executable vec cmd dl t t))) - ;; Check parameters. On busybox, "ls" output coloring is - ;; enabled by default sometimes. So we try to disable it - ;; when possible. $LS_COLORING is not supported there. - ;; Some "ls" versions are sensible wrt the order of - ;; arguments, they fail when "-al" is after the - ;; "--color=never" argument (for example on FreeBSD). - (when (zerop (tramp-send-command-and-check - vec (format "%s -lnd /" result))) - (when (zerop (tramp-send-command-and-check - vec (format - "%s --color=never -al /dev/null" result))) - (setq result (concat result " --color=never"))) - (throw 'ls-found result)) - (setq dl (cdr dl)))))) - (tramp-error vec 'file-error "Couldn't find a proper `ls' command")))) - -(defun tramp-get-ls-command-with-dired (vec) - (save-match-data - (with-connection-property vec "ls-dired" - (tramp-message vec 5 "Checking, whether `ls --dired' works") - ;; Some "ls" versions are sensible wrt the order of arguments, - ;; they fail when "-al" is after the "--dired" argument (for - ;; example on FreeBSD). - (zerop (tramp-send-command-and-check - vec (format "%s --dired -al /dev/null" - (tramp-get-ls-command vec))))))) - -(defun tramp-get-test-command (vec) - (with-connection-property vec "test" - (tramp-message vec 5 "Finding a suitable `test' command") - (if (zerop (tramp-send-command-and-check vec "test 0")) - "test" - (tramp-find-executable vec "test" (tramp-get-remote-path vec))))) - -(defun tramp-get-test-nt-command (vec) - ;; Does `test A -nt B' work? Use abominable `find' construct if it - ;; doesn't. BSD/OS 4.0 wants the parentheses around the command, - ;; for otherwise the shell crashes. - (with-connection-property vec "test-nt" - (or - (progn - (tramp-send-command - vec (format "( %s / -nt / )" (tramp-get-test-command vec))) - (with-current-buffer (tramp-get-buffer vec) - (goto-char (point-min)) - (when (looking-at (regexp-quote tramp-end-of-output)) - (format "%s %%s -nt %%s" (tramp-get-test-command vec))))) - (progn - (tramp-send-command - vec - (format - "tramp_test_nt () {\n%s -n \"`find $1 -prune -newer $2 -print`\"\n}" - (tramp-get-test-command vec))) - "tramp_test_nt %s %s")))) - -(defun tramp-get-file-exists-command (vec) - (with-connection-property vec "file-exists" - (tramp-message vec 5 "Finding command to check if file exists") - (tramp-find-file-exists-command vec))) - -(defun tramp-get-remote-ln (vec) - (with-connection-property vec "ln" - (tramp-message vec 5 "Finding a suitable `ln' command") - (tramp-find-executable vec "ln" (tramp-get-remote-path vec)))) - -(defun tramp-get-remote-perl (vec) - (with-connection-property vec "perl" - (tramp-message vec 5 "Finding a suitable `perl' command") - (let ((result - (or (tramp-find-executable vec "perl5" (tramp-get-remote-path vec)) - (tramp-find-executable - vec "perl" (tramp-get-remote-path vec))))) - ;; We must check also for some Perl modules. - (when result - (with-connection-property vec "perl-file-spec" - (zerop - (tramp-send-command-and-check - vec (format "%s -e 'use File::Spec;'" result)))) - (with-connection-property vec "perl-cwd-realpath" - (zerop - (tramp-send-command-and-check - vec (format "%s -e 'use Cwd \"realpath\";'" result))))) - result))) - -(defun tramp-get-remote-stat (vec) - (with-connection-property vec "stat" - (tramp-message vec 5 "Finding a suitable `stat' command") - (let ((result (tramp-find-executable - vec "stat" (tramp-get-remote-path vec))) - tmp) - ;; Check whether stat(1) returns usable syntax. %s does not - ;; work on older AIX systems. - (when result - (setq tmp - ;; We don't want to display an error message. - (with-temp-message (or (current-message) "") - (condition-case nil - (tramp-send-command-and-read - vec (format "%s -c '(\"%%N\" %%s)' /" result)) - (error nil)))) - (unless (and (listp tmp) (stringp (car tmp)) - (string-match "^./.$" (car tmp)) - (integerp (cadr tmp))) - (setq result nil))) - result))) - -(defun tramp-get-remote-readlink (vec) - (with-connection-property vec "readlink" - (tramp-message vec 5 "Finding a suitable `readlink' command") - (let ((result (tramp-find-executable - vec "readlink" (tramp-get-remote-path vec)))) - (when (and result - ;; We don't want to display an error message. - (with-temp-message (or (current-message) "") - (condition-case nil - (zerop - (tramp-send-command-and-check - vec (format "%s --canonicalize-missing /" result))) - (error nil)))) - result)))) +(defun tramp-make-tramp-temp-file (vec) + "Create a temporary file on the remote host identified by VEC. +Return the local name of the temporary file." + (let ((prefix + (tramp-make-tramp-file-name + (tramp-file-name-method vec) + (tramp-file-name-user vec) + (tramp-file-name-host vec) + (tramp-drop-volume-letter + (expand-file-name + tramp-temp-name-prefix + ;; This is defined in tramp-sh.el. Let's assume this is + ;; loaded already. + (tramp-compat-funcall 'tramp-get-remote-tmpdir vec))))) + result) + (while (not result) + ;; `make-temp-file' would be the natural choice for + ;; implementation. But it calls `write-region' internally, + ;; which also needs a temporary file - we would end in an + ;; infinite loop. + (setq result (make-temp-name prefix)) + (if (file-exists-p result) + (setq result nil) + ;; This creates the file by side effect. + (set-file-times result) + (set-file-modes result (tramp-compat-octal-to-decimal "0700")))) -(defun tramp-get-remote-trash (vec) - (with-connection-property vec "trash" - (tramp-message vec 5 "Finding a suitable `trash' command") - (tramp-find-executable vec "trash" (tramp-get-remote-path vec)))) - -(defun tramp-get-remote-id (vec) - (with-connection-property vec "id" - (tramp-message vec 5 "Finding POSIX `id' command") - (or - (catch 'id-found - (let ((dl (tramp-get-remote-path vec)) - result) - (while (and dl (setq result (tramp-find-executable vec "id" dl t t))) - ;; Check POSIX parameter. - (when (zerop (tramp-send-command-and-check - vec (format "%s -u" result))) - (throw 'id-found result)) - (setq dl (cdr dl))))) - (tramp-error vec 'file-error "Couldn't find a POSIX `id' command")))) - -(defun tramp-get-remote-uid (vec id-format) - (with-connection-property vec (format "uid-%s" id-format) - (let ((res (tramp-send-command-and-read - vec - (format "%s -u%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) - ;; The command might not always return a number. - (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) - -(defun tramp-get-remote-gid (vec id-format) - (with-connection-property vec (format "gid-%s" id-format) - (let ((res (tramp-send-command-and-read - vec - (format "%s -g%s %s" - (tramp-get-remote-id vec) - (if (equal id-format 'integer) "" "n") - (if (equal id-format 'integer) - "" "| sed -e s/^/\\\"/ -e s/\$/\\\"/"))))) - ;; The command might not always return a number. - (if (and (equal id-format 'integer) (not (integerp res))) -1 res)))) - -(defun tramp-get-local-uid (id-format) - (if (equal id-format 'integer) (user-uid) (user-login-name))) - -(defun tramp-get-local-gid (id-format) - (nth 3 (tramp-compat-file-attributes "~/" id-format))) - -;; Some predefined connection properties. -(defun tramp-get-inline-compress (vec prop size) - "Return the compress command related to PROP. -PROP is either `inline-compress' or `inline-decompress'. SIZE is -the length of the file to be compressed. - -If no corresponding command is found, nil is returned." - (when (and (integerp tramp-inline-compress-start-size) - (> size tramp-inline-compress-start-size)) - (with-connection-property vec prop - (tramp-find-inline-compress vec) - (tramp-get-connection-property vec prop nil)))) - -(defun tramp-get-inline-coding (vec prop size) - "Return the coding command related to PROP. -PROP is either `remote-encoding', `remode-decoding', -`local-encoding' or `local-decoding'. - -SIZE is the length of the file to be coded. Depending on SIZE, -compression might be applied. - -If no corresponding command is found, nil is returned. -Otherwise, either a string is returned which contains a `%s' mark -to be used for the respective input or output file; or a Lisp -function cell is returned to be applied on a buffer." - ;; We must catch the errors, because we want to return `nil', when - ;; no inline coding is found. - (ignore-errors - (let ((coding - (with-connection-property vec prop - (tramp-find-inline-encoding vec) - (tramp-get-connection-property vec prop nil))) - (prop1 (if (string-match "encoding" prop) - "inline-compress" "inline-decompress")) - compress) - ;; The connection property might have been cached. So we must - ;; send the script to the remote side - maybe. - (when (and coding (symbolp coding) (string-match "remote" prop)) - (let ((name (symbol-name coding))) - (while (string-match (regexp-quote "-") name) - (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value coding) name) - (setq coding name))) - (when coding - ;; Check for the `compress' command. - (setq compress (tramp-get-inline-compress vec prop1 size)) - ;; Return the value. - (cond - ((and compress (symbolp coding)) - (if (string-match "decompress" prop1) - `(lambda (beg end) - (,coding beg end) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (apply - 'call-process-region (point-min) (point-max) - (car (split-string ,compress)) t t nil - (cdr (split-string ,compress))))) - `(lambda (beg end) - (let ((coding-system-for-write 'binary) - (coding-system-for-read 'binary)) - (apply - 'call-process-region beg end - (car (split-string ,compress)) t t nil - (cdr (split-string ,compress)))) - (,coding (point-min) (point-max))))) - ((symbolp coding) - coding) - ((and compress (string-match "decoding" prop)) - (format "(%s | %s >%%s)" coding compress)) - (compress - (format "(%s <%%s | %s)" compress coding)) - ((string-match "decoding" prop) - (format "%s >%%s" coding)) - (t - (format "%s <%%s" coding))))))) + ;; Return the local part. + (with-parsed-tramp-file-name result nil localname))) -(defun tramp-get-method-parameter (method param) - "Return the method parameter PARAM. -If the `tramp-methods' entry does not exist, return nil." - (let ((entry (assoc param (assoc method tramp-methods)))) - (when entry (cadr entry)))) +(defun tramp-delete-temp-file-function () + "Remove temporary files related to current buffer." + (when (stringp tramp-temp-buffer-file-name) + (ignore-errors (delete-file tramp-temp-buffer-file-name)))) -;; Auto saving to a special directory. +(add-hook 'kill-buffer-hook 'tramp-delete-temp-file-function) +(add-hook 'tramp-cache-unload-hook + (lambda () + (remove-hook 'kill-buffer-hook + 'tramp-delete-temp-file-function))) -(defun tramp-exists-file-name-handler (operation &rest args) - "Check, whether OPERATION runs a file name handler." - ;; The file name handler is determined on base of either an - ;; argument, `buffer-file-name', or `default-directory'. - (condition-case nil - (let* ((buffer-file-name "/") - (default-directory "/") - (fnha file-name-handler-alist) - (check-file-name-operation operation) - (file-name-handler-alist - (list - (cons "/" - (lambda (operation &rest args) - "Returns OPERATION if it is the one to be checked." - (if (equal check-file-name-operation operation) - operation - (let ((file-name-handler-alist fnha)) - (apply operation args)))))))) - (equal (apply operation args) operation)) - (error nil))) +;;; Auto saving to a special directory: (unless (tramp-exists-file-name-handler 'make-auto-save-file-name) (defadvice make-auto-save-file-name (around tramp-advice-make-auto-save-file-name () activate) - "Invoke `tramp-handle-make-auto-save-file-name' for Tramp files." + "Invoke `tramp-*-handle-make-auto-save-file-name' for Tramp files." (if (tramp-tramp-file-p (buffer-file-name)) ;; We cannot call `tramp-handle-make-auto-save-file-name' ;; directly, because this would bypass the locking mechanism. @@ -8712,8 +3465,9 @@ If the `tramp-methods' entry does not exist, return nil." ;; Permissions should be set always, because there might be an old ;; auto-saved file belonging to another original file. This could ;; be a security threat. - (set-file-modes buffer-auto-save-file-name - (or (file-modes bfn) (tramp-octal-to-decimal "0600")))))) + (set-file-modes + buffer-auto-save-file-name + (or (file-modes bfn) (tramp-compat-octal-to-decimal "0600")))))) (unless (and (featurep 'xemacs) (= emacs-major-version 21) @@ -8736,9 +3490,7 @@ ALIST is of the form ((FROM . TO) ...)." (setq alist (cdr alist)))) string)) -;; ------------------------------------------------------------ -;; -- Compatibility functions section -- -;; ------------------------------------------------------------ +;;; Compatibility functions section: (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). @@ -8817,7 +3569,6 @@ Return the difference in the format of a time value." (defun tramp-time-diff (t1 t2) "Return the difference between the two times, in seconds. T1 and T2 are time values (as returned by `current-time' for example)." - ;; Pacify byte-compiler with `symbol-function'. (cond ((and (fboundp 'subtract-time) (fboundp 'float-time)) (tramp-compat-funcall @@ -8837,37 +3588,6 @@ T1 and T2 are time values (as returned by `current-time' for example)." (cadr time) (/ (or (nth 2 time) 0) 1000000.0)))))) -(defun tramp-coding-system-change-eol-conversion (coding-system eol-type) - "Return a coding system like CODING-SYSTEM but with given EOL-TYPE. -EOL-TYPE can be one of `dos', `unix', or `mac'." - (cond ((fboundp 'coding-system-change-eol-conversion) - (tramp-compat-funcall - 'coding-system-change-eol-conversion coding-system eol-type)) - ((fboundp 'subsidiary-coding-system) - (tramp-compat-funcall - 'subsidiary-coding-system coding-system - (cond ((eq eol-type 'dos) 'crlf) - ((eq eol-type 'unix) 'lf) - ((eq eol-type 'mac) 'cr) - (t - (error "Unknown EOL-TYPE `%s', must be %s" - eol-type - "`dos', `unix', or `mac'"))))) - (t (error "Can't change EOL conversion -- is MULE missing?")))) - -(defun tramp-set-process-query-on-exit-flag (process flag) - "Specify if query is needed for process when Emacs is exited. -If the second argument flag is non-nil, Emacs will query the user before -exiting if process is running." - (if (fboundp 'set-process-query-on-exit-flag) - (tramp-compat-funcall 'set-process-query-on-exit-flag process flag) - (tramp-compat-funcall 'process-kill-without-query process flag))) - - -;; ------------------------------------------------------------ -;; -- Kludges section -- -;; ------------------------------------------------------------ - ;; Currently (as of Emacs 20.5), the function `shell-quote-argument' ;; does not deal well with newline characters. Newline is replaced by ;; backslash newline. But if, say, the string `a backslash newline b' @@ -8893,6 +3613,7 @@ exiting if process is running." ;; CCC: This function should be rewritten so that ;; `shell-quote-argument' is not used. This way, we are safe from ;; changes in `shell-quote-argument'. +;;;###tramp-autoload (defun tramp-shell-quote-argument (s) "Similar to `shell-quote-argument', but groks newlines. Only works for Bourne-like shells." @@ -8918,113 +3639,42 @@ Only works for Bourne-like shells." (defun tramp-unload-tramp () "Discard Tramp from loading remote files." (interactive) - ;; When Tramp is not loaded yet, its autoloads are still active. - (tramp-unload-file-name-handlers) ;; ange-ftp settings must be enabled. (tramp-compat-funcall 'tramp-ftp-enable-ange-ftp) - ;; Maybe its not loaded yet. - (condition-case nil - (unload-feature 'tramp 'force) - (error nil))) - -(when (and load-in-progress - (string-match "Loading tramp..." (or (current-message) ""))) - (message "Loading tramp...done")) + ;; Maybe it's not loaded yet. + (ignore-errors (unload-feature 'tramp 'force))) (provide 'tramp) ;;; TODO: -;; * Handle nonlocal exits such as C-g. -;; * But it would probably be better to use with-local-quit at the -;; place where it's actually needed: around any potentially -;; indefinitely blocking piece of code. In this case it would be -;; within Tramp around one of its calls to accept-process-output (or -;; around one of the loops that calls accept-process-output) -;; (Stefan Monnier). ;; * Rewrite `tramp-shell-quote-argument' to abstain from using ;; `shell-quote-argument'. ;; * In Emacs 21, `insert-directory' shows total number of bytes used ;; by the files in that directory. Add this here. ;; * Avoid screen blanking when hitting `g' in dired. (Eli Tziperman) ;; * Make ffap.el grok Tramp filenames. (Eli Tziperman) -;; * Don't use globbing for directories with many files, as this is -;; likely to produce long command lines, and some shells choke on -;; long command lines. -;; * How to deal with MULE in `insert-file-contents' and `write-region'? ;; * abbreviate-file-name ;; * Better error checking. At least whenever we see something ;; strange when doing zerop, we should kill the process and start ;; again. (Greg Stark) -;; * Remove unneeded parameters from methods. -;; * Make it work for different encodings, and for different file name -;; encodings, too. (Daniel Pittman) -;; * Don't search for perl5 and perl. Instead, only search for perl and -;; then look if it's the right version (with `perl -v'). -;; * When editing a remote CVS controlled file as a different user, VC -;; gets confused about the file locking status. Try to find out why -;; the workaround doesn't work. ;; * Username and hostname completion. ;; ** Try to avoid usage of `last-input-event' in `tramp-completion-mode-p'. ;; ** Unify `tramp-parse-{rhosts,shosts,sconfig,hosts,passwd,netrc}'. ;; Code is nearly identical. -;; * Allow out-of-band methods as _last_ multi-hop. Open a connection -;; until the last but one hop via `start-file-process'. Apply it -;; also for ftp and smb. -;; * WIBNI if we had a command "trampclient"? If I was editing in -;; some shell with root priviledges, it would be nice if I could -;; just call -;; trampclient filename.c -;; as an editor, and the _current_ shell would connect to an Emacs -;; server and would be used in an existing non-priviledged Emacs -;; session for doing the editing in question. -;; That way, I need not tell Emacs my password again and be afraid -;; that it makes it into core dumps or other ugly stuff (I had Emacs -;; once display a just typed password in the context of a keyboard -;; sequence prompt for a question immediately following in a shell -;; script run within Emacs -- nasty). -;; And if I have some ssh session running to a different computer, -;; having the possibility of passing a local file there to a local -;; Emacs session (in case I can arrange for a connection back) would -;; be nice. -;; Likely the corresponding Tramp server should not allow the -;; equivalent of the emacsclient -eval option in order to make this -;; reasonably unproblematic. And maybe trampclient should have some -;; way of passing credentials, like by using an SSL socket or -;; something. (David Kastrup) -;; * Reconnect directly to a compliant shell without first going -;; through the user's default shell. (Pete Forman) ;; * Make `tramp-default-user' obsolete. -;; * How can I interrupt the remote process with a signal -;; (interrupt-process seems not to work)? (Markus Triska) -;; * Avoid the local shell entirely for starting remote processes. If -;; so, I think even a signal, when delivered directly to the local -;; SSH instance, would correctly be propagated to the remote process -;; automatically; possibly SSH would have to be started with -;; "-t". (Markus Triska) -;; * It makes me wonder if tramp couldn't fall back to ssh when scp -;; isn't on the remote host. (Mark A. Hershberger) -;; * Use lsh instead of ssh. (Alfred M. Szmidt) ;; * Implement a general server-local-variable mechanism, as there are ;; probably other variables that need different values for different ;; servers too. The user could then configure a variable (such as ;; tramp-server-local-variable-alist) to define any such variables ;; that they need to, which would then be let bound as appropriate ;; in tramp functions. (Jason Rumney) -;; * Optimize out-of-band copying, when both methods are scp-like (not -;; rsync). -;; * Keep a second connection open for out-of-band methods like scp or -;; rsync. ;; * IMHO, it's a drawback that currently Tramp doesn't support ;; Unicode in Dired file names by default. Is it possible to ;; improve Tramp to set LC_ALL to "C" only for commands where Tramp ;; expects English? Or just to set LC_MESSAGES to "C" if Tramp ;; expects only English messages? (Juri Linkov) ;; * Make shadowfile.el grok Tramp filenames. (Bug#4526, Bug#4846) -;; * Load Tramp subpackages only when needed. (Bug#1529, Bug#5448, Bug#5705) -;; * Try telnet+curl as new method. It might be useful for busybox, -;; without built-in uuencode/uudecode. -;; * Load ~/.emacs_SHELLNAME on the remote host for `shell'. ;; * I was wondering it it would be possible to use tramp even if I'm ;; actually using sshfs. But when I launch a command I would like ;; to get it executed on the remote machine where the files really @@ -9036,7 +3686,6 @@ Only works for Bourne-like shells." ;; Functions for file-name-handler-alist: ;; diff-latest-backup-file -- in diff.el -;; arch-tag: 3a21a994-182b-48fa-b0cd-c1d9fede424a ;;; tramp.el ends here ;; Local Variables: diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 80e06121f83..e58fe01ee32 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -6,6 +6,7 @@ ;; Author: Kai Großjohann <kai.grossjohann@gmx.net> ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -30,19 +31,31 @@ ;; version check is defined in macro AC_EMACS_INFO of aclocal.m4; ;; should be changed only there. -(defconst tramp-version "2.1.20" +;;;###tramp-autoload +(defconst tramp-version "2.2.1-pre" "This version of Tramp.") +;;;###tramp-autoload (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 22) (and (featurep 'xemacs) (= emacs-major-version 21) (>= emacs-minor-version 4))) "ok" (format "Tramp 2.1.20 is not fit for %s" (when (string-match "^.*$" (emacs-version)) (match-string 0 (emacs-version))))))) +(let ((x (if (or (>= emacs-major-version 22) + (and (featurep 'xemacs) + (= emacs-major-version 21) + (>= emacs-minor-version 4))) + "ok" + (format "Tramp 2.2.1-pre is not fit for %s" + (when (string-match "^.*$" (emacs-version)) + (match-string 0 (emacs-version))))))) (unless (string-match "\\`ok\\'" x) (error "%s" x))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'trampver 'force))) + (provide 'trampver) -;; arch-tag: 443576ca-f8f1-4bb1-addc-5c70861e93b1 ;;; trampver.el ends here ;; Local Variables: diff --git a/lisp/net/xesam.el b/lisp/net/xesam.el index e783f3ce102..234a89393a9 100644 --- a/lisp/net/xesam.el +++ b/lisp/net/xesam.el @@ -151,7 +151,7 @@ (defgroup xesam nil "Xesam compatible interface to search engines." :group 'extensions - :group 'hypermedia + :group 'comm :version "23.1") (defcustom xesam-query-type 'user-query |