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 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 23.  This
  26 ;; package provides compatibility functions for GNU Emacs 21, GNU
  27 ;; Emacs 22 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   ;; tramp-util offers integration into other (X)Emacs packages like
  49   ;; compile.el, gud.el etc.  Not necessary in Emacs 23.
  50   (eval-after-load "tramp"
  51     ;; We check whether `start-file-process' is an alias.
  52     '(when (or (not (fboundp 'start-file-process))
  53                (symbolp (symbol-function 'start-file-process)))
  54        (require 'tramp-util)
  55        (add-hook 'tramp-unload-hook
  56                  '(lambda ()
  57                     (when (featurep 'tramp-util)
  58                       (unload-feature 'tramp-util 'force))))))
  59
  60   ;; Make sure that we get integration with the VC package.  When it
  61   ;; is loaded, we need to pull in the integration module.  Not
  62   ;; necessary in Emacs 23.
  63   (eval-after-load "vc"
  64     (eval-after-load "tramp"
  65       ;; We check whether `start-file-process' is an alias.
  66       '(when (or (not (fboundp 'start-file-process))
  67                  (symbolp (symbol-function 'start-file-process)))
  68          (require 'tramp-vc)
  69          (add-hook 'tramp-unload-hook
  70                    '(lambda ()
  71                       (when (featurep 'tramp-vc)
  72                         (unload-feature 'tramp-vc 'force)))))))
  73
  74   ;; Avoid byte-compiler warnings if the byte-compiler supports this.
  75   ;; Currently, XEmacs supports this.
  76   (when (featurep 'xemacs)
  77     (unless (boundp 'byte-compile-default-warnings)
  78       (defvar byte-compile-default-warnings nil))
  79     (delq 'unused-vars byte-compile-default-warnings))
  80
  81   ;; `last-coding-system-used' is unknown in XEmacs.
  82   (unless (boundp 'last-coding-system-used)
  83     (defvar last-coding-system-used nil))
  84
  85   ;; `directory-sep-char' is an obsolete variable in Emacs.  But it is
  86   ;; used in XEmacs, so we set it here and there.  The following is
  87   ;; needed to pacify Emacs byte-compiler.
  88   (unless (boundp 'byte-compile-not-obsolete-var)
  89     (defvar byte-compile-not-obsolete-var nil))
  90   (setq byte-compile-not-obsolete-var 'directory-sep-char)
  91   (if (boundp 'byte-compile-not-obsolete-vars) ; Emacs 23.2
  92       (setq byte-compile-not-obsolete-vars '(directory-sep-char)))
  93
  94   ;; `with-temp-message' does not exists in XEmacs.
  95   (condition-case nil
  96       (with-temp-message (current-message) nil)
  97     (error (defmacro with-temp-message (message &rest body) `(progn ,@body))))
  98
  99   ;; `set-buffer-multibyte' comes from Emacs Leim.
 100   (unless (fboundp 'set-buffer-multibyte)
 101     (defalias 'set-buffer-multibyte 'ignore))
 102
 103   ;; `font-lock-add-keywords' does not exist in XEmacs.
 104   (unless (fboundp 'font-lock-add-keywords)
 105     (defalias 'font-lock-add-keywords 'ignore))
 106
 107   ;; The following functions cannot be aliases of the corresponding
 108   ;; `tramp-handle-*' functions, because this would bypass the locking
 109   ;; mechanism.
 110
 111   ;; `file-remote-p' has been introduced with Emacs 22.  The version
 112   ;; of XEmacs is not a magic file name function (yet); this is
 113   ;; corrected in tramp-util.el.  Here it is sufficient if the
 114   ;; function exists.
 115   (unless (fboundp 'file-remote-p)
 116     (defalias 'file-remote-p
 117       (lambda (file &optional identification connected)
 118         (when (tramp-tramp-file-p file)
 119           (tramp-file-name-handler
 120            'file-remote-p file identification connected)))))
 121
 122   ;; `process-file' exists since Emacs 22.
 123   (unless (fboundp 'process-file)
 124     (defalias 'process-file
 125       (lambda (program &optional infile buffer display &rest args)
 126         (when (tramp-tramp-file-p default-directory)
 127           (apply
 128            'tramp-file-name-handler
 129            'process-file program infile buffer display args)))))
 130
 131   ;; `start-file-process' is new in Emacs 23.
 132   (unless (fboundp 'start-file-process)
 133     (defalias 'start-file-process
 134       (lambda (name buffer program &rest program-args)
 135         (when (tramp-tramp-file-p default-directory)
 136           (apply
 137            'tramp-file-name-handler
 138            'start-file-process name buffer program program-args)))))
 139
 140   ;; `set-file-times' is also new in Emacs 23.
 141   (unless (fboundp 'set-file-times)
 142     (defalias 'set-file-times
 143       (lambda (filename &optional time)
 144         (when (tramp-tramp-file-p filename)
 145           (tramp-file-name-handler
 146            'set-file-times filename time))))))
 147
 148 (defsubst tramp-compat-line-beginning-position ()
 149   "Return point at beginning of line (compat function).
 150 Calls `line-beginning-position' or `point-at-bol' if defined, else
 151 own implementation."
 152   (cond
 153    ((fboundp 'line-beginning-position)
 154     (funcall (symbol-function 'line-beginning-position)))
 155    ((fboundp 'point-at-bol) (funcall (symbol-function 'point-at-bol)))
 156    (t (save-excursion (beginning-of-line) (point)))))
 157
 158 (defsubst tramp-compat-line-end-position ()
 159   "Return point at end of line (compat function).
 160 Calls `line-end-position' or `point-at-eol' if defined, else
 161 own implementation."
 162   (cond
 163    ((fboundp 'line-end-position) (funcall (symbol-function 'line-end-position)))
 164    ((fboundp 'point-at-eol)      (funcall (symbol-function 'point-at-eol)))
 165    (t (save-excursion (end-of-line) (point)))))
 166
 167 (defsubst tramp-compat-temporary-file-directory ()
 168   "Return name of directory for temporary files (compat function).
 169 For Emacs, this is the variable `temporary-file-directory', for XEmacs
 170 this is the function `temp-directory'."
 171   (cond
 172    ((boundp 'temporary-file-directory) (symbol-value 'temporary-file-directory))
 173    ((fboundp 'temp-directory) (funcall (symbol-function 'temp-directory)))
 174    ((let ((d (getenv "TEMP"))) (and d (file-directory-p d)))
 175     (file-name-as-directory (getenv "TEMP")))
 176    ((let ((d (getenv "TMP"))) (and d (file-directory-p d)))
 177     (file-name-as-directory (getenv "TMP")))
 178    ((let ((d (getenv "TMPDIR"))) (and d (file-directory-p d)))
 179     (file-name-as-directory (getenv "TMPDIR")))
 180    ((file-exists-p "c:/temp") (file-name-as-directory "c:/temp"))
 181    (t (message (concat "Neither `temporary-file-directory' nor "
 182                        "`temp-directory' is defined -- using /tmp."))
 183       (file-name-as-directory "/tmp"))))
 184
 185 ;; `make-temp-file' exists in Emacs only.  The third parameter SUFFIX
 186 ;; has been introduced with Emacs 22.  We try it, if it fails, we fall
 187 ;; back to `make-temp-name', creating the temporary file immediately
 188 ;; in order to avoid a security hole.
 189 (defsubst tramp-compat-make-temp-file (filename)
 190   "Create a temporary file (compat function).
 191 Add the extension of FILENAME, if existing."
 192   (let* (file-name-handler-alist
 193          (prefix (expand-file-name
 194                   (symbol-value 'tramp-temp-name-prefix)
 195                   (tramp-compat-temporary-file-directory)))
 196          (extension (file-name-extension filename t))
 197          result)
 198     (condition-case nil
 199         (setq result
 200               (funcall (symbol-function 'make-temp-file) prefix nil extension))
 201       (error
 202        ;; We use our own implementation, taken from files.el.
 203        (while
 204            (condition-case ()
 205                (progn
 206                  (setq result (concat (make-temp-name prefix) extension))
 207                  (write-region
 208                   "" nil result nil 'silent nil
 209                   ;; 7th parameter is MUSTBENEW in Emacs, and
 210                   ;; CODING-SYSTEM in XEmacs.  It is not a security
 211                   ;; hole in XEmacs if we cannot use this parameter,
 212                   ;; because XEmacs uses a user-specific subdirectory
 213                   ;; with 0700 permissions.
 214                   (when (not (featurep 'xemacs)) 'excl))
 215                  nil)
 216              (file-already-exists t))
 217          ;; The file was somehow created by someone else between
 218          ;; `make-temp-name' and `write-region', let's try again.
 219          nil)))
 220     result))
 221
 222 ;; `most-positive-fixnum' arrived in Emacs 22.  Before, and in XEmacs,
 223 ;; it is a fixed value.
 224 (defsubst tramp-compat-most-positive-fixnum ()
 225   "Return largest positive integer value (compat function)."
 226   (cond
 227    ((boundp 'most-positive-fixnum) (symbol-value 'most-positive-fixnum))
 228    ;; Default value in XEmacs and Emacs 21.
 229    (t 134217727)))
 230
 231 ;; ID-FORMAT exists since Emacs 22.
 232 (defun tramp-compat-file-attributes (filename &optional id-format)
 233   "Like `file-attributes' for Tramp files (compat function)."
 234   (cond
 235    ((or (null id-format) (eq id-format 'integer))
 236     (file-attributes filename))
 237    ((tramp-tramp-file-p filename)
 238     (tramp-file-name-handler 'file-attributes filename id-format))
 239    (t (condition-case nil
 240           (funcall (symbol-function 'file-attributes) filename id-format)
 241         (error (file-attributes filename))))))
 242
 243 ;; PRESERVE-UID-GID has been introduced with Emacs 23.  It does not
 244 ;; hurt to ignore it for other (X)Emacs versions.
 245 (defun tramp-compat-copy-file
 246   (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid)
 247   "Like `copy-file' for Tramp files (compat function)."
 248   (if preserve-uid-gid
 249       (funcall
 250        (symbol-function 'copy-file)
 251        filename newname ok-if-already-exists keep-date preserve-uid-gid)
 252     (copy-file filename newname ok-if-already-exists keep-date)))
 253
 254 ;; `copy-tree' is a built-in function in XEmacs.  In Emacs 21, it is
 255 ;; an autoloaded function in cl-extra.el.  Since Emacs 22, it is part
 256 ;; of subr.el.  There are problems when autoloading, therefore we test
 257 ;; for `subrp' and `symbol-file'.  Implementation is taken from Emacs 23.
 258 (defun tramp-compat-copy-tree (tree)
 259   "Make a copy of TREE (compat function)."
 260   (if (or (subrp 'copy-tree) (symbol-file 'copy-tree))
 261       (funcall (symbol-function 'copy-tree) tree)
 262     (let (result)
 263       (while (consp tree)
 264         (let ((newcar (car tree)))
 265           (if (consp (car tree))
 266               (setq newcar (tramp-compat-copy-tree (car tree))))
 267           (push newcar result))
 268         (setq tree (cdr tree)))
 269       (nconc (nreverse result) tree))))
 270
 271 ;; `number-sequence' has been introduced in Emacs 22.  Implementation
 272 ;; is taken from Emacs 23.
 273 (defun tramp-compat-number-sequence (from &optional to inc)
 274   "Return a sequence of numbers from FROM to TO as a list (compat function)."
 275   (if (or (subrp 'number-sequence) (symbol-file 'number-sequence))
 276       (funcall (symbol-function 'number-sequence) from to inc)
 277     (if (or (not to) (= from to))
 278         (list from)
 279       (or inc (setq inc 1))
 280       (when (zerop inc) (error "The increment can not be zero"))
 281       (let (seq (n 0) (next from))
 282         (if (> inc 0)
 283             (while (<= next to)
 284               (setq seq (cons next seq)
 285                     n (1+ n)
 286                     next (+ from (* n inc))))
 287           (while (>= next to)
 288             (setq seq (cons next seq)
 289                   n (1+ n)
 290                   next (+ from (* n inc)))))
 291         (nreverse seq)))))
 292
 293 (defun tramp-compat-split-string (string pattern)
 294   "Like `split-string' but omit empty strings.
 295 In Emacs, (split-string \"/foo/bar\" \"/\") returns (\"foo\" \"bar\").
 296 This is, the first, empty, element is omitted.  In XEmacs, the first
 297 element is not omitted."
 298   (delete "" (split-string string pattern)))
 299
 300 (defun tramp-compat-process-running-p (process-name)
 301   "Returns `t' if system process PROCESS-NAME is running for `user-login-name'."
 302   (when (stringp process-name)
 303     (cond
 304      ;; GNU Emacs 22 on w32.
 305      ((fboundp 'w32-window-exists-p)
 306       (funcall (symbol-function 'w32-window-exists-p)
 307                process-name process-name))
 308
 309      ;; GNU Emacs 23.
 310      ((and (fboundp 'list-system-processes) (fboundp 'process-attributes))
 311       (let (result)
 312         (dolist (pid (funcall (symbol-function 'list-system-processes)) result)
 313           (let ((attributes
 314                  (funcall (symbol-function 'process-attributes) pid)))
 315             (when
 316                 (and (string-equal
 317                       (cdr (assoc 'user attributes)) (user-login-name))
 318                      ;; The returned command name could be truncated
 319                      ;; to 15 characters.  Therefore, we cannot check
 320                      ;; for `string-equal'.
 321                      (string-match
 322                       (concat "^" (regexp-quote (cdr (assoc 'comm attributes))))
 323                       process-name))
 324               (setq result t))))))
 325
 326      ;; Fallback, if there is no Lisp support yet.
 327      (t (let ((default-directory
 328                 (if (file-remote-p default-directory)
 329                     (tramp-compat-temporary-file-directory)
 330                   default-directory))
 331               (unix95 (getenv "UNIX95"))
 332               result)
 333           (setenv "UNIX95" "1")
 334           (when (member
 335                  (user-login-name)
 336                  (tramp-compat-split-string
 337                   (shell-command-to-string
 338                    (format "ps -C %s -o user=" process-name))
 339                   "[ \f\t\n\r\v]+"))
 340             (setq result t))
 341           (setenv "UNIX95" unix95)
 342           result)))))
 343
 344 (provide 'tramp-compat)
 345
 346 ;;; TODO:
 347
 348 ;; arch-tag: 0e724b18-6699-4f87-ad96-640b272e5c85
 349 ;;; tramp-compat.el ends here