From: ange@hplb.hpl.hp.com (Andy Norman)
Subject: ange-ftp 4.20, part 2 of 8
Organization: Source only  Discussion and requests in gnu.emacs.help.
Distribution: gnu
Date: Wed, 19 Aug 1992 09:13:24 GMT

Submitted-by: ange@hplb.hpl.hp.com
Archive-name: ange-ftp/part02

---- Cut Here and feed the following to sh ----
#!/bin/sh
# this is ange-ftp.02 (part 2 of ange-ftp)
# do not concatenate these parts, unpack them in order with /bin/sh
# file ange-ftp.el continued
#
if test ! -r _shar_seq_.tmp; then
	echo 'Please unpack part 1 first!'
	exit 1
fi
(read Scheck
 if test "$Scheck" != 2; then
	echo Please unpack part "$Scheck" next!
	exit 1
 else
	exit 0
 fi
) < _shar_seq_.tmp || exit 1
if test -f _shar_wnt_.tmp; then
sed 's/^X//' << 'SHAR_EOF' >> 'ange-ftp.el' &&
doesn't arrive. This might need to be increased for very slow connections.")
X
(defvar ange-ftp-auto-save 0
X  "If 1, allows ange-ftp files to be auto-saved.
If 0, suppresses auto-saving of ange-ftp files.
Don't use any other value.")
X
;;;; ------------------------------------------------------------
;;;; Hash table support.
;;;; ------------------------------------------------------------
X
(require 'backquote)
X
(defun ange-ftp-make-hashtable (&optional size)
X  "Make an obarray suitable for use as a hashtable.
SIZE, if supplied, should be a prime number."
X  (make-vector (or size 31) 0))
X
(defun ange-ftp-map-hashtable (fun tbl)
X  "Call FUNCTION on each key and value in HASHTABLE."
X  (mapatoms
X   (function 
X    (lambda (sym)
X      (funcall fun (get sym 'key) (get sym 'val))))
X   tbl))
X
(defmacro ange-ftp-make-hash-key (key)
X  "Convert KEY into a suitable key for a hashtable."
X  (` (if (stringp (, key))
X	 (, key)
X       (prin1-to-string (, key)))))
X
(defun ange-ftp-get-hash-entry (key tbl)
X  "Return the value associated with KEY in HASHTABLE."
X  (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))
X    (and sym (get sym 'val))))
X
(defun ange-ftp-put-hash-entry (key val tbl)
X  "Record an association between KEY and VALUE in HASHTABLE."
X  (let ((sym (intern (ange-ftp-make-hash-key key) tbl)))
X    (put sym 'val val)
X    (put sym 'key key)))
X
(defun ange-ftp-del-hash-entry (key tbl)
X  "Copy all symbols except KEY in HASHTABLE and return modified hashtable."
X  (let* ((len (length tbl))
X	 (new-tbl (ange-ftp-make-hashtable len))
X	 (i (1- len)))
X    (ange-ftp-map-hashtable
X     (function
X      (lambda (k v)
X	(or (equal k key)
X	    (ange-ftp-put-hash-entry k v new-tbl))))
X     tbl)
X    (while (>= i 0)
X      (aset tbl i (aref new-tbl i))
X      (setq i (1- i)))
X    tbl))
X
(defun ange-ftp-hash-entry-exists-p (key tbl)
X  "Return whether there is an association for KEY in TABLE."
X  (intern-soft (ange-ftp-make-hash-key key) tbl))
X
(defun ange-ftp-hash-table-keys (tbl)
X  "Return a sorted list of all the active keys in the hashtable, as strings."
X  (sort (all-completions "" tbl)
X	(function string-lessp)))
X
;;;; ------------------------------------------------------------
;;;; Internal variables.
;;;; ------------------------------------------------------------
X
(defconst ange-ftp-version "$Revision: 4.20 $")
X
(defvar ange-ftp-data-buffer-name " *ftp data*"
X  "Buffer name to hold directory listing data received from ftp process.")
X
(defvar ange-ftp-netrc-modtime nil
X  "Last modified time of the netrc file from file-attributes.")
X
(defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable)
X  "Hash table holding associations between HOST, USER pairs.")
X
(defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable)
X  "Mapping between a HOST, USER pair and a PASSWORD for them.")
X
(defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable)
X  "Mapping between a HOST, USER pair and a ACCOUNT password for them.")
X
(defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97)
X  "Hash table for storing directories and their respective files.")
X
(defvar ange-ftp-ls-cache-lsargs nil
X  "Last set of args used by ange-ftp-ls.")
X
(defvar ange-ftp-ls-cache-file nil
X  "Last file passed to ange-ftp-ls.")
X
(defvar ange-ftp-ls-cache-res nil
X  "Last result returned from ange-ftp-ls.")
X
;; New error symbols.
(put 'ftp-error 'error-conditions '(ftp-error file-error error))
;; (put 'ftp-error 'error-message "FTP error")
X
;;; ------------------------------------------------------------
;;; Match-data support (stolen from Kyle I think)
;;; ------------------------------------------------------------
X
(defmacro ange-ftp-save-match-data (&rest body)
X  "Execute the BODY forms, restoring the global value of the match data.
Before executing BODY, case-fold-search is locally bound to nil."
X  (let ((original (make-symbol "match-data"))
X	case-fold-search)
X    (list
X     'let (list (list original '(match-data)))
X     (list 'unwind-protect
X           (cons 'progn body)
X           (list 'store-match-data original)))))
X
(put 'ange-ftp-save-match-data 'lisp-indent-hook 0)
(put 'ange-ftp-save-match-data 'edebug-form-hook '(&rest form))
X
;;; ------------------------------------------------------------
;;; Enhanced message support.
;;; ------------------------------------------------------------
X
(defun ange-ftp-message (fmt &rest args)
X  "Output the given message, but truncate to the size of the minibuffer
window."
X  (let ((msg (apply (function format) fmt args))
X	(max (window-width (minibuffer-window))))
X    (if (>= (length msg) max)
X	(setq msg (concat "> " (substring msg (- 3 max)))))
X    (message "%s" msg)))
X
(defun ange-ftp-abbreviate-filename (file &optional new)
X  "Abbreviate the given filename relative to the default-directory.  If the
optional parameter NEW is given and the non-directory parts match, only return
the directory part of the file."
X  (ange-ftp-save-match-data
X    (if (and default-directory
X	     (string-match (concat "^"
X				   (regexp-quote default-directory)
X				   ".") file))
X	(setq file (substring file (1- (match-end 0)))))
X    (if (and new
X	     (string-equal (file-name-nondirectory file)
X			   (file-name-nondirectory new)))
X	(setq file (file-name-directory file)))
X    (or file "./")))
X
;;;; ------------------------------------------------------------
;;;; User / Host mapping support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-set-user (host user)
X  "For a given HOST, set or change the default USER."
X  (interactive "sHost: \nsUser: ")
X  (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable))
X
(defun ange-ftp-get-user (host)
X  "Given a HOST, return the default USER."
X  (ange-ftp-parse-netrc)
X  (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable)))
X    (or user
X	(prog1
X	    (setq user
X		  (cond ((stringp ange-ftp-default-user)
X			 ;; We have a default name.  Use it.
X			 ange-ftp-default-user)
X			(ange-ftp-default-user
X			 ;; Ask the user.
X			 (let ((enable-recursive-minibuffers t))
X			   (read-string (format "User for %s: " host)
X					(user-login-name))))
X			;; Default to the user's login name.
X			(t
X			 (user-login-name))))
X	  (ange-ftp-set-user host user)))))
X
;;;; ------------------------------------------------------------
;;;; Password support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-read-passwd (prompt &optional default)
X  "Read a password from the user. Echos a . for each character typed.
End with RET, LFD, or ESC. DEL or C-h rubs out.  ^U kills line.
Optional DEFAULT is password to start with."
X  (let ((pass (if default default ""))
X	(c 0)
X	(echo-keystrokes 0)
X	(cursor-in-echo-area t))
X    (while (and (/= c ?\r) (/= c ?\n) (/= c ?\e))
X      (message "%s%s"
X	       prompt
X	       (make-string (length pass) ?.))
X      (setq c (read-char))
X      (if (= c ?\C-u)
X	  (setq pass "")
X	(if (and (/= c ?\b) (/= c ?\177))
X	    (setq pass (concat pass (char-to-string c)))
X	  (if (> (length pass) 0)
X	      (setq pass (substring pass 0 -1))))))
X    (ange-ftp-repaint-minibuffer)
X    (substring pass 0 -1)))
X
(defmacro ange-ftp-generate-passwd-key (host user)
X  (` (concat (, host) "/" (, user))))
X
(defmacro ange-ftp-lookup-passwd (host user)
X  (` (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key (, host) (, user))
X			      ange-ftp-passwd-hashtable)))
X
(defun ange-ftp-set-passwd (host user passwd)
X  "For a given HOST and USER, set or change the associated PASSWORD."
X  (interactive (list (read-string "Host: ")
X		     (read-string "User: ")
X		     (ange-ftp-read-passwd "Password: ")))
X  (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
X			   passwd
X			   ange-ftp-passwd-hashtable))
X
(defun ange-ftp-get-host-with-passwd (user)
X  "Given a USER, return a host we know the password for."
X  (ange-ftp-parse-netrc)
X  (catch 'found-one
X    (ange-ftp-map-hashtable
X     (function (lambda (host val)
X		 (if (ange-ftp-lookup-passwd host user)
X		     (throw 'found-one host))))
X     ange-ftp-user-hashtable)
X    (ange-ftp-save-match-data
X      (ange-ftp-map-hashtable
X       (function
X	(lambda (key value)
X	  (if (string-match "^[^/]*\\(/\\).*$" key)
X	      (let ((host (substring key 0 (match-beginning 1))))
X		(if (and (string-equal user (substring key (match-end 1)))
X			 value)
X		    (throw 'found-one host))))))
X       ange-ftp-passwd-hashtable))
X    nil))
X
(defun ange-ftp-get-passwd (host user)
X  "Given a HOST and USER, return the FTP password, prompting if it was not
previously set."
X  (ange-ftp-parse-netrc)
X
X  ;; look up password in the hash table first; user might have overriden the
X  ;; defaults.
X  (cond ((ange-ftp-lookup-passwd host user))
X	
X	;; see if default user and password set from the .netrc file.
X	((and (stringp ange-ftp-default-user)
X	      ange-ftp-default-password
X	      (string-equal user ange-ftp-default-user))
X	 ange-ftp-default-password)
X	
X	;; anonymous ftp password is handled specially since there is an
X	;; unwritten rule about how that is used on the Internet.
X	((and (or (string-equal user "anonymous")
X		  (string-equal user "ftp"))
X	      ange-ftp-generate-anonymous-password)
X	 (if (stringp ange-ftp-generate-anonymous-password)
X	     ange-ftp-generate-anonymous-password
X	   (concat (user-login-name) "@" (system-name))))
X	
X	;; see if same user has logged in to other hosts; if so then prompt
X	;; with the password that was used there.
X	(t
X	 (let* ((other (ange-ftp-get-host-with-passwd user))
X		(passwd (if other
X			    
X			    ;; found another machine with the same user.
X			    ;; Try that account.
X			    (ange-ftp-read-passwd
X			     (format "passwd for %s@%s (same as %s@%s): "
X				     user host user other)
X			     (ange-ftp-lookup-passwd other user))
X			  
X			  ;; I give up.  Ask the user for the password.
X			  (ange-ftp-read-passwd
X			   (format "Password for %s@%s: " user host)))))
X	   (ange-ftp-set-passwd host user passwd)
X	   passwd))))
X
;;;; ------------------------------------------------------------
;;;; Account support
;;;; ------------------------------------------------------------
X
;; Account passwords must be either specified in the .netrc file, or set
;; manually by calling ange-ftp-set-account.  For the moment, ange-ftp doesn't
;; check to see whether the FTP process is actually prompting for an account
;; password.
X 
(defun ange-ftp-set-account (host user account)
X  "For a given HOST and USER, set or change the associated ACCOUNT password."
X  (interactive (list (read-string "Host: ")
X		     (read-string "User: ")
X		     (ange-ftp-read-passwd "Account password: ")))
X  (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)
X			   account
X			   ange-ftp-account-hashtable))
X
(defun ange-ftp-get-account (host user)
X  "Given a HOST and USER, return the FTP account."
X  (ange-ftp-parse-netrc)
X  (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user)
X			       ange-ftp-account-hashtable)
X      (and (stringp ange-ftp-default-user)
X	   (string-equal user ange-ftp-default-user)
X	   ange-ftp-default-account)))
X
;;;; ------------------------------------------------------------
;;;; ~/.netrc support
;;;; ------------------------------------------------------------
X
(defun ange-ftp-chase-symlinks (file)
X  "Return the filename that FILENAME references, following all symbolic links."
X  (let (temp)
X    (while (setq temp (ange-ftp-real-file-symlink-p file))
X      (setq file
X	    (if (file-name-absolute-p temp)
X		temp
X	      (concat (file-name-directory file) temp)))))
X  file)
X
(defun ange-ftp-parse-netrc-token (token limit)
X  "Move along current line looking for the value of the TOKEN.  Valid
separators between TOKEN and its value are commas and whitespace.
Second arg LIMIT is a limit for the search."
X  (if (search-forward token limit t)
X      (let (beg)
X	(skip-chars-forward ", \t\r\n" limit)
X	(if (eq (following-char) ?\")	;quoted token value
X	    (progn (forward-char 1)
X		   (setq beg (point))
X		   (skip-chars-forward "^\"" limit)
X		   (forward-char 1)
X		   (buffer-substring beg (1- (point))))
X	  (setq beg (point))
X	  (skip-chars-forward "^, \t\r\n" limit)
X	  (buffer-substring beg (point))))))
X
(defun ange-ftp-parse-netrc-group ()
X  "Extract the values for the tokens  \`machine\', \`login\', \`password\'
and \`account\' in the current buffer.  If successful, record the information
found."
X  (beginning-of-line)
X  (let ((start (point))
X	(end (progn (re-search-forward "machine\\|default"
X				       (point-max) 'end 2) (point)))
X	machine login password account)
X    (goto-char start)
X    (setq machine  (ange-ftp-parse-netrc-token "machine"  end)
X	  login    (ange-ftp-parse-netrc-token "login"    end)
X	  password (ange-ftp-parse-netrc-token "password" end)
X	  account  (ange-ftp-parse-netrc-token "account"  end))
X    (if (and machine login)
X	;; found a `machine` token.
X	(progn
X	  (ange-ftp-set-user machine login)
X	  (ange-ftp-set-passwd machine login password)
X	  (and account
X	       (ange-ftp-set-account machine login account)))
X      (goto-char start)
X      (if (search-forward "default" end t)
X	  ;; found a `default' token
X	  (progn
X	    (setq login    (ange-ftp-parse-netrc-token "login"    end)
X		  password (ange-ftp-parse-netrc-token "password" end)
X		  account  (ange-ftp-parse-netrc-token "account"  end))
X	    (and login
X		 (setq ange-ftp-default-user login))
X	    (and password
X		 (setq ange-ftp-default-password password))
X	    (and account
X		 (setq ange-ftp-default-account account)))))
X    (goto-char end)))
X
(defun ange-ftp-parse-netrc ()
X  "If ~/.netrc file exists and has the correct permissions then extract the
\`machine\', \`login\', \`password\' and \`account\' information from within."
X
X  ;; We set this before actually doing it to avoid the possibility
X  ;; of an infinite loop if ange-ftp-netrc-filename is an FTP file.
X  (interactive)
X  (let* ((file (ange-ftp-chase-symlinks
X		(ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
X	 (attr (ange-ftp-real-file-attributes file)))
X    (if (and attr			; file exists.
X	     (not (equal (nth 5 attr) ange-ftp-netrc-modtime)))	; file changed
X	(ange-ftp-save-match-data
X	  (if (or ange-ftp-disable-netrc-security-check
X		  (and (eq (nth 2 attr) (user-uid)) ; Same uids.
X		       (string-match ".r..------" (nth 8 attr))))
X	      (save-excursion
X		;; we are cheating a bit here.  I'm trying to do the equivalent
X		;; of find-file on the .netrc file, but then nuke it afterwards.
X		;; with the bit of logic below we should be able to have
X		;; encrypted .netrc files.
X		(set-buffer (generate-new-buffer "*ftp-.netrc*"))
X		(ange-ftp-real-insert-file-contents file)
X		(setq buffer-file-name file)
X		(setq default-directory (file-name-directory file))
X		(normal-mode t)
X		(mapcar 'funcall find-file-hooks)
X		(setq buffer-file-name nil)
X		(goto-char (point-min))
X		(while (not (eobp))
X		  (ange-ftp-parse-netrc-group))
X		(kill-buffer (current-buffer)))
X	    (ange-ftp-message "%s either not owned by you or badly protected."
X			      ange-ftp-netrc-filename)
X	    (sit-for 1))
X	  (setq ange-ftp-netrc-modtime (nth 5 attr))))))
X
(defun ange-ftp-generate-root-prefixes ()
X  "Return a list of prefixes of the form 'user@host:' to be used when
completion is done in the root directory."
X  (ange-ftp-parse-netrc)
X  (ange-ftp-save-match-data
X    (let (res)
X      (ange-ftp-map-hashtable
X       (function
X	(lambda (key value)
X	  (if (string-match "^[^/]*\\(/\\).*$" key)
X	      (let ((host (substring key 0 (match-beginning 1)))
X		    (user (substring key (match-end 1))))
X		(setq res (cons (list (concat user "@" host ":"))
X				res))))))
X       ange-ftp-passwd-hashtable)
X      (ange-ftp-map-hashtable
X       (function (lambda (host user)
X		   (setq res (cons (list (concat host ":"))
X				   res))))
X       ange-ftp-user-hashtable)
X      (or res (list nil)))))
X
;;;; ------------------------------------------------------------
;;;; Remote pathname syntax support.
;;;; ------------------------------------------------------------
X
(defmacro ange-ftp-ftp-path-component (n ns path)
X  "Extract the Nth ftp path component from NS."
X  (` (let ((elt (nth (, n) (, ns))))
X       (substring (, path) (match-beginning elt) (match-end elt)))))
X
(defvar ange-ftp-ftp-path-arg "")
(defvar ange-ftp-ftp-path-res nil)
X
(defun ange-ftp-ftp-path (path)
X  "Parse PATH according to ange-ftp-path-format (which see).
Returns a list (HOST USER PATH), or nil if PATH does not match the format."
X  (if (string-equal path ange-ftp-ftp-path-arg)
X      ange-ftp-ftp-path-res
X    (setq ange-ftp-ftp-path-arg path
X	  ange-ftp-ftp-path-res
X	  (ange-ftp-save-match-data
X	    (if (string-match (car ange-ftp-path-format) path)
X		(let* ((ns (cdr ange-ftp-path-format))
X		       (host (ange-ftp-ftp-path-component 0 ns path))
X		       (user (ange-ftp-ftp-path-component 1 ns path))
X		       (path (ange-ftp-ftp-path-component 2 ns path)))
X		  (if (zerop (length user))
X		      (setq user (ange-ftp-get-user host)))
X		  (list host user path))
X	      nil)))))
X
(defun ange-ftp-replace-path-component (fullpath path)
X  "Take a FULLPATH that matches according to ange-ftp-path-format and
replace the path component with PATH."
X  (ange-ftp-save-match-data
X    (if (string-match (car ange-ftp-path-format) fullpath)
X	(let* ((ns (cdr ange-ftp-path-format))
X	       (elt (nth 2 ns)))
X	  (concat (substring fullpath 0 (match-beginning elt))
X		  path
X		  (substring fullpath (match-end elt)))))))
X
;;;; ------------------------------------------------------------
;;;; Miscellaneous utils.
;;;; ------------------------------------------------------------
X
(setq ange-ftp-tmp-keymap (make-sparse-keymap))
(define-key ange-ftp-tmp-keymap "\C-m" 'exit-minibuffer)
X
(defun ange-ftp-repaint-minibuffer ()
X  "Gross hack to set minibuf_message = 0, so that the contents of the
minibuffer will show."
X  (if (eq (selected-window) (minibuffer-window))
X      (if (fboundp 'allocate-event)
X	  ;; lemacs
X	  (let ((unread-command-event (character-to-event ?\C-m
X							  (allocate-event)))
X		(enable-recursive-minibuffers t))
X	    (read-from-minibuffer "" nil ange-ftp-tmp-keymap nil))
X	;; v18 GNU Emacs
X	(let ((unread-command-char ?\C-m)
X	      (enable-recursive-minibuffers t))
X	  (read-from-minibuffer "" nil ange-ftp-tmp-keymap nil)))))
X
(defun ange-ftp-ftp-process-buffer (host user)
X  "Return the name of the buffer that collects output from the ftp process
connected to the given HOST and USER pair."
X  (concat "*ftp " user "@" host "*"))
X
(defun ange-ftp-error (host user msg)
X  "Display the last chunk of output from the ftp process for the given HOST
USER pair, and signal an error including MSG in the text."
X  (let ((cur (selected-window))
X	(pop-up-windows t))
X    (pop-to-buffer
X     (get-buffer-create
X      (ange-ftp-ftp-process-buffer host user)))
X    (goto-char (point-max))
X    (select-window cur))
X  (signal 'ftp-error (list (format "FTP Error: %s" msg))))
X
(defun ange-ftp-set-buffer-mode ()
X  "Set the correct modes for the current buffer if it is visiting a remote
file."
X  (if (and (stringp buffer-file-name)
X	   (ange-ftp-ftp-path buffer-file-name))
X      (progn
X	(auto-save-mode ange-ftp-auto-save)
X	(make-variable-buffer-local 'revert-buffer-function)
X	(setq revert-buffer-function 'ange-ftp-revert-buffer))))
X
(defun ange-ftp-kill-ftp-process (buffer)
X  "If the BUFFER's visited filename or default-directory is an ftp filename
then kill the related ftp process."
X  (interactive "bKill FTP process associated with buffer: ")
X  (if (null buffer)
X      (setq buffer (current-buffer)))
X  (let ((file (or (buffer-file-name) default-directory)))
X    (if file
X	(let ((parsed (ange-ftp-ftp-path (expand-file-name file))))
X	  (if parsed
X	      (let ((host (nth 0 parsed))
X		    (user (nth 1 parsed)))
X		(kill-buffer (ange-ftp-ftp-process-buffer host user))))))))
X
(defun ange-ftp-quote-string (string)
X  "Quote any characters in STRING that may confuse the ftp process."
X  (apply (function concat)
X	 (mapcar (function
X		   (lambda (char)
X		     (if (or (<= char ? )
X			     (> char ?\~)
X		             (= char ?\")
X			     (= char ?\\))
X			 (vector ?\\ char)
X		       (vector char))))
X		 string)))
X
(defun ange-ftp-barf-if-not-directory (directory)
X  (or (file-directory-p directory)
X      (signal 'file-error
X	      (list "Opening directory"
X		    (if (file-exists-p directory)
X			"not a directory"
X		      "no such file or directory")
X		    directory))))
X
;;;; ------------------------------------------------------------
;;;; FTP process filter support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-process-handle-line (line proc)
X  "Look at the given LINE from the ftp process PROC.  Try to catagorize it
into one of four categories: good, skip, fatal, or unknown."
X  (cond ((string-match ange-ftp-xfer-size-msgs line)
X	 (setq ange-ftp-xfer-size
X	       (ash (string-to-int (substring line
X					      (match-beginning 1)
X					      (match-end 1)))
X		    -10)))
X	((string-match ange-ftp-skip-msgs line)
X	 t)
X	((string-match ange-ftp-good-msgs line)
X	 (setq ange-ftp-process-busy nil
X	       ange-ftp-process-result t
X	       ange-ftp-process-result-line line))
X	((string-match ange-ftp-fatal-msgs line)
X	 (delete-process proc)
X	 (setq ange-ftp-process-busy nil
X	       ange-ftp-process-result-line line))
X	((string-match ange-ftp-multi-msgs line)
X	 (setq ange-ftp-process-multi-skip t))
X	(ange-ftp-process-multi-skip
X	 t)
X	(t
X	 (setq ange-ftp-process-busy nil
X	       ange-ftp-process-result-line line))))
X
(defun ange-ftp-process-log-string (proc str)
X  "For a given PROCESS, log the given STRING at the end of its
associated buffer."
X  (let ((old-buffer (current-buffer)))
X    (unwind-protect
X	(let (moving)
X	  (set-buffer (process-buffer proc))
X	  (setq moving (= (point) (process-mark proc)))
X	  (save-excursion
X	    ;; Insert the text, moving the process-marker.
X	    (goto-char (process-mark proc))
X	    (insert str)
X	    (set-marker (process-mark proc) (point)))
X	  (if moving (goto-char (process-mark proc))))
X      (set-buffer old-buffer))))
X
(defun ange-ftp-set-xfer-size (host user bytes)
X  "Set the size of the next FTP transfer in bytes."
X  (let ((proc (ange-ftp-get-process host user)))
X    (if proc
X	(let ((buf (process-buffer proc)))
X	  (if buf
X	      (save-excursion
X		(set-buffer buf)
X		(setq ange-ftp-xfer-size (ash bytes -10))))))))
X
(defun ange-ftp-process-handle-hash (str)
X  "Remove hash marks from STRING and display count so far."
X  (setq str (concat (substring str 0 (match-beginning 0))
X		    (substring str (match-end 0)))
X	ange-ftp-hash-mark-count (+ (- (match-end 0)
X				       (match-beginning 0))
X				    ange-ftp-hash-mark-count))
X  (and ange-ftp-process-msg
X       ange-ftp-process-verbose
X       (not (eq (selected-window) (minibuffer-window)))
X       (not (boundp 'search-message))	;screws up isearch otherwise
X       (not cursor-in-echo-area)	;screws up y-or-n-p otherwise
X       (let ((kbytes (ash (* ange-ftp-hash-mark-unit
X			     ange-ftp-hash-mark-count)
X			  -6)))
X       (if (zerop ange-ftp-xfer-size)
X	   (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)
X	 (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size)))
X	   ;; cut out the redisplay of identical %-age messages.
X	   (if (not (eq percent ange-ftp-last-percent))
X	       (progn
X		 (setq ange-ftp-last-percent percent)
X		 (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent)))))))
X  str)
X
(defun ange-ftp-call-cont (cont result line)
X  "Call the function specified by CONT.  CONT can be either a function or a
list of a function and some args.  The first two parameters passed to the
function will be RESULT and LINE.  The remaining args will be taken from CONT
if a list was passed."
X  (if cont
X      (if (and (listp cont)
X	       (not (eq (car cont) 'lambda)))
X	  (apply (car cont) result line (cdr cont))
X	(funcall cont result line))))
X
(defun ange-ftp-process-filter (proc str)
X  "Build up a complete line of output from the ftp PROCESS and pass it
on to ange-ftp-process-handle-line to deal with."
X  (let ((buffer (process-buffer proc))
X	(old-buffer (current-buffer)))
X
X    ;; see if the buffer is still around... it could have been deleted.
X    (if (buffer-name buffer)
X	(unwind-protect
X	    (ange-ftp-save-match-data
X	      (set-buffer (process-buffer proc))
X	      
X	      ;; handle hash mark printing
X	      (and ange-ftp-hash-mark-unit
X		   ange-ftp-process-busy
X		   (string-match "^#+$" str)
X		   (setq str (ange-ftp-process-handle-hash str)))
X	      (ange-ftp-process-log-string proc str)
X	      (if ange-ftp-process-busy
X		  (progn
X		    (setq ange-ftp-process-string (concat ange-ftp-process-string
X							  str))
X		    
X		    ;; if we gave an empty password to the USER command earlier
X		    ;; then we should send a null password now.
X		    (if (string-match "Password: *$" ange-ftp-process-string)
X			(send-string proc "\n"))))
X	      (while (and ange-ftp-process-busy
X			  (string-match "\n" ange-ftp-process-string))
X		(let ((line (substring ange-ftp-process-string
X				       0
X				       (match-beginning 0))))
X		  (setq ange-ftp-process-string (substring ange-ftp-process-string
X							   (match-end 0)))
X		  (while (string-match "^ftp> *" line)
X		    (setq line (substring line (match-end 0))))
X		  (ange-ftp-process-handle-line line proc)))
X
X	      ;; has the ftp client finished?  if so then do some clean-up
X	      ;; actions.
X	      (if (not ange-ftp-process-busy)
X		  (progn
X		    ;; reset the xfer size
X		    (setq ange-ftp-xfer-size 0)
X
X		    ;; issue the "done" message since we've finished.
X		    (if (and ange-ftp-process-msg
X			     ange-ftp-process-verbose
X			     ange-ftp-process-result)
X			(progn
X			  (ange-ftp-message "%s...done" ange-ftp-process-msg)
X			  (ange-ftp-repaint-minibuffer)
X			  (setq ange-ftp-process-msg nil)))
X		    
X		    ;; is there a continuation we should be calling?  if so,
X		    ;; we'd better call it, making sure we only call it once.
X		    (if ange-ftp-process-continue
X			(let ((cont ange-ftp-process-continue))
X			  (setq ange-ftp-process-continue nil)
X			  (ange-ftp-call-cont cont
X					      ange-ftp-process-result
X					      ange-ftp-process-result-line))))))
X	  (set-buffer old-buffer)))))
X
(defun ange-ftp-process-sentinel (proc str)
X  "When ftp process changes state, nuke all file-entries in cache."
X  (ange-ftp-save-match-data
X    (let ((name (process-name proc)))
X      (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name)
X	  (let ((user (substring name (match-beginning 1) (match-end 1)))
X		(host (substring name (match-beginning 2) (match-end 2))))
X	    (ange-ftp-wipe-file-entries host user))))
X    (setq ange-ftp-ls-cache-file nil)))
X
;;;; ------------------------------------------------------------
;;;; Gateway support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-use-gateway-p (host)
X  "Returns whether to access this host via a normal (non-smart) gateway."
X  ;; yes, I know that I could simplify the following expression, but it is
X  ;; clearer (to me at least) this way.
X  (and (not ange-ftp-smart-gateway)
X       (ange-ftp-save-match-data
X	 (not (string-match ange-ftp-local-host-regexp host)))))
X
(defun ange-ftp-use-smart-gateway-p (host)
X  "Returns whether to access this host via a smart gateway."
X  (and ange-ftp-smart-gateway
X       (ange-ftp-save-match-data
X	 (not (string-match ange-ftp-local-host-regexp host)))))
X
X
;;; ------------------------------------------------------------
;;; Temporary file location and deletion...
;;; ------------------------------------------------------------
X
(defvar ange-ftp-tmp-name-files ())
(defvar ange-ftp-tmp-name-hashtable (ange-ftp-make-hashtable 10))
(defvar ange-ftp-pid nil)
X
(defun ange-ftp-get-pid ()
X  "Half-hearted attempt to get the current process's id."
X  (setq ange-ftp-pid (substring (make-temp-name "") 1)))
X
(defun ange-ftp-make-tmp-name (host)
X  "This routine will return the name of a new file."
X  (let* ((template (if (ange-ftp-use-gateway-p host)
X		       ange-ftp-gateway-tmp-name-template
X		     ange-ftp-tmp-name-template))
X	 (pid (or ange-ftp-pid (ange-ftp-get-pid)))
X	 (start ?a)
X	 file entry)
X    (while 
X	(progn
X	  (setq file (format "%s%c%s" template start pid))
X	  (setq entry (intern file ange-ftp-tmp-name-hashtable))
X	  (or (memq entry ange-ftp-tmp-name-files)
X	      (ange-ftp-real-file-exists-p file)))
X      (if (> (setq start (1+ start)) ?z)
X	  (progn
X	    (setq template (concat template "X"))
X	    (setq start ?a))))
X    (setq ange-ftp-tmp-name-files
X	  (cons entry ange-ftp-tmp-name-files))
X    file))
X
(defun ange-ftp-del-tmp-name (temp)
X  (setq ange-ftp-tmp-name-files
X	(delq (intern temp ange-ftp-tmp-name-hashtable)
X	      ange-ftp-tmp-name-files))
X  (condition-case ()
X      (ange-ftp-real-delete-file temp)
X    (error nil)))
X
;;;; ------------------------------------------------------------
;;;; Interactive gateway program support.
;;;; ------------------------------------------------------------
X
(defvar ange-ftp-gwp-running t)
(defvar ange-ftp-gwp-status nil)
X
(defun ange-ftp-gwp-sentinel (proc str)
X  (setq ange-ftp-gwp-running nil))
X
(defun ange-ftp-gwp-filter (proc str)
X  (ange-ftp-save-match-data
X    (ange-ftp-process-log-string proc str)
X    (cond ((string-match "login: *$" str)
X	   (send-string proc
X			(concat
X			 (let ((ange-ftp-default-user t))
X			   (ange-ftp-get-user ange-ftp-gateway-host))
X			 "\n")))
X	  ((string-match "Password: *$" str)
X	   (send-string proc
X			(concat
X			 (ange-ftp-get-passwd ange-ftp-gateway-host
X					      (ange-ftp-get-user
X					       ange-ftp-gateway-host))
X			 "\n")))
X	  ((string-match ange-ftp-gateway-fatal-msgs str)
X	   (delete-process proc)
X	   (setq ange-ftp-gwp-running nil))
X	  ((string-match ange-ftp-gateway-prompt-pattern str)
X	   (setq ange-ftp-gwp-running nil
X		 ange-ftp-gwp-status t)))))
X
(defun ange-ftp-gwp-start (host user name args)
X  "Login to the gateway machine and fire up an ftp process."
X  (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host))
X	 (proc (start-process name name 
X			      ange-ftp-gateway-program
X			      ange-ftp-gateway-host))
X	 (ftp (mapconcat (function identity) args " ")))
X    (process-kill-without-query proc)
X    (set-process-sentinel proc (function ange-ftp-gwp-sentinel))
X    (set-process-filter proc (function ange-ftp-gwp-filter))
X    (set-marker (process-mark proc) (point))
X    (setq ange-ftp-gwp-running t
X	  ange-ftp-gwp-status nil)
X    (ange-ftp-message "Connecting to gateway %s..." ange-ftp-gateway-host)
X    (while ange-ftp-gwp-running		;perform login sequence
X      (accept-process-output proc))
X    (if (not ange-ftp-gwp-status)
X	(ange-ftp-error host user "unable to login to gateway"))
X    (ange-ftp-message "Connecting to gateway %s...done" ange-ftp-gateway-host)
X    (setq ange-ftp-gwp-running t
X	  ange-ftp-gwp-status nil)
X    (process-send-string proc ange-ftp-gateway-setup-term-command)
X    (while ange-ftp-gwp-running		;zap ^M's and double echoing.
X      (accept-process-output proc))
X    (if (not ange-ftp-gwp-status)
X	(ange-ftp-error host user "unable to set terminal modes on gateway"))
X    (setq ange-ftp-gwp-running t
X	  ange-ftp-gwp-status nil)
X    (process-send-string proc (concat "exec " ftp "\n")) ;spawn ftp process
X    proc))
X
;;;; ------------------------------------------------------------
;;;; Support for sending commands to the ftp process.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-raw-send-cmd (proc cmd &optional msg cont nowait)
X  "Low-level routine to send the given ftp CMD to the ftp PROCESS.
MSG is an optional message to output before and after the command.
If CONT is non-NIL then it is either a function or a list of function and
some arguments.  The function will be called when the ftp command has completed.
If CONT is NIL then this routine will return \( RESULT . LINE \) where RESULT
is whether the command was successful, and LINE is the line from the FTP
process that caused the command to complete.
If NOWAIT is given then the routine will return immediately the command has
been queued with no result.  CONT will still be called, however."
X  (if (memq (process-status proc) '(run open))
X      (save-excursion
X	(set-buffer (process-buffer proc))
X	(while ange-ftp-process-busy
X	  (accept-process-output))
X	(setq ange-ftp-process-string ""
X	      ange-ftp-process-result-line ""
X	      ange-ftp-process-busy t
X	      ange-ftp-process-result nil
X	      ange-ftp-process-multi-skip nil
X	      ange-ftp-process-msg msg
X	      ange-ftp-process-continue cont
X	      ange-ftp-hash-mark-count 0
X	      ange-ftp-last-percent -1
X	      cmd (concat cmd "\n"))
X	(and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
X	(goto-char (point-max))
X	(move-marker last-input-start (point))
X	;; don't insert the password into the buffer on the USER command.
X	(ange-ftp-save-match-data
X	  (if (string-match "^user \"[^\"]*\"" cmd)
X	      (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
X	    (insert cmd)))
X	(move-marker last-input-end (point))
X	(send-string proc cmd)
X	(set-marker (process-mark proc) (point))
X	(if nowait
X	    nil
X	  ;; hang around for command to complete
X	  (while ange-ftp-process-busy
X	    (accept-process-output proc))
X	  (if cont
X	      nil			;cont has already been called
X	    (cons ange-ftp-process-result ange-ftp-process-result-line))))))
X
(defun ange-ftp-nslookup-host (host)
X  "Attempt to resolve the given HOSTNAME using nslookup if possible."
X  (interactive "sHost:  ")
X  (if ange-ftp-nslookup-program
X      (let ((proc (start-process " *nslookup*" " *nslookup*"
X				 ange-ftp-nslookup-program host))
X	    (res host))
X	(process-kill-without-query proc)
X	(save-excursion
X	  (set-buffer (process-buffer proc))
X	  (while (memq (process-status proc) '(run open))
X	    (accept-process-output proc))
X	  (goto-char (point-min))
X	  (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
X	      (setq res (buffer-substring (match-beginning 1)
X					  (match-end 1))))
X	  (kill-buffer (current-buffer)))
X	res)
X    host))
X
(defun ange-ftp-start-process (host user name)
X  "Spawn a new ftp process ready to connect to machine HOST and give it NAME.
If HOST is only ftp-able through a gateway machine then spawn a shell
on the gateway machine to do the ftp instead."
X  (let* ((use-gateway (ange-ftp-use-gateway-p host))
X	 (ftp-prog (if use-gateway 
X		       ange-ftp-gateway-ftp-program-name
X		     ange-ftp-ftp-program-name))
X	 (args (append (list ftp-prog) ange-ftp-ftp-program-args))
X	 proc)
X    (if use-gateway
X	(if ange-ftp-gateway-program-interactive
X	    (setq proc (ange-ftp-gwp-start host user name args))
X	  (setq proc (apply 'start-process name name
X			    (append (list ange-ftp-gateway-program
X					  ange-ftp-gateway-host)
X				    args))))
X      (setq proc (apply 'start-process name name args)))
X    (process-kill-without-query proc)
X    (save-excursion
X      (set-buffer (process-buffer proc))
X      (ange-ftp-shell-mode))
X    (set-process-sentinel proc (function ange-ftp-process-sentinel))
X    (set-process-filter proc (function ange-ftp-process-filter))
X    (accept-process-output proc)	;wait for ftp startup message
X    proc))
X
(defun ange-ftp-smart-login (host user pass account proc)
X  "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
PROC is the FTP-client's process.  This routine uses the smart-gateway
host specified in ``ange-ftp-gateway-host''."
X  (let ((result (ange-ftp-raw-send-cmd
X		 proc
X		 (format "open %s %s"
X			 (ange-ftp-nslookup-host ange-ftp-gateway-host)
X			 ange-ftp-smart-gateway-port)
X		 (format "Opening FTP connection to %s via %s"
X			 host
X			 ange-ftp-gateway-host))))
X    (or (car result)
X	(ange-ftp-error host user 
X			(concat "OPEN request failed: "
X				(cdr result))))
X    (setq result (ange-ftp-raw-send-cmd
X		  proc (format "user \"%s\"@%s %s %s"
X			       user
X			       (ange-ftp-nslookup-host host)
X			       pass
X			       account)
X		  (format "Logging in as user %s@%s"
X			  user host)))
X    (or (car result)
X	(progn
X	  (ange-ftp-set-passwd host user nil) ; reset password
X	  (ange-ftp-set-account host user nil) ; reset account
X	  (ange-ftp-error host user
X			  (concat "USER request failed: "
X				  (cdr result)))))))
X
(defun ange-ftp-normal-login (host user pass account proc)
X  "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT.
PROC is the process to the FTP-client."
X  (let ((result (ange-ftp-raw-send-cmd
X		 proc
X		 (format "open %s" (ange-ftp-nslookup-host host))
X		 (format "Opening FTP connection to %s" host))))
X    (or (car result)
X	(ange-ftp-error host user
X			(concat "OPEN request failed: "
X				(cdr result))))
X    (setq result (ange-ftp-raw-send-cmd
X		  proc
X		  (format "user \"%s\" %s %s" user pass account)
X		  (format "Logging in as user %s@%s" user host)))
X    (or (car result)
X	(progn
X	  (ange-ftp-set-passwd host user nil) ;reset password.
X	  (ange-ftp-set-account host user nil) ;reset account.
X	  (ange-ftp-error host user
X			  (concat "USER request failed: "
X				  (cdr result)))))))
X
(defvar ange-ftp-hash-mark-msgs
X  "[hH]ash mark [^0-9]*\\([0-9]+\\)"
X  "*Regexp matching the FTP client's output upon doing a HASH command.")
X
(defun ange-ftp-guess-hash-mark-size (proc)
X  (if ange-ftp-send-hash
X      (save-excursion
X	(set-buffer (process-buffer proc))
X	(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
X	       (result (car status))
X	       (line (cdr status)))
X	  (ange-ftp-save-match-data
X	    (if (string-match ange-ftp-hash-mark-msgs line)
X		(let ((size (string-to-int
X			    (substring line
X				       (match-beginning 1)
X				       (match-end 1)))))
X		  (setq ange-ftp-ascii-hash-mark-size size
X			ange-ftp-hash-mark-unit (ash size -4))
X
X		  ;; if a default value for this is set, use that value.
X		  (or ange-ftp-binary-hash-mark-size
X		      (setq ange-ftp-binary-hash-mark-size size)))))))))
X
(defun ange-ftp-get-process (host user)
X  "Return the process object for a FTP process connected to HOST and
logged in as USER.  Create a new process if needed."
X  (let* ((name (ange-ftp-ftp-process-buffer host user))
X	 (proc (get-process name)))
X    (if (and proc (memq (process-status proc) '(run open)))
X	proc
X      (let ((pass (ange-ftp-quote-string
X		   (ange-ftp-get-passwd host user)))
X	    (account (ange-ftp-quote-string
X		      (ange-ftp-get-account host user))))
X	;; grab a suitable process.
X	(setq proc (ange-ftp-start-process host user name))
X	
X	;; login to FTP server.
X	(if (ange-ftp-use-smart-gateway-p host)
X	    (ange-ftp-smart-login host user pass account proc)
X	  (ange-ftp-normal-login host user pass account proc))
X      
X	;; Tell client to send back hash-marks as progress.  It isn't usually
X	;; fatal if this command fails.
X	(ange-ftp-guess-hash-mark-size proc)
X
X	;; Guess at the host type.
X	(ange-ftp-guess-host-type host user)
X
X	;; Run any user-specified hooks.  Note that proc, host and user are
X	;; dynamically bound at this point.
X	(run-hooks 'ange-ftp-process-startup-hook))
X      proc)))
X
;; Variables for caching host and host-type
(defvar ange-ftp-host-cache nil)
(defvar ange-ftp-host-type-cache nil)
X
;; If ange-ftp-host-type is called with the optional user
;; argument, it will attempt to guess the host type by connecting
SHAR_EOF
true || echo 'restore of ange-ftp.el failed'
fi
echo 'End of part 2, continue with part 3'
echo 3 > _shar_seq_.tmp
exit 0
Newsgroups: gnu.emacs.sources