lisp/net/tramp-compat.el

   1 ;;; tramp-compat.el --- Tramp compatibility functions
   2
   3 ;; Copyright (C) 2007-2017 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Keywords: comm, processes
   7 ;; Package: tramp
   8
   9 ;; This file is part of GNU Emacs.
  10
  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 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; 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 ;;; Commentary:
  25
  26 ;; Tramp's main Emacs version for development is Emacs 26.  This
  27 ;; package provides compatibility functions for Emacs 23, Emacs 24 and
  28 ;; Emacs 25.
  29
  30 ;;; Code:
  31
  32 ;; Pacify byte-compiler.
  33 (eval-when-compile
  34   (require 'cl))
  35
  36 (require 'auth-source)
  37 (require 'advice)
  38 (require 'custom)
  39 (require 'format-spec)
  40 (require 'parse-time)
  41 (require 'password-cache)
  42 (require 'shell)
  43 (require 'timer)
  44 (require 'ucs-normalize)
  45
  46 (require 'trampver)
  47 (require 'tramp-loaddefs)
  48
  49 ;; `remote-file-name-inhibit-cache' has been introduced with Emacs
  50 ;; 24.1.  Besides t, nil, and integer, we use also timestamps (as
  51 ;; returned by `current-time') internally.
  52 (unless (boundp 'remote-file-name-inhibit-cache)
  53   (defvar remote-file-name-inhibit-cache nil))
  54
  55 ;; For not existing functions, obsolete functions, or functions with a
  56 ;; changed argument list, there are compiler warnings.  We want to
  57 ;; 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      (with-no-warnings (funcall ,function ,@arguments))))
  62
  63 ;; We currently use "[" and "]" in the filename format for IPv6 hosts
  64 ;; of GNU Emacs.  This means that Emacs wants to expand wildcards if
  65 ;; `find-file-wildcards' is non-nil, and then barfs because no
  66 ;; expansion could be found.  We detect this situation and do
  67 ;; something really awful: we have `file-expand-wildcards' return the
  68 ;; original filename if it can't expand anything.  Let's just hope
  69 ;; that this doesn't break anything else.  It is not needed anymore
  70 ;; since GNU Emacs 23.2.
  71 (unless (featurep 'files 'remote-wildcards)
  72   (defadvice file-expand-wildcards
  73       (around tramp-advice-file-expand-wildcards activate)
  74     (let ((name (ad-get-arg 0)))
  75       ;; If it's a Tramp file, look if wildcards need to be expanded
  76       ;; at all.
  77       (if (and
  78            (tramp-tramp-file-p name)
  79            (not (string-match "[[*?]" (file-remote-p name 'localname))))
  80           (setq ad-return-value (list name))
  81         ;; Otherwise, just run the original function.
  82         ad-do-it)))
  83   (add-hook
  84    'tramp-unload-hook
  85    (lambda ()
  86      (ad-remove-advice
  87       'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards)
  88      (ad-activate 'file-expand-wildcards))))
  89
  90 ;; `condition-case-unless-debug' is introduced with Emacs 24.
  91 (if (fboundp 'condition-case-unless-debug)
  92     (defalias 'tramp-compat-condition-case-unless-debug
  93       'condition-case-unless-debug)
  94   (defmacro tramp-compat-condition-case-unless-debug
  95     (var bodyform &rest handlers)
  96   "Like `condition-case' except that it does not catch anything when debugging."
  97     (declare (debug condition-case) (indent 2))
  98     (let ((bodysym (make-symbol "body")))
  99       `(let ((,bodysym (lambda () ,bodyform)))
 100          (if debug-on-error
 101              (funcall ,bodysym)
 102            (condition-case ,var
 103                (funcall ,bodysym)
 104              ,@handlers))))))
 105
 106 (defsubst tramp-compat-temporary-file-directory ()
 107   "Return name of directory for temporary files.
 108 It is the default value of `temporary-file-directory'."
 109   ;; We must return a local directory.  If it is remote, we could run
 110   ;; into an infloop.
 111   (eval (car (get 'temporary-file-directory 'standard-value))))
 112
 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   (let* (file-name-handler-alist
 117          (prefix (expand-file-name
 118                   (symbol-value 'tramp-temp-name-prefix)
 119                   (tramp-compat-temporary-file-directory)))
 120          (extension (file-name-extension f t)))
 121     (make-temp-file prefix dir-flag extension)))
 122
 123 ;; `temporary-file-directory' as function is introduced with Emacs 26.1.
 124 (defalias 'tramp-compat-temporary-file-directory-function
 125   (if (fboundp 'temporary-file-directory)
 126       'temporary-file-directory
 127     'tramp-handle-temporary-file-directory))
 128
 129 ;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with Emacs 24.1
 130 ;; (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     (condition-case nil
 138         (tramp-compat-funcall
 139          'copy-file filename newname ok-if-already-exists keep-date
 140          preserve-uid-gid preserve-extended-attributes)
 141       (wrong-number-of-arguments
 142        (copy-file
 143         filename newname ok-if-already-exists keep-date preserve-uid-gid))))
 144    (t
 145     (copy-file
 146      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
 150   (directory newname &optional keep-time parents copy-contents)
 151   "Make a copy of DIRECTORY (compat function)."
 152   (condition-case nil
 153       (tramp-compat-funcall
 154        'copy-directory directory newname keep-time parents copy-contents)
 155
 156     ;; `copy-directory' is either not implemented, or it does not
 157     ;; support the the COPY-CONTENTS flag.  For the time being, we
 158     ;; ignore COPY-CONTENTS as well.
 159
 160     (error
 161      ;; If `default-directory' is a remote directory, make sure we
 162      ;; find its `copy-directory' handler.
 163      (let ((handler (or (find-file-name-handler directory 'copy-directory)
 164                         (find-file-name-handler newname 'copy-directory))))
 165        (if handler
 166            (funcall handler 'copy-directory directory newname keep-time parents)
 167
 168          ;; Compute target name.
 169          (setq directory (directory-file-name (expand-file-name directory))
 170                newname   (directory-file-name (expand-file-name newname)))
 171          (if (and (file-directory-p newname)
 172                   (not (string-equal (file-name-nondirectory directory)
 173                                      (file-name-nondirectory newname))))
 174              (setq newname
 175                    (expand-file-name
 176                     (file-name-nondirectory directory) newname)))
 177          (if (not (file-directory-p newname)) (make-directory newname parents))
 178
 179          ;; Copy recursively.
 180          (mapc
 181           (lambda (file)
 182             (if (file-directory-p file)
 183                 (tramp-compat-copy-directory file newname keep-time parents)
 184               (copy-file file newname t keep-time)))
 185           ;; We do not want to delete "." and "..".
 186           (directory-files directory 'full directory-files-no-dot-files-regexp))
 187
 188          ;; Set directory attributes.
 189          (set-file-modes newname (file-modes directory))
 190          (if keep-time
 191              (set-file-times newname (nth 5 (file-attributes directory)))))))))
 192
 193 ;; TRASH has been introduced with Emacs 24.1.
 194 (defun tramp-compat-delete-file (filename &optional trash)
 195   "Like `delete-file' for Tramp files (compat function)."
 196   (condition-case nil
 197       (tramp-compat-funcall 'delete-file filename trash)
 198     ;; This Emacs version does not support the TRASH flag.
 199     (wrong-number-of-arguments
 200      (let ((delete-by-moving-to-trash
 201             (and (boundp 'delete-by-moving-to-trash)
 202                  (symbol-value 'delete-by-moving-to-trash)
 203                  trash)))
 204        (delete-file filename)))))
 205
 206 ;; RECURSIVE has been introduced with Emacs 23.2.  TRASH has been
 207 ;; introduced with Emacs 24.1.
 208 (defun tramp-compat-delete-directory (directory &optional recursive trash)
 209   "Like `delete-directory' for Tramp files (compat function)."
 210   (condition-case nil
 211       (cond
 212        (trash
 213         (tramp-compat-funcall 'delete-directory directory recursive trash))
 214        (t
 215         (delete-directory directory recursive)))
 216     ;; This Emacs version does not support the TRASH flag.  We use the
 217     ;; implementation from Emacs 23.2.
 218     (wrong-number-of-arguments
 219      (setq directory (directory-file-name (expand-file-name directory)))
 220      (when (not (file-symlink-p directory))
 221        (mapc (lambda (file)
 222                (if (eq t (car (file-attributes file)))
 223                    (tramp-compat-delete-directory file recursive trash)
 224                  (tramp-compat-delete-file file trash)))
 225              (directory-files
 226               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   (when (stringp process-name)
 232     (cond
 233      ;; GNU Emacs 22 on w32.
 234      ((fboundp 'w32-window-exists-p)
 235       (tramp-compat-funcall 'w32-window-exists-p process-name process-name))
 236
 237      ;; GNU Emacs 23.
 238      ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
 239       (let (result)
 240         (dolist (pid (tramp-compat-funcall 'list-system-processes) result)
 241           (let ((attributes (process-attributes pid)))
 242             (when (and (string-equal
 243                         (cdr (assoc 'user attributes)) (user-login-name))
 244                        (let ((comm (cdr (assoc 'comm attributes))))
 245                          ;; The returned command name could be truncated
 246                          ;; to 15 characters.  Therefore, we cannot check
 247                          ;; for `string-equal'.
 248                          (and comm (string-match
 249                                     (concat "^" (regexp-quote comm))
 250                                     process-name))))
 251               (setq result t)))))))))
 252
 253 ;; `process-running-live-p' is introduced in Emacs 24.
 254 (defalias 'tramp-compat-process-live-p
 255   (if (fboundp 'process-running-live-p)
 256       'process-running-live-p
 257     (lambda (process)
 258       "Returns non-nil if PROCESS is alive.
 259 A process is considered alive if its status is `run', `open',
 260 `listen', `connect' or `stop'.  Value is nil if PROCESS is not a
 261 process."
 262       (and (processp process)
 263            (memq (process-status process)
 264                  '(run open listen connect stop))))))
 265
 266 ;; `user-error' has appeared in Emacs 24.3.
 267 (defsubst tramp-compat-user-error (vec-or-proc format &rest args)
 268   "Signal a pilot error."
 269   (apply
 270    'tramp-error vec-or-proc
 271    (if (fboundp 'user-error) 'user-error 'error) format args))
 272
 273 ;; `file-attribute-*' are introduced in Emacs 25.1.
 274
 275 (if (fboundp 'file-attribute-type)
 276     (defalias 'tramp-compat-file-attribute-type 'file-attribute-type)
 277   (defsubst tramp-compat-file-attribute-type (attributes)
 278     "The type field in ATTRIBUTES returned by `file-attributes'.
 279 The value is either t for directory, string (name linked to) for
 280 symbolic link, or nil."
 281     (nth 0 attributes)))
 282
 283 (if (fboundp 'file-attribute-link-number)
 284     (defalias 'tramp-compat-file-attribute-link-number
 285       'file-attribute-link-number)
 286   (defsubst tramp-compat-file-attribute-link-number (attributes)
 287     "Return the number of links in ATTRIBUTES returned by `file-attributes'."
 288     (nth 1 attributes)))
 289
 290 (if (fboundp 'file-attribute-user-id)
 291     (defalias 'tramp-compat-file-attribute-user-id 'file-attribute-user-id)
 292   (defsubst tramp-compat-file-attribute-user-id (attributes)
 293     "The UID field in ATTRIBUTES returned by `file-attributes'.
 294 This is either a string or a number.  If a string value cannot be
 295 looked up, a numeric value, either an integer or a float, is
 296 returned."
 297     (nth 2 attributes)))
 298
 299 (if (fboundp 'file-attribute-group-id)
 300     (defalias 'tramp-compat-file-attribute-group-id 'file-attribute-group-id)
 301   (defsubst tramp-compat-file-attribute-group-id (attributes)
 302     "The GID field in ATTRIBUTES returned by `file-attributes'.
 303 This is either a string or a number.  If a string value cannot be
 304 looked up, a numeric value, either an integer or a float, is
 305 returned."
 306     (nth 3 attributes)))
 307
 308 (if (fboundp 'file-attribute-modification-time)
 309     (defalias 'tramp-compat-file-attribute-modification-time
 310       'file-attribute-modification-time)
 311   (defsubst tramp-compat-file-attribute-modification-time (attributes)
 312     "The modification time in ATTRIBUTES returned by `file-attributes'.
 313 This is the time of the last change to the file's contents, and
 314 is a list of integers (HIGH LOW USEC PSEC) in the same style
 315 as (current-time)."
 316     (nth 5 attributes)))
 317
 318 (if (fboundp 'file-attribute-size)
 319     (defalias 'tramp-compat-file-attribute-size 'file-attribute-size)
 320   (defsubst tramp-compat-file-attribute-size (attributes)
 321     "The size (in bytes) in ATTRIBUTES returned by `file-attributes'.
 322 This is a floating point number if the size is too large for an integer."
 323     (nth 7 attributes)))
 324
 325 (if (fboundp 'file-attribute-modes)
 326     (defalias 'tramp-compat-file-attribute-modes 'file-attribute-modes)
 327   (defsubst tramp-compat-file-attribute-modes (attributes)
 328     "The file modes in ATTRIBUTES returned by `file-attributes'.
 329 This is a string of ten letters or dashes as in ls -l."
 330     (nth 8 attributes)))
 331
 332 ;; `default-toplevel-value' has been declared in Emacs 24.
 333 (unless (fboundp 'default-toplevel-value)
 334   (defalias 'default-toplevel-value 'symbol-value))
 335
 336 ;; `format-message' is new in Emacs 25.
 337 (unless (fboundp 'format-message)
 338   (defalias 'format-message 'format))
 339
 340 ;; `file-missing' is introduced in Emacs 26.
 341 (defconst tramp-file-missing
 342   (if (get 'file-missing 'error-conditions) 'file-missing 'file-error)
 343   "The error symbol for the `file-missing' error.")
 344
 345 (add-hook 'tramp-unload-hook
 346           (lambda ()
 347             (unload-feature 'tramp-loaddefs 'force)
 348             (unload-feature 'tramp-compat 'force)))
 349
 350 ;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' are
 351 ;; introduced in Emacs 26.
 352 (eval-and-compile
 353   (if (fboundp 'file-name-quoted-p)
 354       (defalias 'tramp-compat-file-name-quoted-p 'file-name-quoted-p)
 355     (defsubst tramp-compat-file-name-quoted-p (name)
 356       "Whether NAME is quoted with prefix \"/:\".
 357 If NAME is a remote file name, check the local part of NAME."
 358       (string-match "^/:" (or (file-remote-p name 'localname) name))))
 359
 360   (if (fboundp 'file-name-quote)
 361       (defalias 'tramp-compat-file-name-quote 'file-name-quote)
 362     (defsubst tramp-compat-file-name-quote (name)
 363       "Add the quotation prefix \"/:\" to file NAME.
 364 If NAME is a remote file name, the local part of NAME is quoted."
 365       (concat
 366        (file-remote-p name) "/:" (or (file-remote-p name 'localname) name))))
 367
 368   (if (fboundp 'file-name-unquote)
 369       (defalias 'tramp-compat-file-name-unquote 'file-name-unquote)
 370     (defsubst tramp-compat-file-name-unquote (name)
 371       "Remove quotation prefix \"/:\" from file NAME.
 372 If NAME is a remote file name, the local part of NAME is unquoted."
 373       (save-match-data
 374         (let ((localname (or (file-remote-p name 'localname) name)))
 375           (when (tramp-compat-file-name-quoted-p localname)
 376             (setq
 377              localname
 378              (replace-match
 379               (if (= (length localname) 2) "/" "") nil t localname)))
 380           (concat (file-remote-p name) localname))))))
 381
 382 (provide 'tramp-compat)
 383
 384 ;;; TODO:
 385
 386 ;;; tramp-compat.el ends here