code.delx.au - gnu-emacs/blob - lisp/net/tramp-compat.el

   1 ;;; tramp-compat.el --- Tramp compatibility functions
   2
   3 ;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
   4
   5 ;; Author: Michael Albinus <michael.albinus@gmx.de>
   6 ;; Keywords: comm, processes
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Commentary:
  24
  25 ;; Tramp's main Emacs version for development is GNU Emacs 24.  This
  26 ;; package provides compatibility functions for GNU Emacs 22, GNU
  27 ;; Emacs 23 and XEmacs 21.4+.
  28
  29 ;;; Code:
  30
  31 (eval-when-compile
  32
  33   ;; Pacify byte-compiler.
  34   (require 'cl))
  35
  36 (eval-and-compile
  37
  38   (require 'custom)
  39
  40   ;; Load the appropriate timer package.
  41   (if (featurep 'xemacs)
  42       (require 'timer-funcs)
  43     (require 'timer))
  44
  45   (autoload 'tramp-tramp-file-p "tramp")
  46   (autoload 'tramp-file-name-handler "tramp")
  47
  48   ;; We check whether `start-file-process' is bound.
  49   (unless (fboundp 'start-file-process)
  50
  51     ;; tramp-util offers integration into other (X)Emacs packages like
  52     ;; compile.el, gud.el etc.  Not necessary in Emacs 23.
  53     (eval-after-load "tramp"
  54       '(progn
  55          (require 'tramp-util)
  56          (add-hook 'tramp-unload-hook
  57                    '(lambda ()
  58                       (when (featurep 'tramp-util)
  59                         (unload-feature 'tramp-util 'force))))))
  60
  61     ;; Make sure that we get integration with the VC package.  When it
  62     ;; is loaded, we need to pull in the integration module.  Not
  63     ;; necessary in Emacs 23.
  64     (eval-after-load "vc"
  65       (eval-after-load "tramp"
  66         '(progn
  67            (require 'tramp-vc)
  68            (add-hook 'tramp-unload-hook
  69                      '(lambda ()
  70                         (when (featurep 'tramp-vc)
  71                           (unload-feature 'tramp-vc 'force))))))))
  72
  73   ;; Avoid byte-compiler warnings if the byte-compiler supports this.
  74   ;; Currently, XEmacs supports this.
  75   (when (featurep 'xemacs)
  76     (unless (boundp 'byte-compile-default-warnings)
  77       (defvar byte-compile-default-warnings nil))
  78     (delq 'unused-vars byte-compile-default-warnings))
  79
  80   ;; `last-coding-system-used' is unknown in XEmacs.
  81   (unless (boundp 'last-coding-system-used)
  82     (defvar last-coding-system-used nil))
  83
  84   ;; `directory-sep-char' is an obsolete variable in Emacs.  But it is
  85   ;; used in XEmacs, so we set it here and there.  The following is
  86   ;; needed to pacify Emacs byte-compiler.
  87   (unless (boundp 'byte-compile-not-obsolete-var)
  88     (defvar byte-compile-not-obsolete-var nil))
  89   (setq byte-compile-not-obsolete-var 'directory-sep-char)
  90   ;; Emacs 23.2.
  91   (unless (boundp 'byte-compile-not-obsolete-vars)
  92     (defvar byte-compile-not-obsolete-vars nil))
  93   (setq byte-compile-not-obsolete-vars '(directory-sep-char))
  94
  95   ;; `with-temp-message' does not exists in XEmacs.
  96   (condition-case nil
  97       (with-temp-message (current-message) nil)
  98     (error (defmacro with-temp-message (message &rest body) `(progn ,@body))))
  99
 100   ;; For not existing functions, or functions with a changed argument
 101   ;; list, there are compiler warnings.  We want to avoid them in
 102   ;; cases we know what we do.
 103   (defmacro tramp-compat-funcall (function &rest arguments)
 104     (if (featurep 'xemacs)
 105         `(funcall (symbol-function ,function) ,@arguments)
 106       `(when (or (subrp ,function) (functionp ,function))
 107          (with-no-warnings (funcall ,function ,@arguments)))))
 108
 109   ;; `set-buffer-multibyte' comes from Emacs Leim.
 110   (unless (fboundp 'set-buffer-multibyte)
 111     (defalias 'set-buffer-multibyte 'ignore))
 112
 113   ;; `font-lock-add-keywords' does not exist in XEmacs.
 114   (unless (fboundp 'font-lock-add-keywords)
 115     (defalias 'font-lock-add-keywords 'ignore))
 116
 117   ;; The following functions cannot be aliases of the corresponding
 118   ;; `tramp-handle-*' functions, because this would bypass the locking
 119   ;; mechanism.
 120
 121   ;; `file-remote-p' has been introduced with Emacs 22.  The version
 122   ;; of XEmacs is not a magic file name function (yet); this is
 123   ;; corrected in tramp-util.el.  Here it is sufficient if the
 124   ;; function exists.
 125   (unless (fboundp 'file-remote-p)
 126     (defalias 'file-remote-p
 127       (lambda (file &optional identification connected)
 128         (when (tramp-tramp-file-p file)
 129           (tramp-file-name-handler
 130            'file-remote-p file identification connected)))))
 131
 132   ;; `process-file' does not exist in XEmacs.
 133   (unless (fboundp 'process-file)
 134     (defalias 'process-file
 135       (lambda (program &optional infile buffer display &rest args)
 136         (when (tramp-tramp-file-p default-directory)
 137           (apply
 138            'tramp-file-name-handler
 139            'process-file program infile buffer display args)))))
 140
 141   ;; `start-file-process' is new in Emacs 23.
 142   (unless (fboundp 'start-file-process)
 143     (defalias 'start-file-process
 144       (lambda (name buffer program &rest program-args)
 145         (when (tramp-tramp-file-p default-directory)
 146           (apply
 147            'tramp-file-name-handler
 148            'start-file-process name buffer program program-args)))))
 149
 150   ;; `set-file-times' is also new in Emacs 23.
 151   (unless (fboundp 'set-file-times)
 152     (defalias 'set-file-times
 153       (lambda (filename &optional time)
 154         (when (tramp-tramp-file-p filename)
 155           (tramp-file-name-handler
 156            'set-file-times filename time)))))
 157
 158   ;; We currently use "[" and "]" in the filename format for IPv6
 159   ;; hosts of GNU Emacs.  This means, that Emacs wants to expand
 160   ;; wildcards if `find-file-wildcards' is non-nil, and then barfs
 161   ;; because no expansion could be found.  We detect this situation
 162   ;; and do something really awful: we have `file-expand-wildcards'
 163   ;; return the original filename if it can't expand anything.  Let's
 164   ;; just hope that this doesn't break anything else.
 165   ;; It is not needed anymore since GNU Emacs 23.2.
 166   (unless (or (featurep 'xemacs)
 167               ;; `featurep' has only one argument in XEmacs.
 168               (funcall 'featurep 'files 'remote-wildcards))
 169     (defadvice file-expand-wildcards
 170       (around tramp-advice-file-expand-wildcards activate)
 171       (let ((name (ad-get-arg 0)))
 172         ;; If it's a Tramp file, look if wildcards need to be expanded
 173         ;; at all.
 174         (if (and
 175              (tramp-tramp-file-p name)
 176              (not (string-match
 177                    "[[*?]" (tramp-compat-funcall
 178                             'file-remote-p name 'localname))))
 179             (setq ad-return-value (list name))
 180           ;; Otherwise, just run the original function.
 181           ad-do-it)))
 182     (add-hook
 183      'tramp-unload-hook
 184      (lambda ()
 185        (ad-remove-advice
 186         'file-expand-wildcards 'around 'tramp-advice-file-expand-wildcards)
 187        (ad-activate 'file-expand-wildcards)))))
 188
 189 (defsubst tramp-compat-line-beginning-position ()
 190   "Return point at beginning of line (compat function).
 191 Calls `line-beginning-position' or `point-at-bol' if defined, else
 192 own implementation."
 193   (cond
 194    ((fboundp 'line-beginning-position)
 195     (tramp-compat-funcall 'line-beginning-position))
 196    ((fboundp 'point-at-bol) (tramp-compat-funcall 'point-at-bol))
 197    (t (save-excursion (beginning-of-line) (point)))))
 198
 199 (defsubst tramp-compat-line-end-position ()
 200   "Return point at end of line (compat function).
 201 Calls `line-end-position' or `point-at-eol' if defined, else
 202 own implementation."
 203   (cond
 204    ((fboundp 'line-end-position) (tramp-compat-funcall 'line-end-position))
 205    ((fboundp 'point-at-eol) (tramp-compat-funcall 'point-at-eol))
 206    (t (save-excursion (end-of-line) (point)))))
 207
 208 (defsubst tramp-compat-temporary-file-directory ()
 209   "Return name of directory for temporary files (compat function).
 210 For Emacs, this is the variable `temporary-file-directory', for XEmacs
 211 this is the function `temp-directory'."
 212   (cond
 213    ((boundp 'temporary-file-directory) (symbol-value 'temporary-file-directory))
 214    ((fboundp 'temp-directory) (tramp-compat-funcall 'temp-directory))
 215    ((let ((d (getenv "TEMP"))) (and d (file-directory-p d)))
 216     (file-name-as-directory (getenv "TEMP")))
 217    ((let ((d (getenv "TMP"))) (and d (file-directory-p d)))
 218     (file-name-as-directory (getenv "TMP")))
 219    ((let ((d (getenv "TMPDIR"))) (and d (file-directory-p d)))
 220     (file-name-as-directory (getenv "TMPDIR")))
 221    ((file-exists-p "c:/temp") (file-name-as-directory "c:/temp"))
 222    (t (message (concat "Neither `temporary-file-directory' nor "
 223                        "`temp-directory' is defined -- using /tmp."))
 224       (file-name-as-directory "/tmp"))))
 225
 226 ;; `make-temp-file' exists in Emacs only.  On XEmacs, we use our own
 227 ;; implementation with `make-temp-name', creating the temporary file
 228 ;; immediately in order to avoid a security hole.
 229 (defsubst tramp-compat-make-temp-file (filename &optional dir-flag)
 230   "Create a temporary file (compat function).
 231 Add the extension of FILENAME, if existing."
 232   (let* (file-name-handler-alist
 233          (prefix (expand-file-name
 234                   (symbol-value 'tramp-temp-name-prefix)
 235                   (tramp-compat-temporary-file-directory)))
 236          (extension (file-name-extension filename t))
 237          result)
 238     (condition-case nil
 239         (setq result
 240               (tramp-compat-funcall 'make-temp-file prefix dir-flag extension))
 241       (error
 242        ;; We use our own implementation, taken from files.el.
 243        (while
 244            (condition-case ()
 245                (progn
 246                  (setq result (concat (make-temp-name prefix) extension))
 247                  (if dir-flag
 248                      (make-directory result)
 249                    (write-region "" nil result nil 'silent))
 250                  nil)
 251              (file-already-exists t))
 252          ;; The file was somehow created by someone else between
 253          ;; `make-temp-name' and `write-region', let's try again.
 254          nil)))
 255     result))
 256
 257 ;; `most-positive-fixnum' does not exist in XEmacs.
 258 (defsubst tramp-compat-most-positive-fixnum ()
 259   "Return largest positive integer value (compat function)."
 260   (cond
 261    ((boundp 'most-positive-fixnum) (symbol-value 'most-positive-fixnum))
 262    ;; Default value in XEmacs.
 263    (t 134217727)))
 264
 265 ;; ID-FORMAT does not exists in XEmacs.
 266 (defun tramp-compat-file-attributes (filename &optional id-format)
 267   "Like `file-attributes' for Tramp files (compat function)."
 268   (cond
 269    ((or (null id-format) (eq id-format 'integer))
 270     (file-attributes filename))
 271    ((tramp-tramp-file-p filename)
 272     (tramp-file-name-handler 'file-attributes filename id-format))
 273    (t (condition-case nil
 274           (tramp-compat-funcall 'file-attributes filename id-format)
 275         (wrong-number-of-arguments (file-attributes filename))))))
 276
 277 ;; PRESERVE-UID-GID has been introduced with Emacs 23.  It does not
 278 ;; hurt to ignore it for other (X)Emacs versions.
 279 ;; PRESERVE-SELINUX-CONTEXT has been introduced with Emacs 24.
 280 (defun tramp-compat-copy-file
 281   (filename newname &optional ok-if-already-exists keep-date
 282             preserve-uid-gid preserve-selinux-context)
 283   "Like `copy-file' for Tramp files (compat function)."
 284   (cond
 285    (preserve-selinux-context
 286     (tramp-compat-funcall
 287      'copy-file filename newname ok-if-already-exists keep-date
 288      preserve-uid-gid preserve-selinux-context))
 289    (preserve-uid-gid
 290     (tramp-compat-funcall
 291      'copy-file filename newname ok-if-already-exists keep-date
 292      preserve-uid-gid))
 293    (t
 294     (copy-file filename newname ok-if-already-exists keep-date))))
 295
 296 ;; `copy-directory' is a new function in Emacs 23.2.  Implementation
 297 ;; is taken from there.
 298 (defun tramp-compat-copy-directory
 299   (directory newname &optional keep-time parents)
 300   "Make a copy of DIRECTORY (compat function)."
 301   (if (fboundp 'copy-directory)
 302       (tramp-compat-funcall 'copy-directory directory newname keep-time parents)
 303
 304     ;; If `default-directory' is a remote directory, make sure we find
 305     ;; its `copy-directory' handler.
 306     (let ((handler (or (find-file-name-handler directory 'copy-directory)
 307                        (find-file-name-handler newname 'copy-directory))))
 308       (if handler
 309           (funcall handler 'copy-directory directory newname keep-time parents)
 310
 311         ;; Compute target name.
 312         (setq directory (directory-file-name (expand-file-name directory))
 313               newname   (directory-file-name (expand-file-name newname)))
 314         (if (and (file-directory-p newname)
 315                  (not (string-equal (file-name-nondirectory directory)
 316                                     (file-name-nondirectory newname))))
 317             (setq newname
 318                   (expand-file-name
 319                    (file-name-nondirectory directory) newname)))
 320         (if (not (file-directory-p newname)) (make-directory newname parents))
 321
 322         ;; Copy recursively.
 323         (mapc
 324          (lambda (file)
 325            (if (file-directory-p file)
 326                (tramp-compat-copy-directory file newname keep-time parents)
 327              (copy-file file newname t keep-time)))
 328          ;; We do not want to delete "." and "..".
 329          (directory-files
 330           directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*"))
 331
 332         ;; Set directory attributes.
 333         (set-file-modes newname (file-modes directory))
 334         (if keep-time
 335             (set-file-times newname (nth 5 (file-attributes directory))))))))
 336
 337 ;; TRASH has been introduced with Emacs 24.1.
 338 (defun tramp-compat-delete-file (filename &optional trash)
 339   "Like `delete-file' for Tramp files (compat function)."
 340   (condition-case nil
 341       (tramp-compat-funcall 'delete-file filename trash)
 342     ;; This Emacs version does not support the TRASH flag.
 343     (wrong-number-of-arguments
 344      (let ((delete-by-moving-to-trash
 345             (and (boundp 'delete-by-moving-to-trash)
 346                  (symbol-value 'delete-by-moving-to-trash)
 347                  trash)))
 348        (delete-file filename)))))
 349
 350 ;; RECURSIVE has been introduced with Emacs 23.2.
 351 (defun tramp-compat-delete-directory (directory &optional recursive)
 352   "Like `delete-directory' for Tramp files (compat function)."
 353   (if (null recursive)
 354       (delete-directory directory)
 355     (condition-case nil
 356         (tramp-compat-funcall 'delete-directory directory recursive)
 357       ;; This Emacs version does not support the RECURSIVE flag.  We
 358       ;; use the implementation from Emacs 23.2.
 359       (wrong-number-of-arguments
 360        (setq directory (directory-file-name (expand-file-name directory)))
 361        (if (not (file-symlink-p directory))
 362            (mapc (lambda (file)
 363                    (if (eq t (car (file-attributes file)))
 364                        (tramp-compat-delete-directory file recursive)
 365                      (delete-file file)))
 366                  (directory-files
 367                   directory 'full "^\\([^.]\\|\\.\\([^.]\\|\\..\\)\\).*")))
 368        (delete-directory directory)))))
 369
 370 ;; `number-sequence' does not exist in XEmacs.  Implementation is
 371 ;; taken from Emacs 23.
 372 (defun tramp-compat-number-sequence (from &optional to inc)
 373   "Return a sequence of numbers from FROM to TO as a list (compat function)."
 374   (if (or (subrp 'number-sequence) (symbol-file 'number-sequence))
 375       (tramp-compat-funcall 'number-sequence from to inc)
 376     (if (or (not to) (= from to))
 377         (list from)
 378       (or inc (setq inc 1))
 379       (when (zerop inc) (error "The increment can not be zero"))
 380       (let (seq (n 0) (next from))
 381         (if (> inc 0)
 382             (while (<= next to)
 383               (setq seq (cons next seq)
 384                     n (1+ n)
 385                     next (+ from (* n inc))))
 386           (while (>= next to)
 387             (setq seq (cons next seq)
 388                   n (1+ n)
 389                   next (+ from (* n inc)))))
 390         (nreverse seq)))))
 391
 392 (defun tramp-compat-split-string (string pattern)
 393   "Like `split-string' but omit empty strings.
 394 In Emacs, (split-string \"/foo/bar\" \"/\") returns (\"foo\" \"bar\").
 395 This is, the first, empty, element is omitted.  In XEmacs, the first
 396 element is not omitted."
 397   (delete "" (split-string string pattern)))
 398
 399 (defun tramp-compat-process-running-p (process-name)
 400   "Returns `t' if system process PROCESS-NAME is running for `user-login-name'."
 401   (when (stringp process-name)
 402     (cond
 403      ;; GNU Emacs 22 on w32.
 404      ((fboundp 'w32-window-exists-p)
 405       (tramp-compat-funcall 'w32-window-exists-p process-name process-name))
 406
 407      ;; GNU Emacs 23.
 408      ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
 409       (let (result)
 410         (dolist (pid (tramp-compat-funcall 'list-system-processes) result)
 411           (let ((attributes (tramp-compat-funcall 'process-attributes pid)))
 412             (when (and (string-equal
 413                         (cdr (assoc 'user attributes)) (user-login-name))
 414                        (let ((comm (cdr (assoc 'comm attributes))))
 415                          ;; The returned command name could be truncated
 416                          ;; to 15 characters.  Therefore, we cannot check
 417                          ;; for `string-equal'.
 418                          (and comm (string-match
 419                                     (concat "^" (regexp-quote comm))
 420                                     process-name))))
 421               (setq result t))))))
 422
 423      ;; Fallback, if there is no Lisp support yet.
 424      (t (let ((default-directory
 425                 (if (file-remote-p default-directory)
 426                     (tramp-compat-temporary-file-directory)
 427                   default-directory))
 428               (unix95 (getenv "UNIX95"))
 429               result)
 430           (setenv "UNIX95" "1")
 431           (when (member
 432                  (user-login-name)
 433                  (tramp-compat-split-string
 434                   (shell-command-to-string
 435                    (format "ps -C %s -o user=" process-name))
 436                   "[ \f\t\n\r\v]+"))
 437             (setq result t))
 438           (setenv "UNIX95" unix95)
 439           result)))))
 440
 441 ;; The following functions do not exist in XEmacs.  We ignore this;
 442 ;; they are used for checking a remote tty.
 443 (defun tramp-compat-process-get (process propname)
 444   "Return the value of PROCESS' PROPNAME property.
 445 This is the last value stored with `(process-put PROCESS PROPNAME VALUE)'."
 446   (ignore-errors (tramp-compat-funcall 'process-get process propname)))
 447
 448 (defun tramp-compat-process-put (process propname value)
 449   "Change PROCESS' PROPNAME property to VALUE.
 450 It can be retrieved with `(process-get PROCESS PROPNAME)'."
 451   (ignore-errors (tramp-compat-funcall 'process-put process propname value)))
 452
 453 (provide 'tramp-compat)
 454
 455 ;;; TODO:
 456
 457 ;; arch-tag: 0e724b18-6699-4f87-ad96-640b272e5c85
 458 ;;; tramp-compat.el ends here