;;; ange-ftp.el --- transparent FTP support for GNU Emacs
;; Copyright (C) 1989, 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1998,
-;; 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
+;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
;; Author: Andy Norman (ange@hplb.hpl.hp.com)
;; Maintainer: FSF
(if (or ange-ftp-disable-netrc-security-check
(and (eq (nth 2 attr) (user-uid)) ; Same uids.
(string-match ".r..------" (nth 8 attr))))
- (save-excursion
+ (with-current-buffer
;; we are cheating a bit here. I'm trying to do the equivalent
;; of find-file on the .netrc file, but then nuke it afterwards.
;; with the bit of logic below we should be able to have
;; encrypted .netrc files.
- (set-buffer (generate-new-buffer "*ftp-.netrc*"))
+ (generate-new-buffer "*ftp-.netrc*")
(ange-ftp-real-insert-file-contents file)
(setq buffer-file-name file)
(setq default-directory (file-name-directory file))
(setq buffer (current-buffer))
(setq buffer (get-buffer buffer)))
(let ((file (or (buffer-file-name buffer)
- (save-excursion (set-buffer buffer) default-directory))))
+ (with-current-buffer buffer default-directory))))
(if file
(let ((parsed (ange-ftp-ftp-name (expand-file-name file))))
(if parsed
(if proc
(let ((buf (process-buffer proc)))
(if buf
- (save-excursion
- (set-buffer buf)
+ (with-current-buffer buf
(setq ange-ftp-xfer-size
;; For very large files, BYTES can be a float.
(if (integerp bytes)
(defun ange-ftp-gwp-filter (proc str)
(comint-output-filter proc str)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
;; Replace STR by the result of the comint processing.
(setq str (buffer-substring comint-last-output-start (process-mark proc))))
(cond ((string-match "login: *$" str)
ange-ftp-nslookup-program host)))
(res host))
(set-process-query-on-exit-flag proc nil)
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(while (memq (process-status proc) '(run open))
(accept-process-output proc))
(goto-char (point-min))
;; Copy this so we don't alter it permanently.
(process-environment (copy-tree process-environment))
(buffer (get-buffer-create name)))
- (save-excursion
- (set-buffer buffer)
+ (with-current-buffer buffer
(internal-ange-ftp-mode))
;; This tells GNU ftp not to output any fancy escape sequences.
(setenv "TERM" "dumb")
ange-ftp-gateway-host)
args))))
(setq proc (apply 'start-process name name args))))
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(goto-char (point-max))
(set-marker (process-mark proc) (point)))
(set-process-query-on-exit-flag proc nil)
(defun ange-ftp-guess-hash-mark-size (proc)
(if ange-ftp-send-hash
- (save-excursion
- (set-buffer (process-buffer proc))
+ (with-current-buffer (process-buffer proc)
(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
(line (cdr status)))
(save-match-data
(not (string-match "R" cmd3))
(setq cmd1 (concat cmd1 ".")))
+ ;; Using "ls -flags foo" has several problems:
+ ;; - if foo is a symlink, we may get a single line showing the symlink
+ ;; rather than the listing of the directory it points to.
+ ;; - if "foo" has spaces, the parsing of the command may be done wrong.
+ ;; - some version of netbsd's ftpd only accept a single argument after
+ ;; `ls', which can either be the directory or the flags.
+ ;; So to work around those problems, we use "cd foo; ls -flags".
+
;; If the dir name contains a space, some ftp servers will
;; refuse to list it. We instead change directory to the
;; directory in question and ls ".".
(format "Listing %s"
(ange-ftp-abbreviate-filename
ange-ftp-this-file)))))
- (save-excursion
- (set-buffer (get-buffer-create
- ange-ftp-data-buffer-name))
+ (with-current-buffer (get-buffer-create
+ ange-ftp-data-buffer-name)
(erase-buffer)
(if (ange-ftp-real-file-readable-p temp)
(ange-ftp-real-insert-file-contents temp)
;;;; Directory information caching support.
;;;; ------------------------------------------------------------
-(defconst ange-ftp-date-regexp
- (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)")
- ;; In some locales, month abbreviations are as short as 2 letters,
- ;; and they can be padded on the right with spaces.
- ;; weiand: changed: month ends with . or , or .,
-;;old (month (concat l l "+ *"))
- (month (concat l l "+[.]?,? *"))
- ;; Recognize any non-ASCII character.
- ;; The purpose is to match a Kanji character.
- (k "[^\0-\177]")
- (s " ")
- (mm "[ 0-1][0-9]")
- ;; weiand: changed: day ends with .
-;;old (dd "[ 0-3][0-9]")
- (dd "[ 0-3][0-9][.]?")
- (western (concat "\\(" month s dd "\\|" dd s month "\\)"))
- (japanese (concat mm k s dd k)))
- ;; Require the previous column to end in a digit.
- ;; This avoids recognizing `1 may 1997' as a date in the line:
- ;; -r--r--r-- 1 may 1997 1168 Oct 19 16:49 README
- (concat "[0-9]" s "\\(" western "\\|" japanese "\\)" s))
- "Regular expression to match up to the column before the file name in a
-directory listing. This regular expression is designed to recognize dates
-regardless of the language.")
-
(defvar ange-ftp-add-file-entry-alist nil
"Alist saying how to add file entries on certain OS types.
Association list of pairs \( TYPE \. FUNC \), where FUNC
;;Extract the filename from the current line of a dired-like listing.
`(let ((eol (progn (end-of-line) (point))))
(beginning-of-line)
- (if (re-search-forward ange-ftp-date-regexp eol t)
- (progn
- (skip-chars-forward " ")
- (skip-chars-forward "^ " eol)
- (skip-chars-forward " " eol)
- ;; We bomb on filenames starting with a space.
- (buffer-substring (point) eol)))))
+ (if (re-search-forward directory-listing-before-filename-regexp eol t)
+ (buffer-substring (point) eol))))
;; This deals with the F switch. Should also do something about
;; unquoting names obtained with the SysV b switch and the GNU Q
;; (3) The twilight zone.
;; We'll assume (1) for now.
nil)
- ((re-search-forward ange-ftp-date-regexp nil t)
+ ((re-search-forward directory-listing-before-filename-regexp nil t)
(beginning-of-line)
(ange-ftp-ls-parser switches))
((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
(let ((result (ange-ftp-send-cmd host user '(type "binary"))))
(if (not (car result))
(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
- (save-excursion
- (set-buffer (process-buffer (ange-ftp-get-process host user)))
+ (with-current-buffer (process-buffer (ange-ftp-get-process host user))
(and ange-ftp-binary-hash-mark-size
(setq ange-ftp-hash-mark-unit
(ash ange-ftp-binary-hash-mark-size -4)))))))
(let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
(if (not (car result))
(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
- (save-excursion
- (set-buffer (process-buffer (ange-ftp-get-process host user)))
+ (with-current-buffer (process-buffer (ange-ftp-get-process host user))
(and ange-ftp-ascii-hash-mark-size
(setq ange-ftp-hash-mark-unit
(ash ange-ftp-ascii-hash-mark-size -4)))))))
;; cleanup forms
(setq coding-system-used last-coding-system-used)
(setq buffer-file-name filename)
- (set-buffer-modified-p mod-p)))
+ (restore-buffer-modified-p mod-p)))
(if binary
(ange-ftp-set-binary-mode host user))
;; (set (make-local-variable 'copy-cont) cont))))
;;
;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
-;; (save-excursion
-;; (set-buffer (process-buffer proc))
+;; (with-current-buffer (process-buffer proc)
;; (let ((cont copy-cont)
;; (result (buffer-string)))
;; (unwind-protect
(defun ange-ftp-insert-directory (file switches &optional wildcard full)
(if (not (ange-ftp-ftp-name (expand-file-name file)))
(ange-ftp-real-insert-directory file switches wildcard full)
- ;; Follow symlinks.
- (let (tem)
- (while (and (not wildcard)
- (stringp (setq tem (file-symlink-p
- (directory-file-name file)))))
- (setq file
- (ange-ftp-expand-symlink
- tem (file-name-directory (directory-file-name file))))))
+ ;; We used to follow symlinks on `file' here. Apparently it was done
+ ;; because some FTP servers react to "ls foo" by listing the symlink foo
+ ;; rather than the directory it points to. Now that ange-ftp-ls uses
+ ;; "cd foo; ls" instead, this is not necesssary any more.
(insert
(cond
(wildcard
;; target marker-char buffer overwrite-query
;; overwrite-backup-query failures skipped
;; success-count total)
-;; (let ((old-buf (current-buffer)))
-;; (unwind-protect
-;; (progn
-;; (set-buffer buffer)
+;; (with-current-buffer buffer
;; (if (null fn-list)
;; (ange-ftp-dcf-3 failures operation total skipped
;; success-count buffer)
;; overwrite-query
;; overwrite-backup-query
;; failures skipped success-count
-;; total))))))))
-;; (set-buffer old-buf))))
+;; total)))))))))
;;(defun ange-ftp-dcf-2 (result line err
;; file-creator operation fn-list
;; overwrite-backup-query
;; failures skipped success-count
;; total)
-;; (let ((old-buf (current-buffer)))
-;; (unwind-protect
-;; (progn
-;; (set-buffer buffer)
+;; (with-current-buffer buffer
;; (if (or err (not result))
;; (progn
;; (setq failures (cons (dired-make-relative from) failures))
;; overwrite-query
;; overwrite-backup-query
;; failures skipped success-count
-;; total))
-;; (set-buffer old-buf))))
+;; total)))
;;(defun ange-ftp-dcf-3 (failures operation total skipped success-count
;; buffer)
-;; (let ((old-buf (current-buffer)))
-;; (unwind-protect
-;; (progn
-;; (set-buffer buffer)
+;; (with-current-buffer buffer
;; (cond
;; (failures
;; (dired-log-summary
;; (t
;; (message "%s: %s file%s."
;; operation success-count (dired-plural-s success-count))))
-;; (dired-move-to-filename))
-;; (set-buffer old-buf))))
+;; (dired-move-to-filename)))
\f
;;;; -----------------------------------------------
;;;; Unix Descriptive Listing (dl) Support
(let ((tbl (make-hash-table :test 'equal)))
(goto-char (point-min))
(save-match-data
- (while (re-search-forward ange-ftp-date-regexp nil t)
+ (while (re-search-forward directory-listing-before-filename-regexp nil t)
(end-of-line)
(skip-chars-backward " ")
(let ((end (point)))