tramp-compat.el 13.6 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
(require 'auth-source)
(require 'advice)
(require 'custom)
(require 'format-spec)
Michael Albinus's avatar
Michael Albinus committed
40
(require 'parse-time)
41 42 43 44 45 46 47 48 49 50 51 52 53 54
(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))

55 56 57
;; 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.
58
(defmacro tramp-compat-funcall (function &rest arguments)
59
  "Call FUNCTION if it exists.  Do not raise compiler warnings."
60
  `(when (functionp ,function)
61 62 63 64 65 66 67 68 69 70 71 72
     (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
73
      (around tramp-advice-file-expand-wildcards activate)
74 75 76 77 78 79 80 81 82 83 84 85 86 87 88
    (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))))
89

Michael Albinus's avatar
Michael Albinus committed
90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
;; `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))))))

106
(defsubst tramp-compat-temporary-file-directory ()
107 108 109 110 111 112
  "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))))

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

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

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

148
;; COPY-CONTENTS has been introduced with Emacs 24.1.
149
(defun tramp-compat-copy-directory
Michael Albinus's avatar
Michael Albinus committed
150
  (directory newname &optional keep-time parents copy-contents)
151
  "Make a copy of DIRECTORY (compat function)."
Michael Albinus's avatar
Michael Albinus committed
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 185
  (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 "..".
186
	  (directory-files directory 'full directory-files-no-dot-files-regexp))
Michael Albinus's avatar
Michael Albinus committed
187 188 189 190 191

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

193 194
;; TRASH has been introduced with Emacs 24.1.
(defun tramp-compat-delete-file (filename &optional trash)
195
  "Like `delete-file' for Tramp files (compat function)."
196 197 198 199 200 201
  (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)
202
		 (symbol-value 'delete-by-moving-to-trash)
203 204
		 trash)))
       (delete-file filename)))))
205

206 207 208
;; 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)
209
  "Like `delete-directory' for Tramp files (compat function)."
210 211 212 213 214
  (condition-case nil
      (cond
       (trash
	(tramp-compat-funcall 'delete-directory directory recursive trash))
       (t
215 216 217
	(delete-directory directory recursive)))
    ;; This Emacs version does not support the TRASH flag.  We use the
    ;; implementation from Emacs 23.2.
218 219
    (wrong-number-of-arguments
     (setq directory (directory-file-name (expand-file-name directory)))
220 221 222 223 224 225 226
     (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)))
227
     (delete-directory directory))))
228

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

     ;; GNU Emacs 23.
     ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
      (let (result)
240
	(dolist (pid (tramp-compat-funcall 'list-system-processes) result)
241
	  (let ((attributes (process-attributes pid)))
242 243 244 245 246 247 248 249 250
	    (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))))
251
	      (setq result t)))))))))
252

253 254 255 256 257 258 259 260 261 262 263 264 265
;; `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
266 267 268 269 270 271 272
;; `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))

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 331
;; `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
332 333 334 335
;; `default-toplevel-value' has been declared in Emacs 24.
(unless (fboundp 'default-toplevel-value)
  (defalias 'default-toplevel-value 'symbol-value))

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

Michael Albinus's avatar
Michael Albinus committed
340 341 342 343 344
;; `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.")

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

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

;;; TODO:

;;; tramp-compat.el ends here