X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/bd78fa1d5442e6e023a16d407741ec899d57d3cd..d231e1987e31c9481489ee90db89b7b055ab3fb9:/lisp/net/tramp-cache.el diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 9c8ab4cb01..9397025cb6 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -1,7 +1,6 @@ ;;; tramp-cache.el --- file information caching for Tramp -;; Copyright (C) 2000, 2005, 2006, 2007, 2008, 2009, -;; 2010 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2005-2011 Free Software Foundation, Inc. ;; Author: Daniel Pittman ;; Michael Albinus @@ -34,7 +33,7 @@ ;; - localname is NIL. This are reusable properties. Examples: ;; "remote-shell" identifies the POSIX shell to be called on the ;; remote host, or "perl" is the command to be called on the remote -;; host, when starting a Perl script. These properties are saved in +;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; ;; - localname is a string. This are temporary properties, which are @@ -50,37 +49,20 @@ ;;; Code: -;; Pacify byte-compiler. -(eval-when-compile - (require 'cl) - (autoload 'tramp-message "tramp") - (autoload 'tramp-tramp-file-p "tramp") - ;; We cannot autoload macro `with-parsed-tramp-file-name', it - ;; results in problems of byte-compiled code. - (autoload 'tramp-dissect-file-name "tramp") - (autoload 'tramp-file-name-method "tramp") - (autoload 'tramp-file-name-user "tramp") - (autoload 'tramp-file-name-host "tramp") - (autoload 'tramp-file-name-localname "tramp") - (autoload 'tramp-run-real-handler "tramp") - (autoload 'tramp-time-less-p "tramp") - (autoload 'time-stamp-string "time-stamp")) +(require 'tramp) +(autoload 'time-stamp-string "time-stamp") ;;; -- Cache -- +;;;###tramp-autoload (defvar tramp-cache-data (make-hash-table :test 'equal) "Hash table for remote files properties.") -(defvar tramp-cache-inhibit-cache nil - "Inhibit cache read access, when `t'. -`nil' means to accept cache entries unconditionally. If the -value is a timestamp (as returned by `current-time'), cache -entries are not used when they have been written before this -time.") - (defcustom tramp-persistency-file-name (cond ;; GNU Emacs. + ((and (fboundp 'locate-user-emacs-file)) + (expand-file-name (tramp-compat-funcall 'locate-user-emacs-file "tramp"))) ((and (boundp 'user-emacs-directory) (stringp (symbol-value 'user-emacs-directory)) (file-directory-p (symbol-value 'user-emacs-directory))) @@ -103,6 +85,7 @@ time.") (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload (defun tramp-get-file-property (vec file property default) "Get the PROPERTY of FILE from the cache context of VEC. Returns DEFAULT if not set." @@ -115,21 +98,28 @@ Returns DEFAULT if not set." (value (when (hash-table-p hash) (gethash property hash)))) (if ;; We take the value only if there is any, and - ;; `tramp-cache-inhibit-cache' indicates that it is still + ;; `remote-file-name-inhibit-cache' indicates that it is still ;; valid. Otherwise, DEFAULT is set. (and (consp value) - (or (null tramp-cache-inhibit-cache) - (and (consp tramp-cache-inhibit-cache) + (or (null remote-file-name-inhibit-cache) + (and (integerp remote-file-name-inhibit-cache) + (<= + (tramp-time-diff (current-time) (car value)) + remote-file-name-inhibit-cache)) + (and (consp remote-file-name-inhibit-cache) (tramp-time-less-p - tramp-cache-inhibit-cache (car value))))) + remote-file-name-inhibit-cache (car value))))) (setq value (cdr value)) (setq value default)) - (if (consp tramp-cache-inhibit-cache) - (tramp-message vec 1 "%s %s %s" file property value)) (tramp-message vec 8 "%s %s %s" file property value) + (when (>= tramp-verbose 10) + (let* ((var (intern (concat "tramp-cache-get-count-" property))) + (val (or (ignore-errors (symbol-value var)) 0))) + (set var (1+ val)))) value)) +;;;###tramp-autoload (defun tramp-set-file-property (vec file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of VEC. Returns VALUE." @@ -142,8 +132,34 @@ Returns VALUE." ;; We put the timestamp there. (puthash property (cons (current-time) value) hash) (tramp-message vec 8 "%s %s %s" file property value) + (when (>= tramp-verbose 10) + (let* ((var (intern (concat "tramp-cache-set-count-" property))) + (val (or (ignore-errors (symbol-value var)) 0))) + (set var (1+ val)))) value)) +;;;###tramp-autoload +(defmacro with-file-property (vec file property &rest body) + "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. +FILE must be a local file name on a connection identified via VEC." + `(if (file-name-absolute-p ,file) + (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) + (when (eq value 'undef) + ;; We cannot pass @body as parameter to + ;; `tramp-set-file-property' because it mangles our + ;; debug messages. + (setq value (progn ,@body)) + (tramp-set-file-property ,vec ,file ,property value)) + value) + ,@body)) + +;;;###tramp-autoload +(put 'with-file-property 'lisp-indent-function 3) +(put 'with-file-property 'edebug-form-spec t) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\")) + +;;;###tramp-autoload (defun tramp-flush-file-property (vec file) "Remove all properties of FILE in the cache context of VEC." ;; Unify localname. @@ -152,6 +168,7 @@ Returns VALUE." (tramp-message vec 8 "%s" file) (remhash vec tramp-cache-data)) +;;;###tramp-autoload (defun tramp-flush-directory-property (vec directory) "Remove all properties of DIRECTORY in the cache context of VEC. Remove also properties of all files in subdirectories." @@ -159,10 +176,10 @@ Remove also properties of all files in subdirectories." 'directory-file-name (list directory)))) (tramp-message vec 8 "%s" directory) (maphash - '(lambda (key value) - (when (and (stringp (tramp-file-name-localname key)) - (string-match directory (tramp-file-name-localname key))) - (remhash key tramp-cache-data))) + (lambda (key value) + (when (and (stringp (tramp-file-name-localname key)) + (string-match directory (tramp-file-name-localname key))) + (remhash key tramp-cache-data))) tramp-cache-data))) ;; Reverting or killing a buffer should also flush file properties. @@ -175,24 +192,24 @@ Remove also properties of all files in subdirectories." (buffer-file-name) default-directory))) (when (tramp-tramp-file-p bfn) - (let* ((v (tramp-dissect-file-name bfn)) - (localname (tramp-file-name-localname v))) + (with-parsed-tramp-file-name bfn nil (tramp-flush-file-property v localname))))) (add-hook 'before-revert-hook 'tramp-flush-file-function) (add-hook 'eshell-pre-command-hook 'tramp-flush-file-function) (add-hook 'kill-buffer-hook 'tramp-flush-file-function) (add-hook 'tramp-cache-unload-hook - '(lambda () - (remove-hook 'before-revert-hook - 'tramp-flush-file-function) - (remove-hook 'eshell-pre-command-hook - 'tramp-flush-file-function) - (remove-hook 'kill-buffer-hook - 'tramp-flush-file-function))) + (lambda () + (remove-hook 'before-revert-hook + 'tramp-flush-file-function) + (remove-hook 'eshell-pre-command-hook + 'tramp-flush-file-function) + (remove-hook 'kill-buffer-hook + 'tramp-flush-file-function))) ;;; -- Properties -- +;;;###tramp-autoload (defun tramp-get-connection-property (key property default) "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a vector. @@ -209,6 +226,7 @@ If the value is not set for the connection, returns DEFAULT." (tramp-message key 7 "%s %s" property value) value)) +;;;###tramp-autoload (defun tramp-set-connection-property (key property value) "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a vector. @@ -223,14 +241,28 @@ PROPERTY is set persistent when KEY is a vector." tramp-cache-data)))) (puthash property value hash) (setq tramp-cache-data-changed t) - ;; This function is called also during initialization of - ;; tramp-cache.el. `tramp-message´ is not defined yet at this - ;; time, so we ignore the corresponding error. - (condition-case nil - (tramp-message key 7 "%s %s" property value) - (error nil)) + (tramp-message key 7 "%s %s" property value) + value)) + +;;;###tramp-autoload +(defmacro with-connection-property (key property &rest body) + "Check in Tramp for property PROPERTY, otherwise executes BODY and set." + `(let ((value (tramp-get-connection-property ,key ,property 'undef))) + (when (eq value 'undef) + ;; We cannot pass ,@body as parameter to + ;; `tramp-set-connection-property' because it mangles our debug + ;; messages. + (setq value (progn ,@body)) + (tramp-set-connection-property ,key ,property value)) value)) +;;;###tramp-autoload +(put 'with-connection-property 'lisp-indent-function 2) +(put 'with-connection-property 'edebug-form-spec t) +(tramp-compat-font-lock-add-keywords + 'emacs-lisp-mode '("\\")) + +;;;###tramp-autoload (defun tramp-flush-connection-property (key) "Remove all properties identified by KEY. KEY identifies the connection, it is either a process or a vector." @@ -251,100 +283,107 @@ KEY identifies the connection, it is either a process or a vector." (setq tramp-cache-data-changed t) (remhash key tramp-cache-data)) +;;;###tramp-autoload (defun tramp-cache-print (table) "Print hash table TABLE." (when (hash-table-p table) (let (result) (maphash - '(lambda (key value) - (let ((tmp (format - "(%s %s)" - (if (processp key) - (prin1-to-string (prin1-to-string key)) - (prin1-to-string key)) - (if (hash-table-p value) - (tramp-cache-print value) - (if (bufferp value) - (prin1-to-string (prin1-to-string value)) - (prin1-to-string value)))))) - (setq result (if result (concat result " " tmp) tmp)))) + (lambda (key value) + (let ((tmp (format + "(%s %s)" + (if (processp key) + (prin1-to-string (prin1-to-string key)) + (prin1-to-string key)) + (if (hash-table-p value) + (tramp-cache-print value) + (if (bufferp value) + (prin1-to-string (prin1-to-string value)) + (prin1-to-string value)))))) + (setq result (if result (concat result " " tmp) tmp)))) table) result))) +;;;###tramp-autoload (defun tramp-list-connections () "Return a list of all known connection vectors according to `tramp-cache'." (let (result) (maphash - '(lambda (key value) - (when (and (vectorp key) (null (aref key 3))) - (add-to-list 'result key))) + (lambda (key value) + (when (and (vectorp key) (null (aref key 3))) + (add-to-list 'result key))) tramp-cache-data) result)) (defun tramp-dump-connection-properties () "Write persistent connection properties into file `tramp-persistency-file-name'." ;; We shouldn't fail, otherwise (X)Emacs might not be able to be closed. - (condition-case nil - (when (and (hash-table-p tramp-cache-data) - (not (zerop (hash-table-count tramp-cache-data))) - tramp-cache-data-changed - (stringp tramp-persistency-file-name)) - (let ((cache (copy-hash-table tramp-cache-data))) - ;; Remove temporary data. - (maphash - '(lambda (key value) - (if (and (vectorp key) (not (tramp-file-name-localname key))) - (progn - (remhash "process-name" value) - (remhash "process-buffer" value) - (remhash "first-password-request" value)) - (remhash key cache))) - cache) - ;; Dump it. - (with-temp-buffer - (insert - ";; -*- emacs-lisp -*-" - ;; `time-stamp-string' might not exist in all (X)Emacs flavors. - (condition-case nil - (progn - (format - " <%s %s>\n" - (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") - tramp-persistency-file-name)) - (error "\n")) - ";; Tramp connection history. Don't change this file.\n" - ";; You can delete it, forcing Tramp to reapply the checks.\n\n" - (with-output-to-string - (pp (read (format "(%s)" (tramp-cache-print cache)))))) - (write-region - (point-min) (point-max) tramp-persistency-file-name)))) - (error nil))) - -(add-hook 'kill-emacs-hook 'tramp-dump-connection-properties) + (ignore-errors + (when (and (hash-table-p tramp-cache-data) + (not (zerop (hash-table-count tramp-cache-data))) + tramp-cache-data-changed + (stringp tramp-persistency-file-name)) + (let ((cache (copy-hash-table tramp-cache-data))) + ;; Remove temporary data. + (maphash + (lambda (key value) + (if (and (vectorp key) (not (tramp-file-name-localname key))) + (progn + (remhash "process-name" value) + (remhash "process-buffer" value) + (remhash "first-password-request" value)) + (remhash key cache))) + cache) + ;; Dump it. + (with-temp-buffer + (insert + ";; -*- emacs-lisp -*-" + ;; `time-stamp-string' might not exist in all (X)Emacs flavors. + (condition-case nil + (progn + (format + " <%s %s>\n" + (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") + tramp-persistency-file-name)) + (error "\n")) + ";; Tramp connection history. Don't change this file.\n" + ";; You can delete it, forcing Tramp to reapply the checks.\n\n" + (with-output-to-string + (pp (read (format "(%s)" (tramp-cache-print cache)))))) + (write-region + (point-min) (point-max) tramp-persistency-file-name)))))) + +(unless noninteractive + (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties)) (add-hook 'tramp-cache-unload-hook - '(lambda () - (remove-hook 'kill-emacs-hook - 'tramp-dump-connection-properties))) + (lambda () + (remove-hook 'kill-emacs-hook + 'tramp-dump-connection-properties))) +;;;###tramp-autoload (defun tramp-parse-connection-properties (method) "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from connection history." (let (res) (maphash - '(lambda (key value) - (if (and (vectorp key) - (string-equal method (tramp-file-name-method key)) - (not (tramp-file-name-localname key))) - (push (list (tramp-file-name-user key) - (tramp-file-name-host key)) - res))) + (lambda (key value) + (if (and (vectorp key) + (string-equal method (tramp-file-name-method key)) + (not (tramp-file-name-localname key))) + (push (list (tramp-file-name-user key) + (tramp-file-name-host key)) + res))) tramp-cache-data) res)) ;; Read persistent connection history. (when (and (stringp tramp-persistency-file-name) - (zerop (hash-table-count tramp-cache-data))) + (zerop (hash-table-count tramp-cache-data)) + ;; When "emacs -Q" has been called, both variables are nil. + ;; We do not load the persistency file then, in order to + ;; have a clean test environment. + (or init-file-user site-run-file)) (condition-case err (with-temp-buffer (insert-file-contents tramp-persistency-file-name) @@ -364,7 +403,10 @@ for all methods. Resulting data are derived from connection history." tramp-persistency-file-name (error-message-string err)) (clrhash tramp-cache-data)))) +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-cache 'force))) + (provide 'tramp-cache) -;; arch-tag: ee1739b7-7628-408c-9b96-d11a74b05d26 ;;; tramp-cache.el ends here