Mercurial > emacs
comparison lisp/net/ange-ftp.el @ 65810:0534e10b621e
Use with-current-buffer.
(ange-ftp-insert-directory): Do not follow symlinks any more.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Mon, 03 Oct 2005 21:19:15 +0000 |
parents | 5121212db622 |
children | 967a91879fee |
comparison
equal
deleted
inserted
replaced
65809:f528ccbc5de9 | 65810:0534e10b621e |
---|---|
1385 (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed | 1385 (not (equal (nth 5 attr) ange-ftp-netrc-modtime))) ; file changed |
1386 (save-match-data | 1386 (save-match-data |
1387 (if (or ange-ftp-disable-netrc-security-check | 1387 (if (or ange-ftp-disable-netrc-security-check |
1388 (and (eq (nth 2 attr) (user-uid)) ; Same uids. | 1388 (and (eq (nth 2 attr) (user-uid)) ; Same uids. |
1389 (string-match ".r..------" (nth 8 attr)))) | 1389 (string-match ".r..------" (nth 8 attr)))) |
1390 (save-excursion | 1390 (with-current-buffer |
1391 ;; we are cheating a bit here. I'm trying to do the equivalent | 1391 ;; we are cheating a bit here. I'm trying to do the equivalent |
1392 ;; of find-file on the .netrc file, but then nuke it afterwards. | 1392 ;; of find-file on the .netrc file, but then nuke it afterwards. |
1393 ;; with the bit of logic below we should be able to have | 1393 ;; with the bit of logic below we should be able to have |
1394 ;; encrypted .netrc files. | 1394 ;; encrypted .netrc files. |
1395 (set-buffer (generate-new-buffer "*ftp-.netrc*")) | 1395 (generate-new-buffer "*ftp-.netrc*") |
1396 (ange-ftp-real-insert-file-contents file) | 1396 (ange-ftp-real-insert-file-contents file) |
1397 (setq buffer-file-name file) | 1397 (setq buffer-file-name file) |
1398 (setq default-directory (file-name-directory file)) | 1398 (setq default-directory (file-name-directory file)) |
1399 (normal-mode t) | 1399 (normal-mode t) |
1400 (run-hooks 'find-file-hook) | 1400 (run-hooks 'find-file-hook) |
1511 (interactive "bKill FTP process associated with buffer: ") | 1511 (interactive "bKill FTP process associated with buffer: ") |
1512 (if (null buffer) | 1512 (if (null buffer) |
1513 (setq buffer (current-buffer)) | 1513 (setq buffer (current-buffer)) |
1514 (setq buffer (get-buffer buffer))) | 1514 (setq buffer (get-buffer buffer))) |
1515 (let ((file (or (buffer-file-name buffer) | 1515 (let ((file (or (buffer-file-name buffer) |
1516 (save-excursion (set-buffer buffer) default-directory)))) | 1516 (with-current-buffer buffer default-directory)))) |
1517 (if file | 1517 (if file |
1518 (let ((parsed (ange-ftp-ftp-name (expand-file-name file)))) | 1518 (let ((parsed (ange-ftp-ftp-name (expand-file-name file)))) |
1519 (if parsed | 1519 (if parsed |
1520 (let ((host (nth 0 parsed)) | 1520 (let ((host (nth 0 parsed)) |
1521 (user (nth 1 parsed))) | 1521 (user (nth 1 parsed))) |
1592 "Set the size of the next FTP transfer in bytes." | 1592 "Set the size of the next FTP transfer in bytes." |
1593 (let ((proc (ange-ftp-get-process host user))) | 1593 (let ((proc (ange-ftp-get-process host user))) |
1594 (if proc | 1594 (if proc |
1595 (let ((buf (process-buffer proc))) | 1595 (let ((buf (process-buffer proc))) |
1596 (if buf | 1596 (if buf |
1597 (save-excursion | 1597 (with-current-buffer buf |
1598 (set-buffer buf) | |
1599 (setq ange-ftp-xfer-size | 1598 (setq ange-ftp-xfer-size |
1600 ;; For very large files, BYTES can be a float. | 1599 ;; For very large files, BYTES can be a float. |
1601 (if (integerp bytes) | 1600 (if (integerp bytes) |
1602 (ash bytes -10) | 1601 (ash bytes -10) |
1603 (/ bytes 1024))))))))) | 1602 (/ bytes 1024))))))))) |
1763 (defun ange-ftp-gwp-sentinel (proc str) | 1762 (defun ange-ftp-gwp-sentinel (proc str) |
1764 (setq ange-ftp-gwp-running nil)) | 1763 (setq ange-ftp-gwp-running nil)) |
1765 | 1764 |
1766 (defun ange-ftp-gwp-filter (proc str) | 1765 (defun ange-ftp-gwp-filter (proc str) |
1767 (comint-output-filter proc str) | 1766 (comint-output-filter proc str) |
1768 (save-excursion | 1767 (with-current-buffer (process-buffer proc) |
1769 (set-buffer (process-buffer proc)) | |
1770 ;; Replace STR by the result of the comint processing. | 1768 ;; Replace STR by the result of the comint processing. |
1771 (setq str (buffer-substring comint-last-output-start (process-mark proc)))) | 1769 (setq str (buffer-substring comint-last-output-start (process-mark proc)))) |
1772 (cond ((string-match "login: *$" str) | 1770 (cond ((string-match "login: *$" str) |
1773 (process-send-string proc | 1771 (process-send-string proc |
1774 (concat | 1772 (concat |
1906 (proc (let ((process-connection-type t)) | 1904 (proc (let ((process-connection-type t)) |
1907 (start-process " *nslookup*" " *nslookup*" | 1905 (start-process " *nslookup*" " *nslookup*" |
1908 ange-ftp-nslookup-program host))) | 1906 ange-ftp-nslookup-program host))) |
1909 (res host)) | 1907 (res host)) |
1910 (set-process-query-on-exit-flag proc nil) | 1908 (set-process-query-on-exit-flag proc nil) |
1911 (save-excursion | 1909 (with-current-buffer (process-buffer proc) |
1912 (set-buffer (process-buffer proc)) | |
1913 (while (memq (process-status proc) '(run open)) | 1910 (while (memq (process-status proc) '(run open)) |
1914 (accept-process-output proc)) | 1911 (accept-process-output proc)) |
1915 (goto-char (point-min)) | 1912 (goto-char (point-min)) |
1916 (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t) | 1913 (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t) |
1917 (setq res (match-string 1))) | 1914 (setq res (match-string 1))) |
1946 ;; Can anyone find a fix for that? | 1943 ;; Can anyone find a fix for that? |
1947 (let ((process-connection-type t) | 1944 (let ((process-connection-type t) |
1948 ;; Copy this so we don't alter it permanently. | 1945 ;; Copy this so we don't alter it permanently. |
1949 (process-environment (copy-tree process-environment)) | 1946 (process-environment (copy-tree process-environment)) |
1950 (buffer (get-buffer-create name))) | 1947 (buffer (get-buffer-create name))) |
1951 (save-excursion | 1948 (with-current-buffer buffer |
1952 (set-buffer buffer) | |
1953 (internal-ange-ftp-mode)) | 1949 (internal-ange-ftp-mode)) |
1954 ;; This tells GNU ftp not to output any fancy escape sequences. | 1950 ;; This tells GNU ftp not to output any fancy escape sequences. |
1955 (setenv "TERM" "dumb") | 1951 (setenv "TERM" "dumb") |
1956 (if use-gateway | 1952 (if use-gateway |
1957 (if ange-ftp-gateway-program-interactive | 1953 (if ange-ftp-gateway-program-interactive |
1959 (setq proc (apply 'start-process name name | 1955 (setq proc (apply 'start-process name name |
1960 (append (list ange-ftp-gateway-program | 1956 (append (list ange-ftp-gateway-program |
1961 ange-ftp-gateway-host) | 1957 ange-ftp-gateway-host) |
1962 args)))) | 1958 args)))) |
1963 (setq proc (apply 'start-process name name args)))) | 1959 (setq proc (apply 'start-process name name args)))) |
1964 (save-excursion | 1960 (with-current-buffer (process-buffer proc) |
1965 (set-buffer (process-buffer proc)) | |
1966 (goto-char (point-max)) | 1961 (goto-char (point-max)) |
1967 (set-marker (process-mark proc) (point))) | 1962 (set-marker (process-mark proc) (point))) |
1968 (set-process-query-on-exit-flag proc nil) | 1963 (set-process-query-on-exit-flag proc nil) |
1969 (set-process-sentinel proc 'ange-ftp-process-sentinel) | 1964 (set-process-sentinel proc 'ange-ftp-process-sentinel) |
1970 (set-process-filter proc 'ange-ftp-process-filter) | 1965 (set-process-filter proc 'ange-ftp-process-filter) |
2126 "[hH]ash mark [^0-9]*\\([0-9]+\\)" | 2121 "[hH]ash mark [^0-9]*\\([0-9]+\\)" |
2127 "*Regexp matching the FTP client's output upon doing a HASH command.") | 2122 "*Regexp matching the FTP client's output upon doing a HASH command.") |
2128 | 2123 |
2129 (defun ange-ftp-guess-hash-mark-size (proc) | 2124 (defun ange-ftp-guess-hash-mark-size (proc) |
2130 (if ange-ftp-send-hash | 2125 (if ange-ftp-send-hash |
2131 (save-excursion | 2126 (with-current-buffer (process-buffer proc) |
2132 (set-buffer (process-buffer proc)) | |
2133 (let* ((status (ange-ftp-raw-send-cmd proc "hash")) | 2127 (let* ((status (ange-ftp-raw-send-cmd proc "hash")) |
2134 (line (cdr status))) | 2128 (line (cdr status))) |
2135 (save-match-data | 2129 (save-match-data |
2136 (if (string-match ange-ftp-hash-mark-msgs line) | 2130 (if (string-match ange-ftp-hash-mark-msgs line) |
2137 (let ((size (string-to-number (match-string 1 line)))) | 2131 (let ((size (string-to-number (match-string 1 line)))) |
2306 ;; be happy.) | 2300 ;; be happy.) |
2307 (and (eq host-type 'unix) | 2301 (and (eq host-type 'unix) |
2308 (string-match "/\\'" cmd1) | 2302 (string-match "/\\'" cmd1) |
2309 (not (string-match "R" cmd3)) | 2303 (not (string-match "R" cmd3)) |
2310 (setq cmd1 (concat cmd1 "."))) | 2304 (setq cmd1 (concat cmd1 "."))) |
2305 | |
2306 ;; Using "ls -flags foo" has several problems: | |
2307 ;; - if foo is a symlink, we may get a single line showing the symlink | |
2308 ;; rather than the listing of the directory it points to. | |
2309 ;; - if "foo" has spaces, the parsing of the command may be done wrong. | |
2310 ;; - some version of netbsd's ftpd only accept a single argument after | |
2311 ;; `ls', which can either be the directory or the flags. | |
2312 ;; So to work around those problems, we use "cd foo; ls -flags". | |
2311 | 2313 |
2312 ;; If the dir name contains a space, some ftp servers will | 2314 ;; If the dir name contains a space, some ftp servers will |
2313 ;; refuse to list it. We instead change directory to the | 2315 ;; refuse to list it. We instead change directory to the |
2314 ;; directory in question and ls ".". | 2316 ;; directory in question and ls ".". |
2315 (when (string-match " " cmd1) | 2317 (when (string-match " " cmd1) |
2605 user | 2607 user |
2606 lscmd | 2608 lscmd |
2607 (format "Listing %s" | 2609 (format "Listing %s" |
2608 (ange-ftp-abbreviate-filename | 2610 (ange-ftp-abbreviate-filename |
2609 ange-ftp-this-file))))) | 2611 ange-ftp-this-file))))) |
2610 (save-excursion | 2612 (with-current-buffer (get-buffer-create |
2611 (set-buffer (get-buffer-create | 2613 ange-ftp-data-buffer-name)) |
2612 ange-ftp-data-buffer-name)) | |
2613 (erase-buffer) | 2614 (erase-buffer) |
2614 (if (ange-ftp-real-file-readable-p temp) | 2615 (if (ange-ftp-real-file-readable-p temp) |
2615 (ange-ftp-real-insert-file-contents temp) | 2616 (ange-ftp-real-insert-file-contents temp) |
2616 (sleep-for ange-ftp-retry-time) | 2617 (sleep-for ange-ftp-retry-time) |
2617 ;wait for file to possibly appear | 2618 ;wait for file to possibly appear |
3021 (defun ange-ftp-set-binary-mode (host user) | 3022 (defun ange-ftp-set-binary-mode (host user) |
3022 "Tell the ftp process for the given HOST & USER to switch to binary mode." | 3023 "Tell the ftp process for the given HOST & USER to switch to binary mode." |
3023 (let ((result (ange-ftp-send-cmd host user '(type "binary")))) | 3024 (let ((result (ange-ftp-send-cmd host user '(type "binary")))) |
3024 (if (not (car result)) | 3025 (if (not (car result)) |
3025 (ange-ftp-error host user (concat "BINARY failed: " (cdr result))) | 3026 (ange-ftp-error host user (concat "BINARY failed: " (cdr result))) |
3026 (save-excursion | 3027 (with-current-buffer (process-buffer (ange-ftp-get-process host user)) |
3027 (set-buffer (process-buffer (ange-ftp-get-process host user))) | |
3028 (and ange-ftp-binary-hash-mark-size | 3028 (and ange-ftp-binary-hash-mark-size |
3029 (setq ange-ftp-hash-mark-unit | 3029 (setq ange-ftp-hash-mark-unit |
3030 (ash ange-ftp-binary-hash-mark-size -4))))))) | 3030 (ash ange-ftp-binary-hash-mark-size -4))))))) |
3031 | 3031 |
3032 (defun ange-ftp-set-ascii-mode (host user) | 3032 (defun ange-ftp-set-ascii-mode (host user) |
3033 "Tell the ftp process for the given HOST & USER to switch to ascii mode." | 3033 "Tell the ftp process for the given HOST & USER to switch to ascii mode." |
3034 (let ((result (ange-ftp-send-cmd host user '(type "ascii")))) | 3034 (let ((result (ange-ftp-send-cmd host user '(type "ascii")))) |
3035 (if (not (car result)) | 3035 (if (not (car result)) |
3036 (ange-ftp-error host user (concat "ASCII failed: " (cdr result))) | 3036 (ange-ftp-error host user (concat "ASCII failed: " (cdr result))) |
3037 (save-excursion | 3037 (with-current-buffer (process-buffer (ange-ftp-get-process host user)) |
3038 (set-buffer (process-buffer (ange-ftp-get-process host user))) | |
3039 (and ange-ftp-ascii-hash-mark-size | 3038 (and ange-ftp-ascii-hash-mark-size |
3040 (setq ange-ftp-hash-mark-unit | 3039 (setq ange-ftp-hash-mark-unit |
3041 (ash ange-ftp-ascii-hash-mark-size -4))))))) | 3040 (ash ange-ftp-ascii-hash-mark-size -4))))))) |
3042 | 3041 |
3043 (defun ange-ftp-cd (host user dir &optional noerror) | 3042 (defun ange-ftp-cd (host user dir &optional noerror) |
3288 (or visit 'quiet)) | 3287 (or visit 'quiet)) |
3289 (setq coding-system-used last-coding-system-used)) | 3288 (setq coding-system-used last-coding-system-used)) |
3290 ;; cleanup forms | 3289 ;; cleanup forms |
3291 (setq coding-system-used last-coding-system-used) | 3290 (setq coding-system-used last-coding-system-used) |
3292 (setq buffer-file-name filename) | 3291 (setq buffer-file-name filename) |
3293 (set-buffer-modified-p mod-p))) | 3292 (restore-buffer-modified-p mod-p))) |
3294 (if binary | 3293 (if binary |
3295 (ange-ftp-set-binary-mode host user)) | 3294 (ange-ftp-set-binary-mode host user)) |
3296 | 3295 |
3297 ;; tell the process filter what size the transfer will be. | 3296 ;; tell the process filter what size the transfer will be. |
3298 (let ((attr (file-attributes temp))) | 3297 (let ((attr (file-attributes temp))) |
3641 ;; (process-kill-without-query proc) | 3640 ;; (process-kill-without-query proc) |
3642 ;; (with-current-buffer (process-buffer proc) | 3641 ;; (with-current-buffer (process-buffer proc) |
3643 ;; (set (make-local-variable 'copy-cont) cont)))) | 3642 ;; (set (make-local-variable 'copy-cont) cont)))) |
3644 ;; | 3643 ;; |
3645 ;; (defun ange-ftp-copy-file-locally-sentinel (proc status) | 3644 ;; (defun ange-ftp-copy-file-locally-sentinel (proc status) |
3646 ;; (save-excursion | 3645 ;; (with-current-buffer (process-buffer proc) |
3647 ;; (set-buffer (process-buffer proc)) | |
3648 ;; (let ((cont copy-cont) | 3646 ;; (let ((cont copy-cont) |
3649 ;; (result (buffer-string))) | 3647 ;; (result (buffer-string))) |
3650 ;; (unwind-protect | 3648 ;; (unwind-protect |
3651 ;; (if (and (string-equal status "finished\n") | 3649 ;; (if (and (string-equal status "finished\n") |
3652 ;; (zerop (length result))) | 3650 ;; (zerop (length result))) |
4479 ;; `ange-ftp-ls' handles this. | 4477 ;; `ange-ftp-ls' handles this. |
4480 | 4478 |
4481 (defun ange-ftp-insert-directory (file switches &optional wildcard full) | 4479 (defun ange-ftp-insert-directory (file switches &optional wildcard full) |
4482 (if (not (ange-ftp-ftp-name (expand-file-name file))) | 4480 (if (not (ange-ftp-ftp-name (expand-file-name file))) |
4483 (ange-ftp-real-insert-directory file switches wildcard full) | 4481 (ange-ftp-real-insert-directory file switches wildcard full) |
4484 ;; Follow symlinks. | 4482 ;; We used to follow symlinks on `file' here. Apparently it was done |
4485 (let (tem) | 4483 ;; because some FTP servers react to "ls foo" by listing the symlink foo |
4486 (while (and (not wildcard) | 4484 ;; rather than the directory it points to. Now that ange-ftp-ls uses |
4487 (stringp (setq tem (file-symlink-p | 4485 ;; "cd foo; ls" instead, this is not necesssary any more. |
4488 (directory-file-name file))))) | |
4489 (setq file | |
4490 (ange-ftp-expand-symlink | |
4491 tem (file-name-directory (directory-file-name file)))))) | |
4492 (insert | 4486 (insert |
4493 (cond | 4487 (cond |
4494 (wildcard | 4488 (wildcard |
4495 (let ((default-directory (file-name-directory file))) | 4489 (let ((default-directory (file-name-directory file))) |
4496 (ange-ftp-ls (file-name-nondirectory file) switches nil nil t))) | 4490 (ange-ftp-ls (file-name-nondirectory file) switches nil nil t))) |
4669 | 4663 |
4670 ;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor | 4664 ;;(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor |
4671 ;; target marker-char buffer overwrite-query | 4665 ;; target marker-char buffer overwrite-query |
4672 ;; overwrite-backup-query failures skipped | 4666 ;; overwrite-backup-query failures skipped |
4673 ;; success-count total) | 4667 ;; success-count total) |
4674 ;; (let ((old-buf (current-buffer))) | 4668 ;; (with-current-buffer buffer |
4675 ;; (unwind-protect | |
4676 ;; (progn | |
4677 ;; (set-buffer buffer) | |
4678 ;; (if (null fn-list) | 4669 ;; (if (null fn-list) |
4679 ;; (ange-ftp-dcf-3 failures operation total skipped | 4670 ;; (ange-ftp-dcf-3 failures operation total skipped |
4680 ;; success-count buffer) | 4671 ;; success-count buffer) |
4681 | 4672 |
4682 ;; (let* ((from (car fn-list)) | 4673 ;; (let* ((from (car fn-list)) |
4744 ;; overwrite | 4735 ;; overwrite |
4745 ;; overwrite-confirmed | 4736 ;; overwrite-confirmed |
4746 ;; overwrite-query | 4737 ;; overwrite-query |
4747 ;; overwrite-backup-query | 4738 ;; overwrite-backup-query |
4748 ;; failures skipped success-count | 4739 ;; failures skipped success-count |
4749 ;; total)))))))) | 4740 ;; total))))))))) |
4750 ;; (set-buffer old-buf)))) | |
4751 | 4741 |
4752 ;;(defun ange-ftp-dcf-2 (result line err | 4742 ;;(defun ange-ftp-dcf-2 (result line err |
4753 ;; file-creator operation fn-list | 4743 ;; file-creator operation fn-list |
4754 ;; name-constructor | 4744 ;; name-constructor |
4755 ;; target | 4745 ;; target |
4759 ;; overwrite-confirmed | 4749 ;; overwrite-confirmed |
4760 ;; overwrite-query | 4750 ;; overwrite-query |
4761 ;; overwrite-backup-query | 4751 ;; overwrite-backup-query |
4762 ;; failures skipped success-count | 4752 ;; failures skipped success-count |
4763 ;; total) | 4753 ;; total) |
4764 ;; (let ((old-buf (current-buffer))) | 4754 ;; (with-current-buffer buffer |
4765 ;; (unwind-protect | |
4766 ;; (progn | |
4767 ;; (set-buffer buffer) | |
4768 ;; (if (or err (not result)) | 4755 ;; (if (or err (not result)) |
4769 ;; (progn | 4756 ;; (progn |
4770 ;; (setq failures (cons (dired-make-relative from) failures)) | 4757 ;; (setq failures (cons (dired-make-relative from) failures)) |
4771 ;; (dired-log "%s `%s' to `%s' failed:\n%s\n" | 4758 ;; (dired-log "%s `%s' to `%s' failed:\n%s\n" |
4772 ;; operation from to (or err line))) | 4759 ;; operation from to (or err line))) |
4785 ;; marker-char | 4772 ;; marker-char |
4786 ;; buffer | 4773 ;; buffer |
4787 ;; overwrite-query | 4774 ;; overwrite-query |
4788 ;; overwrite-backup-query | 4775 ;; overwrite-backup-query |
4789 ;; failures skipped success-count | 4776 ;; failures skipped success-count |
4790 ;; total)) | 4777 ;; total))) |
4791 ;; (set-buffer old-buf)))) | |
4792 | 4778 |
4793 ;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count | 4779 ;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count |
4794 ;; buffer) | 4780 ;; buffer) |
4795 ;; (let ((old-buf (current-buffer))) | 4781 ;; (with-current-buffer buffer |
4796 ;; (unwind-protect | |
4797 ;; (progn | |
4798 ;; (set-buffer buffer) | |
4799 ;; (cond | 4782 ;; (cond |
4800 ;; (failures | 4783 ;; (failures |
4801 ;; (dired-log-summary | 4784 ;; (dired-log-summary |
4802 ;; (message "%s failed for %d of %d file%s %s" | 4785 ;; (message "%s failed for %d of %d file%s %s" |
4803 ;; operation (length failures) total | 4786 ;; operation (length failures) total |
4808 ;; operation (length skipped) total | 4791 ;; operation (length skipped) total |
4809 ;; (dired-plural-s total) skipped))) | 4792 ;; (dired-plural-s total) skipped))) |
4810 ;; (t | 4793 ;; (t |
4811 ;; (message "%s: %s file%s." | 4794 ;; (message "%s: %s file%s." |
4812 ;; operation success-count (dired-plural-s success-count)))) | 4795 ;; operation success-count (dired-plural-s success-count)))) |
4813 ;; (dired-move-to-filename)) | 4796 ;; (dired-move-to-filename))) |
4814 ;; (set-buffer old-buf)))) | |
4815 | 4797 |
4816 ;;;; ----------------------------------------------- | 4798 ;;;; ----------------------------------------------- |
4817 ;;;; Unix Descriptive Listing (dl) Support | 4799 ;;;; Unix Descriptive Listing (dl) Support |
4818 ;;;; ----------------------------------------------- | 4800 ;;;; ----------------------------------------------- |
4819 | 4801 |