tramp-compat.el 13.5 KB
Newer Older
1
;;; tramp-compat.el --- Tramp compatibility functions
2

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 2007-2016 Free Software Foundation, Inc.
4 5 6

;; Author: Michael Albinus <michael.albinus@gmx.de>
;; Keywords: comm, processes
7
;; Package: tramp
8 9 10

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
15 16 17 18 19 20 21

;; 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
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23 24 25

;;; Commentary:

Michael Albinus's avatar
Michael Albinus committed
26 27 28
;; Tramp's main Emacs version for development is Emacs 26.  This
;; package provides compatibility functions for Emacs 23, Emacs 24 and
;; Emacs 25.
29 30 31

;;; Code:

Michael Albinus's avatar
Michael Albinus committed
32
;; Pacify byte-compiler.
33 34 35
(eval-when-compile
  (require 'cl))

36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
(require 'auth-source)
(require 'advice)
(require 'custom)
(require 'format-spec)
(require 'password-cache)
(require 'shell)
(require 'timer)
(require 'ucs-normalize)

(require 'trampver)
(require 'tramp-loaddefs)

;; `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.
(unless (boundp 'remote-file-name-inhibit-cache)
  (defvar remote-file-name-inhibit-cache nil))

54 55 56
;; For not existing functions, obsolete functions, or functions with a
;; changed argument list, there are compiler warnings.  We want to
;; avoid them in cases we know what we do.
57
(defmacro tramp-compat-funcall (function &rest arguments)
58
  "Call FUNCTION if it exists.  Do not raise compiler warnings."
59
  `(when (functionp ,function)
60 61 62 63 64 65 66 67 68 69 70 71
     (with-no-warnings (funcall ,function ,@arguments))))

;; We currently use "[" and "]" in the filename format for IPv6 hosts
;; of GNU Emacs.  This means that Emacs wants to expand wildcards if
;; `find-file-wildcards' is non-nil, and then barfs because no
;; expansion could be found.  We detect this situation and do
;; something really awful: we have `file-expand-wildcards' return the
;; original filename if it can't expand anything.  Let's just hope
;; that this doesn't break anything else.  It is not needed anymore
;; since GNU Emacs 23.2.
(unless (featurep 'files 'remote-wildcards)
  (defadvice file-expand-wildcards
72
      (around tramp-advice-file-expand-wildcards activate)
73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
    (let ((name (ad-get-arg 0)))
      ;; If it's a Tramp file, look if wildcards need to be expanded
      ;; at all.
      (if (and
	   (tramp-tramp-file-p name)
	   (not (string-match "[[*?]" (file-remote-p name 'localname))))
	  (setq ad-return-value (list name))
	;; Otherwise, just run the original function.
	ad-do-it)))
  (add-hook
   'tramp-unload-hook
   (lambda ()
     (ad-remove-advice
      'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards)
     (ad-activate 'file-expand-wildcards))))
88

Michael Albinus's avatar
Michael Albinus committed
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
;; `condition-case-unless-debug' is introduced with Emacs 24.
(if (fboundp 'condition-case-unless-debug)
    (defalias 'tramp-compat-condition-case-unless-debug
      'condition-case-unless-debug)
  (defmacro tramp-compat-condition-case-unless-debug
    (var bodyform &rest handlers)
  "Like `condition-case' except that it does not catch anything when debugging."
    (declare (debug condition-case) (indent 2))
    (let ((bodysym (make-symbol "body")))
      `(let ((,bodysym (lambda () ,bodyform)))
	 (if debug-on-error
	     (funcall ,bodysym)
	   (condition-case ,var
	       (funcall ,bodysym)
	     ,@handlers))))))

105
(defsubst tramp-compat-temporary-file-directory ()
106 107 108 109 110 111
  "Return name of directory for temporary files.
It is the default value of `temporary-file-directory'."
  ;; We must return a local directory.  If it is remote, we could run
  ;; into an infloop.
  (eval (car (get 'temporary-file-directory 'standard-value))))

112
(defsubst tramp-compat-make-temp-file (f &optional dir-flag)
113
  "Create a local temporary file (compat function).
114
Add the extension of F, if existing."
115 116 117 118
  (let* (file-name-handler-alist
	 (prefix (expand-file-name
		  (symbol-value 'tramp-temp-name-prefix)
		  (tramp-compat-temporary-file-directory)))
119 120 121
	 (extension (file-name-extension f t)))
    (make-temp-file prefix dir-flag extension)))

122
;; `temporary-file-directory' as function is introduced with Emacs 26.1.
123 124 125 126 127
(defalias 'tramp-compat-temporary-file-directory-function
  (if (fboundp 'temporary-file-directory)
      'temporary-file-directory
    'tramp-handle-temporary-file-directory))

128 129
;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with Emacs 24.1
;; (as PRESERVE-SELINUX-CONTEXT), and renamed in Emacs 24.3.
130
(defun tramp-compat-copy-file
131
  (filename newname &optional ok-if-already-exists keep-date
132
   preserve-uid-gid preserve-extended-attributes)
133
  "Like `copy-file' for Tramp files (compat function)."
134
  (cond
135
   (preserve-extended-attributes
136 137 138 139 140
    (condition-case nil
	(tramp-compat-funcall
	 'copy-file filename newname ok-if-already-exists keep-date
	 preserve-uid-gid preserve-extended-attributes)
      (wrong-number-of-arguments
141
       (copy-file
142
	filename newname ok-if-already-exists keep-date preserve-uid-gid))))
143
   (t
144 145
    (copy-file
     filename newname ok-if-already-exists keep-date preserve-uid-gid))))
146

147
;; COPY-CONTENTS has been introduced with Emacs 24.1.
148
(defun tramp-compat-copy-directory
Michael Albinus's avatar
Michael Albinus committed
149
  (directory newname &optional keep-time parents copy-contents)
150
  "Make a copy of DIRECTORY (compat function)."
Michael Albinus's avatar
Michael Albinus committed
151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
  (condition-case nil
      (tramp-compat-funcall
       'copy-directory directory newname keep-time parents copy-contents)

    ;; `copy-directory' is either not implemented, or it does not
    ;; support the the COPY-CONTENTS flag.  For the time being, we
    ;; ignore COPY-CONTENTS as well.

    (error
     ;; If `default-directory' is a remote directory, make sure we
     ;; find its `copy-directory' handler.
     (let ((handler (or (find-file-name-handler directory 'copy-directory)
			(find-file-name-handler newname 'copy-directory))))
       (if handler
	   (funcall handler 'copy-directory directory newname keep-time parents)

	 ;; Compute target name.
	 (setq directory (directory-file-name (expand-file-name directory))
	       newname   (directory-file-name (expand-file-name newname)))
	 (if (and (file-directory-p newname)
		  (not (string-equal (file-name-nondirectory directory)
				     (file-name-nondirectory newname))))
	     (setq newname
		   (expand-file-name
		    (file-name-nondirectory directory) newname)))
	 (if (not (file-directory-p newname)) (make-directory newname parents))

	 ;; Copy recursively.
	 (mapc
	  (lambda (file)
	    (if (file-directory-p file)
		(tramp-compat-copy-directory file newname keep-time parents)
	      (copy-file file newname t keep-time)))
	  ;; We do not want to delete "." and "..".
185
	  (directory-files directory 'full directory-files-no-dot-files-regexp))
Michael Albinus's avatar
Michael Albinus committed
186 187 188 189 190

	 ;; Set directory attributes.
	 (set-file-modes newname (file-modes directory))
	 (if keep-time
	     (set-file-times newname (nth 5 (file-attributes directory)))))))))
191

192 193
;; TRASH has been introduced with Emacs 24.1.
(defun tramp-compat-delete-file (filename &optional trash)
194
  "Like `delete-file' for Tramp files (compat function)."
195 196 197 198 199 200
  (condition-case nil
      (tramp-compat-funcall 'delete-file filename trash)
    ;; This Emacs version does not support the TRASH flag.
    (wrong-number-of-arguments
     (let ((delete-by-moving-to-trash
	    (and (boundp 'delete-by-moving-to-trash)
201
		 (symbol-value 'delete-by-moving-to-trash)
202 203
		 trash)))
       (delete-file filename)))))
204

205 206 207
;; RECURSIVE has been introduced with Emacs 23.2.  TRASH has been
;; introduced with Emacs 24.1.
(defun tramp-compat-delete-directory (directory &optional recursive trash)
208
  "Like `delete-directory' for Tramp files (compat function)."
209 210 211 212 213
  (condition-case nil
      (cond
       (trash
	(tramp-compat-funcall 'delete-directory directory recursive trash))
       (t
214 215 216
	(delete-directory directory recursive)))
    ;; This Emacs version does not support the TRASH flag.  We use the
    ;; implementation from Emacs 23.2.
217 218
    (wrong-number-of-arguments
     (setq directory (directory-file-name (expand-file-name directory)))
219 220 221 222 223 224 225
     (when (not (file-symlink-p directory))
       (mapc (lambda (file)
	       (if (eq t (car (file-attributes file)))
		   (tramp-compat-delete-directory file recursive trash)
		 (tramp-compat-delete-file file trash)))
	     (directory-files
	      directory 'full directory-files-no-dot-files-regexp)))
226
     (delete-directory directory))))
227

228
(defun tramp-compat-process-running-p (process-name)
229
  "Returns t if system process PROCESS-NAME is running for `user-login-name'."
230 231 232 233
  (when (stringp process-name)
    (cond
     ;; GNU Emacs 22 on w32.
     ((fboundp 'w32-window-exists-p)
234
      (tramp-compat-funcall 'w32-window-exists-p process-name process-name))
235 236 237 238

     ;; GNU Emacs 23.
     ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
      (let (result)
239
	(dolist (pid (tramp-compat-funcall 'list-system-processes) result)
240
	  (let ((attributes (process-attributes pid)))
241 242 243 244 245 246 247 248 249
	    (when (and (string-equal
                        (cdr (assoc 'user attributes)) (user-login-name))
                       (let ((comm (cdr (assoc 'comm attributes))))
                         ;; The returned command name could be truncated
                         ;; to 15 characters.  Therefore, we cannot check
                         ;; for `string-equal'.
                         (and comm (string-match
                                    (concat "^" (regexp-quote comm))
                                    process-name))))
250
	      (setq result t)))))))))
251

252 253 254 255 256 257 258 259 260 261 262 263 264
;; `process-running-live-p' is introduced in Emacs 24.
(defalias 'tramp-compat-process-live-p
  (if (fboundp 'process-running-live-p)
      'process-running-live-p
    (lambda (process)
      "Returns non-nil if PROCESS is alive.
A process is considered alive if its status is `run', `open',
`listen', `connect' or `stop'.  Value is nil if PROCESS is not a
process."
      (and (processp process)
	   (memq (process-status process)
		 '(run open listen connect stop))))))

Michael Albinus's avatar
Michael Albinus committed
265 266 267 268 269 270 271
;; `user-error' has appeared in Emacs 24.3.
(defsubst tramp-compat-user-error (vec-or-proc format &rest args)
  "Signal a pilot error."
  (apply
   'tramp-error vec-or-proc
   (if (fboundp 'user-error) 'user-error 'error) format args))

272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330
;; `file-attribute-*' are introduced in Emacs 25.1.

(if (fboundp 'file-attribute-type)
    (defalias 'tramp-compat-file-attribute-type 'file-attribute-type)
  (defsubst tramp-compat-file-attribute-type (attributes)
    "The type field in ATTRIBUTES returned by `file-attributes'.
The value is either t for directory, string (name linked to) for
symbolic link, or nil."
    (nth 0 attributes)))

(if (fboundp 'file-attribute-link-number)
    (defalias 'tramp-compat-file-attribute-link-number
      'file-attribute-link-number)
  (defsubst tramp-compat-file-attribute-link-number (attributes)
    "Return the number of links in ATTRIBUTES returned by `file-attributes'."
    (nth 1 attributes)))

(if (fboundp 'file-attribute-user-id)
    (defalias 'tramp-compat-file-attribute-user-id 'file-attribute-user-id)
  (defsubst tramp-compat-file-attribute-user-id (attributes)
    "The UID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number.  If a string value cannot be
looked up, a numeric value, either an integer or a float, is
returned."
    (nth 2 attributes)))

(if (fboundp 'file-attribute-group-id)
    (defalias 'tramp-compat-file-attribute-group-id 'file-attribute-group-id)
  (defsubst tramp-compat-file-attribute-group-id (attributes)
    "The GID field in ATTRIBUTES returned by `file-attributes'.
This is either a string or a number.  If a string value cannot be
looked up, a numeric value, either an integer or a float, is
returned."
    (nth 3 attributes)))

(if (fboundp 'file-attribute-modification-time)
    (defalias 'tramp-compat-file-attribute-modification-time
      'file-attribute-modification-time)
  (defsubst tramp-compat-file-attribute-modification-time (attributes)
    "The modification time in ATTRIBUTES returned by `file-attributes'.
This is the time of the last change to the file's contents, and
is a list of integers (HIGH LOW USEC PSEC) in the same style
as (current-time)."
    (nth 5 attributes)))

(if (fboundp 'file-attribute-size)
    (defalias 'tramp-compat-file-attribute-size 'file-attribute-size)
  (defsubst tramp-compat-file-attribute-size (attributes)
    "The size (in bytes) in ATTRIBUTES returned by `file-attributes'.
This is a floating point number if the size is too large for an integer."
    (nth 7 attributes)))

(if (fboundp 'file-attribute-modes)
    (defalias 'tramp-compat-file-attribute-modes 'file-attribute-modes)
  (defsubst tramp-compat-file-attribute-modes (attributes)
    "The file modes in ATTRIBUTES returned by `file-attributes'.
This is a string of ten letters or dashes as in ls -l."
    (nth 8 attributes)))

Michael Albinus's avatar
Michael Albinus committed
331 332 333 334
;; `default-toplevel-value' has been declared in Emacs 24.
(unless (fboundp 'default-toplevel-value)
  (defalias 'default-toplevel-value 'symbol-value))

335
;; `format-message' is new in Emacs 25.
336
(unless (fboundp 'format-message)
337
  (defalias 'format-message 'format))
338

Michael Albinus's avatar
Michael Albinus committed
339 340 341 342 343
;; `file-missing' is introduced in Emacs 26.
(defconst tramp-file-missing
  (if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
  "The error symbol for the `file-missing' error.")

344 345
(add-hook 'tramp-unload-hook
	  (lambda ()
346
	    (unload-feature 'tramp-loaddefs 'force)
347 348
	    (unload-feature 'tramp-compat 'force)))

349 350 351 352 353
(provide 'tramp-compat)

;;; TODO:

;;; tramp-compat.el ends here