X-Git-Url: https://git.hcoop.net/bpt/emacs.git/blobdiff_plain/4787a496a05fdc03241850b45911dd283d4b06b8..4bc3c53d1d9d5b0533c2bbe06693660c8abf1f4a:/lisp/net/tramp-cache.el diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 2a1d840f21..7885d143cc 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -1,10 +1,12 @@ ;;; tramp-cache.el --- file information caching for Tramp -;; Copyright (C) 2000, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2000, 2005, 2006, 2007, 2008, 2009, +;; 2010 Free Software Foundation, Inc. ;; Author: Daniel Pittman ;; Michael Albinus ;; Keywords: comm, processes +;; Package: tramp ;; This file is part of GNU Emacs. @@ -48,22 +50,12 @@ ;;; 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 '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.") @@ -89,6 +81,10 @@ :group 'tramp :type 'file) +(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." @@ -98,12 +94,31 @@ Returns DEFAULT if not set." (let* ((hash (or (gethash vec tramp-cache-data) (puthash vec (make-hash-table :test 'equal) tramp-cache-data))) - (value (if (hash-table-p hash) - (gethash property hash default) - default))) + (value (when (hash-table-p hash) (gethash property hash)))) + (if + ;; We take the value only if there is any, and + ;; `remote-file-name-inhibit-cache' indicates that it is still + ;; valid. Otherwise, DEFAULT is set. + (and (consp value) + (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 + remote-file-name-inhibit-cache (car value))))) + (setq value (cdr value)) + (setq value default)) + (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." @@ -113,10 +128,37 @@ Returns VALUE." (let ((hash (or (gethash vec tramp-cache-data) (puthash vec (make-hash-table :test 'equal) tramp-cache-data)))) - (puthash property value hash) + ;; 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. @@ -125,6 +167,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." @@ -133,7 +176,7 @@ Remove also properties of all files in subdirectories." (tramp-message vec 8 "%s" directory) (maphash '(lambda (key value) - (when (and (stringp key) + (when (and (stringp (tramp-file-name-localname key)) (string-match directory (tramp-file-name-localname key))) (remhash key tramp-cache-data))) tramp-cache-data))) @@ -143,13 +186,12 @@ Remove also properties of all files in subdirectories." ;; not show proper directory contents when a file has been copied or ;; deleted before. (defun tramp-flush-file-function () - "Flush all Tramp cache properties from buffer-file-name." + "Flush all Tramp cache properties from `buffer-file-name'." (let ((bfn (if (stringp (buffer-file-name)) (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) @@ -166,6 +208,7 @@ Remove also properties of all files in subdirectories." ;;; -- 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. @@ -177,11 +220,12 @@ If the value is not set for the connection, returns DEFAULT." (aset key 3 nil)) (let* ((hash (gethash key tramp-cache-data)) (value (if (hash-table-p hash) - (gethash property hash default) - default))) + (gethash property hash default) + 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. @@ -195,14 +239,29 @@ PROPERTY is set persistent when KEY is a vector." (puthash key (make-hash-table :test 'equal) tramp-cache-data)))) (puthash property value hash) - ;; 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)) + (setq tramp-cache-data-changed t) + (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." @@ -211,8 +270,19 @@ KEY identifies the connection, it is either a process or a vector." (when (vectorp key) (setq key (copy-sequence key)) (aset key 3 nil)) + (tramp-message + key 7 "%s %s" key + (let ((hash (gethash key tramp-cache-data)) + properties) + (if (hash-table-p hash) + (maphash + (lambda (x y) (add-to-list 'properties x 'append)) + (gethash key tramp-cache-data))) + properties)) + (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) @@ -233,6 +303,7 @@ KEY identifies the connection, it is either a process or a vector." table) result))) +;;;###tramp-autoload (defun tramp-list-connections () "Return a list of all known connection vectors according to `tramp-cache'." (let (result) @@ -246,39 +317,40 @@ KEY identifies the connection, it is either a process or a vector." (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))) - (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 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))) + (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)))))) (add-hook 'kill-emacs-hook 'tramp-dump-connection-properties) (add-hook 'tramp-cache-unload-hook @@ -286,11 +358,11 @@ KEY identifies the connection, it is either a process or a vector." (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." +for all methods. Resulting data are derived from connection history." (let (res) (maphash '(lambda (key value) @@ -314,7 +386,8 @@ history." (while (setq element (pop list)) (setq key (pop element)) (while (setq item (pop element)) - (tramp-set-connection-property key (pop item) (car item)))))) + (tramp-set-connection-property key (pop item) (car item))))) + (setq tramp-cache-data-changed nil)) (file-error ;; Most likely because the file doesn't exist yet. No message. (clrhash tramp-cache-data)) @@ -324,6 +397,10 @@ 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