lisp/net/tramp-compat.el

   1 ;;; tramp-compat.el --- Tramp compatibility functions
   2
   3 ;; Copyright (C) 2007-2016 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 25.  This
  27 ;; package provides compatibility functions for Emacs 23 and Emacs 24.
  28
  29 ;;; Code:
  30
  31 ;; Pacify byte-compiler.
  32 (eval-when-compile
  33   (require 'cl))
  34
  35 (require 'auth-source)
  36 (require 'advice)
  37 (require 'custom)
  38 (require 'format-spec)
  39 (require 'password-cache)
  40 (require 'shell)
  41 (require 'timer)
  42 (require 'ucs-normalize)
  43
  44 (require 'trampver)
  45 (require 'tramp-loaddefs)
  46
  47 ;; `remote-file-name-inhibit-cache' has been introduced with Emacs
  48 ;; 24.1.  Besides t, nil, and integer, we use also timestamps (as
  49 ;; returned by `current-time') internally.
  50 (unless (boundp 'remote-file-name-inhibit-cache)
  51   (defvar remote-file-name-inhibit-cache nil))
  52
  53 ;; For not existing functions, obsolete functions, or functions with a
  54 ;; changed argument list, there are compiler warnings.  We want to
  55 ;; avoid them in cases we know what we do.
  56 (defmacro tramp-compat-funcall (function &rest arguments)
  57   "Call FUNCTION if it exists.  Do not raise compiler warnings."
  58   `(when (or (subrp ,function) (functionp ,function))
  59      (with-no-warnings (funcall ,function ,@arguments))))
  60
  61 ;; We currently use "[" and "]" in the filename format for IPv6 hosts
  62 ;; of GNU Emacs.  This means that Emacs wants to expand wildcards if
  63 ;; `find-file-wildcards' is non-nil, and then barfs because no
  64 ;; expansion could be found.  We detect this situation and do
  65 ;; something really awful: we have `file-expand-wildcards' return the
  66 ;; original filename if it can't expand anything.  Let's just hope
  67 ;; that this doesn't break anything else.  It is not needed anymore
  68 ;; since GNU Emacs 23.2.
  69 (unless (featurep 'files 'remote-wildcards)
  70   (defadvice file-expand-wildcards
  71       (around tramp-advice-file-expand-wildcards activate)
  72     (let ((name (ad-get-arg 0)))
  73       ;; If it's a Tramp file, look if wildcards need to be expanded
  74       ;; at all.
  75       (if (and
  76            (tramp-tramp-file-p name)
  77            (not (string-match "[[*?]" (file-remote-p name 'localname))))
  78           (setq ad-return-value (list name))
  79         ;; Otherwise, just run the original function.
  80         ad-do-it)))
  81   (add-hook
  82    'tramp-unload-hook
  83    (lambda ()
  84      (ad-remove-advice
  85       'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards)
  86      (ad-activate 'file-expand-wildcards))))
  87
  88 ;; `condition-case-unless-debug' is introduced with Emacs 24.
  89 (if (fboundp 'condition-case-unless-debug)
  90     (defalias 'tramp-compat-condition-case-unless-debug
  91       'condition-case-unless-debug)
  92   (defmacro tramp-compat-condition-case-unless-debug
  93     (var bodyform &rest handlers)
  94   "Like `condition-case' except that it does not catch anything when debugging."
  95     (declare (debug condition-case) (indent 2))
  96     (let ((bodysym (make-symbol "body")))
  97       `(let ((,bodysym (lambda () ,bodyform)))
  98          (if debug-on-error
  99              (funcall ,bodysym)
 100            (condition-case ,var
 101                (funcall ,bodysym)
 102              ,@handlers))))))
 103
 104 (defsubst tramp-compat-temporary-file-directory ()
 105   "Return name of directory for temporary files.
 106 It is the default value of `temporary-file-directory'."
 107   ;; We must return a local directory.  If it is remote, we could run
 108   ;; into an infloop.
 109   (eval (car (get 'temporary-file-directory 'standard-value))))
 110
 111 (defsubst tramp-compat-make-temp-file (f &optional dir-flag)
 112   "Create a local temporary file (compat function).
 113 Add the extension of F, if existing."
 114   (let* (file-name-handler-alist
 115          (prefix (expand-file-name
 116                   (symbol-value 'tramp-temp-name-prefix)
 117                   (tramp-compat-temporary-file-directory)))
 118          (extension (file-name-extension f t)))
 119     (make-temp-file prefix dir-flag extension)))
 120
 121 ;; PRESERVE-EXTENDED-ATTRIBUTES has been introduced with Emacs 24.1
 122 ;; (as PRESERVE-SELINUX-CONTEXT), and renamed in Emacs 24.3.
 123 (defun tramp-compat-copy-file
 124   (filename newname &optional ok-if-already-exists keep-date
 125    preserve-uid-gid preserve-extended-attributes)
 126   "Like `copy-file' for Tramp files (compat function)."
 127   (cond
 128    (preserve-extended-attributes
 129     (condition-case nil
 130         (tramp-compat-funcall
 131          'copy-file filename newname ok-if-already-exists keep-date
 132          preserve-uid-gid preserve-extended-attributes)
 133       (wrong-number-of-arguments
 134        (copy-file
 135         filename newname ok-if-already-exists keep-date preserve-uid-gid))))
 136    (t
 137     (copy-file
 138      filename newname ok-if-already-exists keep-date preserve-uid-gid))))
 139
 140 ;; COPY-CONTENTS has been introduced with Emacs 24.1.
 141 (defun tramp-compat-copy-directory
 142   (directory newname &optional keep-time parents copy-contents)
 143   "Make a copy of DIRECTORY (compat function)."
 144   (condition-case nil
 145       (tramp-compat-funcall
 146        'copy-directory directory newname keep-time parents copy-contents)
 147
 148     ;; `copy-directory' is either not implemented, or it does not
 149     ;; support the the COPY-CONTENTS flag.  For the time being, we
 150     ;; ignore COPY-CONTENTS as well.
 151
 152     (error
 153      ;; If `default-directory' is a remote directory, make sure we
 154      ;; find its `copy-directory' handler.
 155      (let ((handler (or (find-file-name-handler directory 'copy-directory)
 156                         (find-file-name-handler newname 'copy-directory))))
 157        (if handler
 158            (funcall handler 'copy-directory directory newname keep-time parents)
 159
 160          ;; Compute target name.
 161          (setq directory (directory-file-name (expand-file-name directory))
 162                newname   (directory-file-name (expand-file-name newname)))
 163          (if (and (file-directory-p newname)
 164                   (not (string-equal (file-name-nondirectory directory)
 165                                      (file-name-nondirectory newname))))
 166              (setq newname
 167                    (expand-file-name
 168                     (file-name-nondirectory directory) newname)))
 169          (if (not (file-directory-p newname)) (make-directory newname parents))
 170
 171          ;; Copy recursively.
 172          (mapc
 173           (lambda (file)
 174             (if (file-directory-p file)
 175                 (tramp-compat-copy-directory file newname keep-time parents)
 176               (copy-file file newname t keep-time)))
 177           ;; We do not want to delete "." and "..".
 178           (directory-files directory 'full directory-files-no-dot-files-regexp))
 179
 180          ;; Set directory attributes.
 181          (set-file-modes newname (file-modes directory))
 182          (if keep-time
 183              (set-file-times newname (nth 5 (file-attributes directory)))))))))
 184
 185 ;; TRASH has been introduced with Emacs 24.1.
 186 (defun tramp-compat-delete-file (filename &optional trash)
 187   "Like `delete-file' for Tramp files (compat function)."
 188   (condition-case nil
 189       (tramp-compat-funcall 'delete-file filename trash)
 190     ;; This Emacs version does not support the TRASH flag.
 191     (wrong-number-of-arguments
 192      (let ((delete-by-moving-to-trash
 193             (and (boundp 'delete-by-moving-to-trash)
 194                  (symbol-value 'delete-by-moving-to-trash)
 195                  trash)))
 196        (delete-file filename)))))
 197
 198 ;; RECURSIVE has been introduced with Emacs 23.2.  TRASH has been
 199 ;; introduced with Emacs 24.1.
 200 (defun tramp-compat-delete-directory (directory &optional recursive trash)
 201   "Like `delete-directory' for Tramp files (compat function)."
 202   (condition-case nil
 203       (cond
 204        (trash
 205         (tramp-compat-funcall 'delete-directory directory recursive trash))
 206        (t
 207         (delete-directory directory recursive)))
 208     ;; This Emacs version does not support the TRASH flag.  We use the
 209     ;; implementation from Emacs 23.2.
 210     (wrong-number-of-arguments
 211      (setq directory (directory-file-name (expand-file-name directory)))
 212      (when (not (file-symlink-p directory))
 213        (mapc (lambda (file)
 214                (if (eq t (car (file-attributes file)))
 215                    (tramp-compat-delete-directory file recursive trash)
 216                  (tramp-compat-delete-file file trash)))
 217              (directory-files
 218               directory 'full directory-files-no-dot-files-regexp)))
 219      (delete-directory directory))))
 220
 221 (defun tramp-compat-process-running-p (process-name)
 222   "Returns t if system process PROCESS-NAME is running for `user-login-name'."
 223   (when (stringp process-name)
 224     (cond
 225      ;; GNU Emacs 22 on w32.
 226      ((fboundp 'w32-window-exists-p)
 227       (tramp-compat-funcall 'w32-window-exists-p process-name process-name))
 228
 229      ;; GNU Emacs 23.
 230      ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
 231       (let (result)
 232         (dolist (pid (tramp-compat-funcall 'list-system-processes) result)
 233           (let ((attributes (process-attributes pid)))
 234             (when (and (string-equal
 235                         (cdr (assoc 'user attributes)) (user-login-name))
 236                        (let ((comm (cdr (assoc 'comm attributes))))
 237                          ;; The returned command name could be truncated
 238                          ;; to 15 characters.  Therefore, we cannot check
 239                          ;; for `string-equal'.
 240                          (and comm (string-match
 241                                     (concat "^" (regexp-quote comm))
 242                                     process-name))))
 243               (setq result t)))))))))
 244
 245 ;; `default-toplevel-value' has been declared in Emacs 24.
 246 (unless (fboundp 'default-toplevel-value)
 247   (defalias 'default-toplevel-value 'symbol-value))
 248
 249 ;; `format-message' is new in Emacs 25.
 250 (unless (fboundp 'format-message)
 251   (defalias 'format-message 'format))
 252
 253 (add-hook 'tramp-unload-hook
 254           (lambda ()
 255             (unload-feature 'tramp-loaddefs 'force)
 256             (unload-feature 'tramp-compat 'force)))
 257
 258 (provide 'tramp-compat)
 259
 260 ;;; TODO:
 261
 262 ;;; tramp-compat.el ends here