;;; ange-ftp.el --- transparent FTP support for GNU Emacs
-;; Copyright (C) 1989,90,91,92,93,94,95,96 Free Software Foundation, Inc.
+;; Copyright (C) 1989,90,91,92,93,94,95,96,98 Free Software Foundation, Inc.
;; Author: Andy Norman (ange@hplb.hpl.hp.com)
;; Maintainer: FSF
;;; Code:
(require 'comint)
+;; Silence compiler:
+(eval-when-compile
+ (defvar comint-last-output-start nil)
+ (defvar comint-last-input-start nil)
+ (defvar comint-last-input-end nil))
;;;; ------------------------------------------------------------
;;;; User customization variables.
:group 'ange-ftp
:type 'regexp)
-(defcustom ange-ftp-tmp-name-template "/tmp/ange-ftp"
+(defcustom ange-ftp-tmp-name-template
+ (expand-file-name "ange-ftp" temporary-file-directory)
"*Template used to create temporary files."
:group 'ange-ftp
:type 'directory)
(if (looking-at "machine\\>")
;; Skip `machine' and the machine name that follows.
(progn
- (skip-chars-forward "^ \t\n")
- (skip-chars-forward " \t\n")
- (skip-chars-forward "^ \t\n"))
+ (skip-chars-forward "^ \t\r\n")
+ (skip-chars-forward " \t\r\n")
+ (skip-chars-forward "^ \t\r\n"))
;; Skip `default'.
- (skip-chars-forward "^ \t\n"))
+ (skip-chars-forward "^ \t\r\n"))
;; Find start of the next `machine' or `default'
;; or the end of the buffer.
(if (re-search-forward "machine\\>\\|default\\>" nil t)
(mapcar 'funcall find-file-hooks)
(setq buffer-file-name nil)
(goto-char (point-min))
- (skip-chars-forward " \t\n")
+ (skip-chars-forward " \t\r\n")
(while (not (eobp))
(ange-ftp-parse-netrc-group))
(kill-buffer (current-buffer)))
(if parsed
(let ((host (nth 0 parsed))
(user (nth 1 parsed)))
- (kill-buffer (ange-ftp-ftp-process-buffer host user))))))))
+ (kill-buffer (get-buffer (ange-ftp-ftp-process-buffer host user)))))))))
(defun ange-ftp-quote-string (string)
"Quote any characters in STRING that may confuse the ftp process."
(process-kill-without-query proc)
(set-process-sentinel proc (function ange-ftp-process-sentinel))
(set-process-filter proc (function ange-ftp-process-filter))
- (accept-process-output proc) ;wait for ftp startup message
+ ;; wait for ftp startup message
+ (if (not (eq system-type 'windows-nt))
+ (accept-process-output proc)
+ ;; On Windows, the standard ftp client behaves a little oddly,
+ ;; initially buffering its output (because stdin/out are pipe
+ ;; handles). As a result, the startup message doesn't appear
+ ;; until enough output is generated to flush stdout, so a plain
+ ;; accept-process-output call at this point would hang
+ ;; indefinitely. So if nothing appears within 2 seconds, we try
+ ;; sending an innocuous command ("help foo") that forces some
+ ;; output. Curiously, once we start sending normal commands, the
+ ;; output no longer appears to be buffered, and everything works
+ ;; correctly (or at least appears to!).
+ (if (accept-process-output proc 2)
+ nil
+ (process-send-string proc "help foo\n")
+ (accept-process-output proc)))
proc))
(put 'internal-ange-ftp-mode 'mode-class 'special)
(ange-ftp-real-expand-file-name name))
((eq (string-to-char name) ?/)
(ange-ftp-canonize-filename name))
+ ((and (eq system-type 'windows-nt) (string-match "^[a-zA-Z]:" name))
+ name) ; when on local drive, return it as-is
((zerop (length name))
(ange-ftp-canonize-filename (or default default-directory)))
((ange-ftp-canonize-filename
(user (nth 1 parsed))
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
+ ;; What we REALLY need here is a way to determine if the mode
+ ;; of the transfer is irrelevant, i.e. we can use binary mode
+ ;; regardless. Maybe a system-type to host-type lookup?
(binary (or (ange-ftp-binary-file filename)
- (eq (ange-ftp-host-type host user) 'unix)))
+ (and (not (eq system-type 'windows-nt))
+ (eq (ange-ftp-host-type host user) 'unix))))
(cmd (if append 'append 'put))
(abbr (ange-ftp-abbreviate-filename filename)))
(unwind-protect
(name (ange-ftp-quote-string (nth 2 parsed)))
(temp (ange-ftp-make-tmp-name host))
(binary (or (ange-ftp-binary-file filename)
- (eq (ange-ftp-host-type host user) 'unix)))
+ (and (not (eq system-type 'windows-nt))
+ (eq (ange-ftp-host-type host user) 'unix))))
(abbr (ange-ftp-abbreviate-filename filename))
size)
(unwind-protect
(setq
size
(nth 1 (ange-ftp-real-insert-file-contents
- temp visit beg end replace)))
+ temp visit beg end replace))
+ ;; override autodetection of buffer file type
+ ;; to ensure buffer is saved in DOS format
+ buffer-file-type binary)
(signal 'ftp-error
(list
"Opening input file:"
(t-abbr (ange-ftp-abbreviate-filename newname filename))
(binary (or (ange-ftp-binary-file filename)
(ange-ftp-binary-file newname)
- (and (eq (ange-ftp-host-type f-host f-user) 'unix)
+ (and (not (eq system-type 'windows-nt))
+ (eq (ange-ftp-host-type f-host f-user) 'unix)
(eq (ange-ftp-host-type t-host t-user) 'unix))))
temp1
temp2)
file))))
completions)))
- (if (string-equal "/" ange-ftp-this-dir)
+ (if (or (and (eq system-type 'windows-nt)
+ (string-match "[^a-zA-Z]?[a-zA-Z]:[/\]" ange-ftp-this-dir))
+ (string-equal "/" ange-ftp-this-dir))
(nconc (all-completions file (ange-ftp-generate-root-prefixes))
(ange-ftp-real-file-name-all-completions file
ange-ftp-this-dir))
(cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
file-name-handler-alist)))
+;;; Real ange-ftp file names prefixed with a drive letter.
+;;;###autoload
+(and (memq system-type '(ms-dos windows-nt))
+ (or (assoc "^[a-zA-Z]:/[^/:]*[^/:.]:" file-name-handler-alist)
+ (setq file-name-handler-alist
+ (cons '("^[a-zA-Z]:/[^/:]*[^/:.]:" . ange-ftp-hook-function)
+ file-name-handler-alist))))
+
;;; This regexp recognizes and absolute filenames with only one component,
;;; for the sake of hostname completion.
;;;###autoload
(cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
file-name-handler-alist)))
+;;; Absolute file names prefixed with a drive letter.
+;;;###autoload
+(and (memq system-type '(ms-dos windows-nt))
+ (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
+ (setq file-name-handler-alist
+ (cons '("^[a-zA-Z]:/[^/:]*\\'" .
+ ange-ftp-completion-hook-function)
+ file-name-handler-alist))))
+
;;; The above two forms are sufficient to cause this file to be loaded
;;; if the user ever uses a file name with a colon in it.
(put 'vc-registered 'ange-ftp 'null)
(put 'dired-call-process 'ange-ftp 'ange-ftp-dired-call-process)
+(put 'shell-command 'ange-ftp 'ange-ftp-shell-command)
\f
;;; Define ways of getting at unmodified Emacs primitives,
;;; turning off our handler.
(ange-ftp-run-real-handler 'file-name-as-directory args))
(defun ange-ftp-real-directory-file-name (&rest args)
(ange-ftp-run-real-handler 'directory-file-name args))
+(or (and (eq system-type 'windows-nt)
+ ;; Windows handler for [A-Z]: drive name on local disks
+ (defun ange-ftp-real-expand-file-name (&rest args)
+ (ange-ftp-run-real-handler 'ange-ftp-real-expand-file-name-actual args)))
(defun ange-ftp-real-expand-file-name (&rest args)
- (ange-ftp-run-real-handler 'expand-file-name args))
+ (ange-ftp-run-real-handler 'expand-file-name args)))
(defun ange-ftp-real-make-directory (&rest args)
(ange-ftp-run-real-handler 'make-directory args))
(defun ange-ftp-real-delete-directory (&rest args)
(if func (funcall func file keep-backup-version)
(ange-ftp-real-file-name-sans-versions file keep-backup-version))))
-;;; This doesn't work yet; a new hook needs to be created.
-;;; Maybe the new hook should be in call-process.
-(defun ange-ftp-shell-command (command)
+;; This is the handler for shell-command.
+(defun ange-ftp-shell-command (command &optional output-buffer)
(let* ((parsed (ange-ftp-ftp-name default-directory))
(host (nth 0 parsed))
(user (nth 1 parsed))
(name (nth 2 parsed)))
(if (not parsed)
- (ange-ftp-real-shell-command command)
+ (ange-ftp-real-shell-command command output-buffer)
(if (> (length name) 0) ; else it's $HOME
(setq command (concat "cd " name "; " command)))
(setq command
;; Cannot call ange-ftp-real-dired-run-shell-command here as it
;; would prepend "cd default-directory" --- which bombs because
;; default-directory is in ange-ftp syntax for remote file names.
- (ange-ftp-real-shell-command command))))
+ (ange-ftp-real-shell-command command output-buffer))))
;;; This is the handler for call-process.
(defun ange-ftp-dired-call-process (program discard &rest arguments)
;; Can't use ange-ftp-dired-host-type here because the current
;; buffer is *dired-check-process output*
(condition-case oops
- (cond ((equal "chmod" program)
+ (cond ((equal dired-chmod-program program)
(ange-ftp-call-chmod arguments))
;; ((equal "chgrp" program))
;; ((equal dired-chown-program program))
(defun ange-ftp-call-chmod (args)
(if (< (length args) 2)
(error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
- (let ((mode (car args)))
+ (let ((mode (car args))
+ (rest (cdr args)))
+ (if (equal "--" (car rest))
+ (setq rest (cdr rest)))
(mapcar
(function
(lambda (file)
(or (car result)
(call-process
ange-ftp-remote-shell
- nil t nil host "chmod" mode name)))))))
- (cdr args)))
+ nil t nil host dired-chmod-program mode name)))))))
+ rest))
(setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired.
0)
\f
;; (setq ange-ftp-dired-get-filename-alist
;; (cons '(cms . ange-ftp-dired-cms-get-filename)
;; ange-ftp-dired-get-filename-alist)))
+\f
+;;
+(and (eq system-type 'windows-nt)
+ (setq ange-ftp-disable-netrc-security-check t))
+
+;; If a drive letter has been added, remote it. Otherwise, if the drive
+;; letter existed before, leave it.
+(defun ange-ftp-real-expand-file-name-actual (&rest args)
+ (let (old-name new-name final drive-letter)
+ (setq old-name (car args))
+ (setq new-name (ange-ftp-run-real-handler 'expand-file-name args))
+ (setq drive-letter (substring new-name 0 2))
+ ;; I'd like to distill the following lines into one (if) statement
+ ;; removing the need for the temp final variable
+ (setq final new-name)
+ (if (not (equal (substring old-name 0 1) "~"))
+ (if (or (< (length old-name) 2)
+ (not (string-match "/[a-zA-Z]:" old-name)))
+ (setq final (substring new-name 2))))
+ final))
+
\f
;;;; ------------------------------------------------------------
;;;; Finally provide package.