# HG changeset patch # User Michael Albinus # Date 1272706454 -7200 # Node ID 3287df4f34420b4496d6f96949904c5c4891ebc7 # Parent 804e9ced8374f9488d8286727c90de519b207be1 Implement compression for inline methods. * net/tramp.el (tramp-inline-compress-start-size): New defcustom. (tramp-copy-size-limit): Allow also nil. (tramp-inline-compress-commands): New defconst. (tramp-find-inline-compress, tramp-get-inline-compress) (tramp-get-inline-coding): New defuns. (tramp-get-remote-coding, tramp-get-local-coding): Removed, replaced by `tramp-get-inline-coding'. (tramp-handle-file-local-copy, tramp-handle-write-region) (tramp-method-out-of-band-p): Use `tramp-get-inline-coding'. diff -r 804e9ced8374 -r 3287df4f3442 lisp/ChangeLog --- a/lisp/ChangeLog Fri Apr 30 20:04:51 2010 -0700 +++ b/lisp/ChangeLog Sat May 01 11:34:14 2010 +0200 @@ -1,3 +1,18 @@ +2010-05-01 Toru TSUNEYOSHI + Michael Albinus + + Implement compression for inline methods. + + * net/tramp.el (tramp-inline-compress-start-size): New defcustom. + (tramp-copy-size-limit): Allow also nil. + (tramp-inline-compress-commands): New defconst. + (tramp-find-inline-compress, tramp-get-inline-compress) + (tramp-get-inline-coding): New defuns. + (tramp-get-remote-coding, tramp-get-local-coding): Removed, + replaced by `tramp-get-inline-coding'. + (tramp-handle-file-local-copy, tramp-handle-write-region) + (tramp-method-out-of-band-p): Use `tramp-get-inline-coding'. + 2010-05-01 Chong Yidong * server.el (server-sentinel, server-start, server-force-delete): diff -r 804e9ced8374 -r 3287df4f3442 lisp/net/tramp.el --- a/lisp/net/tramp.el Fri Apr 30 20:04:51 2010 -0700 +++ b/lisp/net/tramp.el Sat May 01 11:34:14 2010 +0200 @@ -285,10 +285,19 @@ :group 'tramp :type 'string) +(defcustom tramp-inline-compress-start-size 4096 + "*The minimum size of compressing where inline transfer. +When inline transfer, compress transfered data of file +whose size is this value or above (up to `tramp-copy-size-limit'). +If it is nil, no compression at all will be applied." + :group 'tramp + :type '(choice (const nil) integer)) + (defcustom tramp-copy-size-limit 10240 - "*The maximum file size where inline copying is preferred over an out-of-the-band copy." + "*The maximum file size where inline copying is preferred over an out-of-the-band copy. +If it is nil, inline out-of-the-band copy will be used without a check." :group 'tramp - :type 'integer) + :type '(choice (const nil) integer)) (defcustom tramp-terminal-type "dumb" "*Value of TERM environment variable for logging in to remote host. @@ -4722,16 +4731,16 @@ v 'file-error "Cannot make local copy of non-existing file `%s'" filename)) - (let ((rem-enc (tramp-get-remote-coding v "remote-encoding")) - (loc-dec (tramp-get-local-coding v "local-decoding")) - (tmpfile (tramp-compat-make-temp-file filename))) + (let* ((size (nth 7 (file-attributes filename))) + (rem-enc (tramp-get-inline-coding v "remote-encoding" size)) + (loc-dec (tramp-get-inline-coding v "local-decoding" size)) + (tmpfile (tramp-compat-make-temp-file filename))) (condition-case err (cond ;; `copy-file' handles direct copy and out-of-band methods. ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p - v (nth 7 (file-attributes filename)))) + (tramp-method-out-of-band-p v size)) (copy-file filename tmpfile t t)) ;; Use inline encoding for file transfer. @@ -4739,12 +4748,11 @@ (save-excursion (tramp-message v 5 "Encoding remote file %s..." filename) (tramp-barf-unless-okay - v - (format "%s < %s" rem-enc (tramp-shell-quote-argument localname)) + v (format rem-enc (tramp-shell-quote-argument localname)) "Encoding remote file failed") (tramp-message v 5 "Encoding remote file %s...done" filename) - (if (and (symbolp loc-dec) (fboundp loc-dec)) + (if (functionp loc-dec) ;; If local decoding is a function, we call it. We ;; must disable multibyte, because ;; `uudecode-decode-region' doesn't handle it @@ -5093,12 +5101,10 @@ 'write-region (list start end localname append 'no-message lockname confirm)) - (let ((rem-dec (tramp-get-remote-coding v "remote-decoding")) - (loc-enc (tramp-get-local-coding v "local-encoding")) - (modes (save-excursion (tramp-default-file-modes filename))) + (let ((modes (save-excursion (tramp-default-file-modes filename))) ;; We use this to save the value of - ;; `last-coding-system-used' after writing the tmp file. - ;; At the end of the function, we set + ;; `last-coding-system-used' after writing the tmp + ;; file. At the end of the function, we set ;; `last-coding-system-used' to this saved value. This ;; way, any intermediary coding systems used while ;; talking to the remote shell or suchlike won't hose @@ -5121,7 +5127,8 @@ ;; file. We call `set-visited-file-modtime' ourselves later ;; on. We must ensure that `file-coding-system-alist' ;; matches `tmpfile'. - (let ((file-coding-system-alist + (let (file-name-handler-alist + (file-coding-system-alist (tramp-find-file-name-coding-system-alist filename tmpfile))) (condition-case err (tramp-run-real-handler @@ -5153,124 +5160,125 @@ ;; specified. However, if the method _also_ specifies an ;; encoding function, then that is used for encoding the ;; contents of the tmp file. - (cond - ;; `copy-file' handles direct copy and out-of-band methods. - ((or (tramp-local-host-p v) - (tramp-method-out-of-band-p - v (nth 7 (file-attributes tmpfile)))) - (if (and (not (stringp start)) - (= (or end (point-max)) (point-max)) - (= (or start (point-min)) (point-min)) - (tramp-get-method-parameter - method 'tramp-copy-keep-tmpfile)) - (progn - (setq tramp-temp-buffer-file-name tmpfile) - (condition-case err - ;; We keep the local file for performance - ;; reasons, useful for "rsync". - (copy-file tmpfile filename t) - ((error quit) - (setq tramp-temp-buffer-file-name nil) - (delete-file tmpfile) - (signal (car err) (cdr err))))) - (setq tramp-temp-buffer-file-name nil) - ;; Don't rename, in order to keep context in SELinux. + (let* ((size (nth 7 (file-attributes tmpfile))) + (rem-dec (tramp-get-inline-coding v "remote-decoding" size)) + (loc-enc (tramp-get-inline-coding v "local-encoding" size))) + (cond + ;; `copy-file' handles direct copy and out-of-band methods. + ((or (tramp-local-host-p v) + (tramp-method-out-of-band-p v size)) + (if (and (not (stringp start)) + (= (or end (point-max)) (point-max)) + (= (or start (point-min)) (point-min)) + (tramp-get-method-parameter + method 'tramp-copy-keep-tmpfile)) + (progn + (setq tramp-temp-buffer-file-name tmpfile) + (condition-case err + ;; We keep the local file for performance + ;; reasons, useful for "rsync". + (copy-file tmpfile filename t) + ((error quit) + (setq tramp-temp-buffer-file-name nil) + (delete-file tmpfile) + (signal (car err) (cdr err))))) + (setq tramp-temp-buffer-file-name nil) + ;; Don't rename, in order to keep context in SELinux. + (unwind-protect + (copy-file tmpfile filename t) + (delete-file tmpfile)))) + + ;; Use inline file transfer. + (rem-dec + ;; Encode tmpfile. + (tramp-message v 5 "Encoding region...") (unwind-protect - (copy-file tmpfile filename t) - (delete-file tmpfile)))) - - ;; Use inline file transfer. - (rem-dec - ;; Encode tmpfile. - (tramp-message v 5 "Encoding region...") - (unwind-protect - (with-temp-buffer - ;; Use encoding function or command. - (if (and (symbolp loc-enc) (fboundp loc-enc)) - (progn - (tramp-message - v 5 "Encoding region using function `%s'..." - (symbol-name loc-enc)) - (let ((coding-system-for-read 'binary)) - (insert-file-contents-literally tmpfile)) - ;; The following `let' is a workaround for the - ;; base64.el that comes with pgnus-0.84. If - ;; both of the following conditions are - ;; satisfied, it tries to write to a local - ;; file in default-directory, but at this - ;; point, default-directory is remote. - ;; (`call-process-region' can't write to - ;; remote files, it seems.) The file in - ;; question is a tmp file anyway. - (let ((default-directory - (tramp-compat-temporary-file-directory))) - (funcall loc-enc (point-min) (point-max)))) - - (tramp-message - v 5 "Encoding region using command `%s'..." loc-enc) - (unless (equal 0 (tramp-call-local-coding-command + (with-temp-buffer + (set-buffer-multibyte nil) + ;; Use encoding function or command. + (if (functionp loc-enc) + (progn + (tramp-message + v 5 "Encoding region using function `%s'..." loc-enc) + (let ((coding-system-for-read 'binary)) + (insert-file-contents-literally tmpfile)) + ;; The following `let' is a workaround for the + ;; base64.el that comes with pgnus-0.84. If + ;; both of the following conditions are + ;; satisfied, it tries to write to a local + ;; file in default-directory, but at this + ;; point, default-directory is remote. + ;; (`call-process-region' can't write to + ;; remote files, it seems.) The file in + ;; question is a tmp file anyway. + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (funcall loc-enc (point-min) (point-max)))) + + (tramp-message + v 5 "Encoding region using command `%s'..." loc-enc) + (unless (zerop (tramp-call-local-coding-command loc-enc tmpfile t)) - (tramp-error - v 'file-error - "Cannot write to `%s', local encoding command `%s' failed" - filename loc-enc))) - - ;; Send buffer into remote decoding command which - ;; writes to remote file. Because this happens on - ;; the remote host, we cannot use the function. - (goto-char (point-max)) - (unless (bolp) (newline)) - (tramp-message - v 5 "Decoding region into remote file %s..." filename) - (tramp-send-command - v - (format - "%s >%s <<'EOF'\n%sEOF" - rem-dec - (tramp-shell-quote-argument localname) - (buffer-string))) - (tramp-barf-unless-okay - v nil - "Couldn't write region to `%s', decode using `%s' failed" - filename rem-dec) - ;; When `file-precious-flag' is set, the region is - ;; written to a temporary file. Check that the - ;; checksum is equal to that from the local tmpfile. - (when file-precious-flag - (erase-buffer) - (and - ;; cksum runs locally, if possible. - (zerop (tramp-local-call-process "cksum" tmpfile t)) - ;; cksum runs remotely. - (zerop - (tramp-send-command-and-check - v - (format - "cksum <%s" (tramp-shell-quote-argument localname)))) - ;; ... they are different. - (not - (string-equal - (buffer-string) - (with-current-buffer (tramp-get-buffer v) - (buffer-string)))) - (tramp-error - v 'file-error - (concat "Couldn't write region to `%s'," - " decode using `%s' failed") - filename rem-dec))) - (tramp-message - v 5 "Decoding region into remote file %s...done" filename)) - - ;; Save exit. - (delete-file tmpfile))) - - ;; That's not expected. - (t - (tramp-error - v 'file-error - (concat "Method `%s' should specify both encoding and " - "decoding command or an rcp program") - method))) + (tramp-error + v 'file-error + "Cannot write to `%s', local encoding command `%s' failed" + filename loc-enc))) + + ;; Send buffer into remote decoding command which + ;; writes to remote file. Because this happens on + ;; the remote host, we cannot use the function. + (goto-char (point-max)) + (unless (bolp) (newline)) + (tramp-message + v 5 "Decoding region into remote file %s..." filename) + (tramp-send-command + v + (format + (concat rem-dec " <<'EOF'\n%sEOF") + (tramp-shell-quote-argument localname) + (buffer-string))) + (tramp-barf-unless-okay + v nil + "Couldn't write region to `%s', decode using `%s' failed" + filename rem-dec) + ;; When `file-precious-flag' is set, the region is + ;; written to a temporary file. Check that the + ;; checksum is equal to that from the local tmpfile. + (when file-precious-flag + (erase-buffer) + (and + ;; cksum runs locally, if possible. + (zerop (tramp-local-call-process "cksum" tmpfile t)) + ;; cksum runs remotely. + (zerop + (tramp-send-command-and-check + v + (format + "cksum <%s" (tramp-shell-quote-argument localname)))) + ;; ... they are different. + (not + (string-equal + (buffer-string) + (with-current-buffer (tramp-get-buffer v) + (buffer-string)))) + (tramp-error + v 'file-error + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") + filename rem-dec))) + (tramp-message + v 5 "Decoding region into remote file %s...done" filename)) + + ;; Save exit. + (delete-file tmpfile))) + + ;; That's not expected. + (t + (tramp-error + v 'file-error + (concat "Method `%s' should specify both encoding and " + "decoding command or an rcp program") + method)))) ;; Make `last-coding-system-used' have the right value. (when coding-system-used @@ -7200,6 +7208,64 @@ (if (string-match "%s" cmd) (format cmd input) cmd) (if (stringp output) (concat "> " output) "")))) +(defconst tramp-inline-compress-commands + '(("gzip" "gzip -d") + ("bzip2" "bzip2 -d") + ("compress" "compress -d")) + "List of compress and decompress commands for inline transfer. +Each item is a list that looks like this: + +\(COMPRESS DECOMPRESS\) + +COMPRESS or DECOMPRESS are strings with the respective commands.") + +(defun tramp-find-inline-compress (vec) + "Find an inline transfer compress command that works. +Goes through the list `tramp-inline-compress-commands'." + (save-excursion + (let ((commands tramp-inline-compress-commands) + (magic "xyzzy") + item compress decompress + found) + (while (and commands (not found)) + (catch 'next + (setq item (pop commands) + compress (nth 0 item) + decompress (nth 1 item)) + (tramp-message + vec 5 + "Checking local compress command `%s', `%s' for sanity" + compress decompress) + (unless (zerop (tramp-call-local-coding-command + (format "echo %s | %s | %s" + magic compress decompress) nil nil)) + (throw 'next nil)) + (tramp-message + vec 5 + "Checking remote compress command `%s', `%s' for sanity" + compress decompress) + (unless (zerop (tramp-send-command-and-check + vec (format "echo %s | %s | %s" + magic compress decompress) t)) + (throw 'next nil)) + (setq found t))) + + ;; Did we find something? + (if found + (progn + ;; Set connection properties. + (tramp-message + vec 5 "Using inline transfer compress command `%s'" compress) + (tramp-set-connection-property vec "inline-compress" compress) + (tramp-message + vec 5 "Using inline transfer decompress command `%s'" decompress) + (tramp-set-connection-property vec "inline-decompress" decompress)) + + (tramp-set-connection-property vec "inline-compress" nil) + (tramp-set-connection-property vec "inline-decompress" nil) + (tramp-message + vec 2 "Couldn't find an inline transfer compress command"))))) + (defun tramp-compute-multi-hops (vec) "Expands VEC according to `tramp-default-proxies-alist'. Gateway hops are already opened." @@ -8079,8 +8145,9 @@ (tramp-get-method-parameter (tramp-file-name-method vec) 'tramp-copy-program) ;; Either the file size is large enough, or (in rare cases) there ;; does not exist a remote encoding. - (or (> size tramp-copy-size-limit) - (null (tramp-get-remote-coding vec "remote-encoding"))))) + (or (null tramp-copy-size-limit) + (> size tramp-copy-size-limit) + (null (tramp-get-inline-coding vec "remote-encoding" size))))) (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise." @@ -8361,31 +8428,82 @@ (nth 3 (tramp-compat-file-attributes "~/" id-format))) ;; Some predefined connection properties. -(defun tramp-get-remote-coding (vec prop) - ;; Local coding handles properties like remote coding. So we could - ;; call it without pain. - (let ((ret (tramp-get-local-coding vec prop))) +(defun tramp-get-inline-compress (vec prop size) + "Return the compress command related to PROP. +PROP is either `inline-compress' or `inline-decompress'. SIZE is +the length of the file to be compressed. + +If no corresponding command is found, nil is returned." + (when (and (integerp tramp-inline-compress-start-size) + (> size tramp-inline-compress-start-size)) + (with-connection-property vec prop + (tramp-find-inline-compress vec) + (tramp-get-connection-property vec prop nil)))) + +(defun tramp-get-inline-coding (vec prop size) + "Return the coding command related to PROP. +PROP is either `remote-encoding', `remode-decoding', +`local-encoding' or `local-decoding'. + +SIZE is the length of the file to be coded. Depending on SIZE, +compression might be applied. + +If no corresponding command is found, nil is returned. +Otherwise, either a string is returned which contains a `%s' mark +to be used for the respective input or output file; or a Lisp +function cell is returned to be applied on a buffer." + (let ((coding + (with-connection-property vec prop + (tramp-find-inline-encoding vec) + (tramp-get-connection-property vec prop nil))) + (prop1 (if (string-match "encoding" prop) + "inline-compress" "inline-decompress")) + compress) ;; The connection property might have been cached. So we must send - ;; the script - maybe. - (when (and ret (symbolp ret)) - (let ((name (symbol-name ret))) + ;; the script to the remote side - maybe. + (when (and coding (symbolp coding) (string-match "remote" prop)) + (let ((name (symbol-name coding))) (while (string-match (regexp-quote "-") name) (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value ret) name) - (setq ret name))) - ;; Return the value. - ret)) - -(defun tramp-get-local-coding (vec prop) - (or - (tramp-get-connection-property vec prop nil) - (progn - (tramp-find-inline-encoding vec) - (tramp-get-connection-property vec prop nil)))) + (tramp-maybe-send-script vec (symbol-value coding) name) + (setq coding name))) + (when coding + ;; Check for the `compress' command. + (setq compress (tramp-get-inline-compress vec prop1 size)) + ;; Return the value. + (cond + ((and compress (symbolp coding)) + (if (string-match "decompress" prop1) + `(lambda (beg end) + (,coding beg end) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (apply + 'call-process-region (point-min) (point-max) + (car (split-string ,compress)) t t nil + (cdr (split-string ,compress))))) + `(lambda (beg end) + (let ((coding-system-for-write 'binary) + (coding-system-for-read 'binary)) + (apply + 'call-process-region beg end + (car (split-string ,compress)) t t nil + (cdr (split-string ,compress)))) + (,coding (point-min) (point-max))))) + ((symbolp coding) + coding) + ((and compress (string-match "decoding" prop)) + (format "(%s | %s >%%s)" coding compress)) + (compress + (format "(%s <%%s | %s)" compress coding)) + ((string-match "decoding" prop) + (format "%s >%%s" coding)) + (t + (format "%s <%%s" coding)))))) (defun tramp-get-method-parameter (method param) "Return the method parameter PARAM. -If the `tramp-methods' entry does not exist, return NIL." +If the `tramp-methods' entry does not exist, return nil." (let ((entry (assoc param (assoc method tramp-methods)))) (when entry (cadr entry))))