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

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

---- Cut Here and feed the following to sh ----
#!/bin/sh
# this is ange-ftp.04 (part 4 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" != 4; 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' &&
X			       filename)))))
X	    (ange-ftp-del-tmp-name temp)
X	    (if binary 
X		(ange-ftp-set-ascii-mode host user)))
X	  (if (eq visit t)
X	      (progn
X		(ange-ftp-set-buffer-mode)
X		(setq buffer-file-name filename)
X		(set-buffer-modified-p nil)))
X	  (ange-ftp-message "Wrote %s" abbr)
X	  (ange-ftp-add-file-entry filename))
X      (ange-ftp-real-write-region start end filename append visit))))
X
(defun ange-ftp-insert-file-contents (filename &optional visit)
X  "Documented as original."
X  (barf-if-buffer-read-only)
X  (setq filename (expand-file-name filename))
X  (let ((parsed (ange-ftp-ftp-path filename)))
X    (if parsed
X	(progn
X	  (if visit
X	      (setq buffer-file-name filename))
X	  (if (or (file-exists-p filename)
X		  (progn
X		    (setq ange-ftp-ls-cache-file nil)
X		    (ange-ftp-del-hash-entry (file-name-directory filename)
X					     ange-ftp-files-hashtable)
X		    (file-exists-p filename)))
X	      (let* ((host (nth 0 parsed))
X		     (user (nth 1 parsed))
X		     (path (ange-ftp-quote-string (nth 2 parsed)))
X		     (temp (ange-ftp-make-tmp-name host))
X		     (binary (ange-ftp-binary-file filename))
X		     (abbr (ange-ftp-abbreviate-filename filename))
X		     size)
X		(unwind-protect
X		    (progn
X		      (if binary
X			  (ange-ftp-set-binary-mode host user))
X		      (let ((result (ange-ftp-send-cmd host user
X					      (list 'get path temp)
X					      (format "Retrieving %s" abbr))))
X			(or (car result)
X			    (signal 'ftp-error
X				    (list
X				     "Opening input file"
X				     (format "FTP Error: \"%s\"" (cdr result))
X				     filename))))
X		      (if (or (ange-ftp-real-file-readable-p temp)
X			      (sleep-for ange-ftp-retry-time)
X			      ;; Wait for file to hopefully appear.
X			      (ange-ftp-real-file-readable-p temp))
X			  (setq
X			   size
X			   (nth 1 (ange-ftp-real-insert-file-contents temp
X								      visit)))
X			(signal 'ftp-error
X				(list
X				 "Opening input file:"
X				 (format
X				  "FTP Error: %s not arrived or readable"
X				  filename)))))
X		  (if binary
X		      (ange-ftp-set-ascii-mode host user))
X		  (ange-ftp-del-tmp-name temp))
X		(if visit
X		    (setq buffer-file-name filename))
X		(list filename size))
X	    (signal 'file-error
X		    (list 
X		     "Opening input file"
X		     filename))))
X      (ange-ftp-real-insert-file-contents filename visit))))
X 
(defun ange-ftp-revert-buffer (arg noconfirm)
X  "Revert this buffer from a remote file using ftp."
X  (let ((opoint (point)))
X    (cond ((null buffer-file-name)
X	   (error "Buffer does not seem to be associated with any file"))
X	  ((or noconfirm
X	       (yes-or-no-p (format "Revert buffer from file %s? "
X				    buffer-file-name)))
X	   (let ((buffer-read-only nil))
X	     ;; Set buffer-file-name to nil
X	     ;; so that we don't try to lock the file.
X	     (let ((buffer-file-name nil))
X	       (unlock-buffer)
X	       (erase-buffer))
X	     (insert-file-contents buffer-file-name t))
X	   (goto-char (min opoint (point-max)))
X	   (after-find-file nil)
X	   t))))
X
(defun ange-ftp-expand-symlink (file dir)
X  (if (file-name-absolute-p file)
X      (ange-ftp-replace-path-component dir file)
X    (expand-file-name file dir)))
X
(defun ange-ftp-file-symlink-p (file)
X  "Documented as original."
X  ;; call ange-ftp-expand-file-name rather than the normal
X  ;; expand-file-name to stop loops when using a package that
X  ;; redefines both file-symlink-p and expand-file-name.
X  (setq file (ange-ftp-expand-file-name file))
X  (if (ange-ftp-ftp-path file)
X      (let ((file-ent
X	     (ange-ftp-get-hash-entry
X	      (ange-ftp-get-file-part file)
X	      (ange-ftp-get-files (file-name-directory file)))))
X	(if (stringp file-ent)
X	    (if (file-name-absolute-p file-ent)
X		(ange-ftp-replace-path-component
X		      (file-name-directory file) file-ent)
X	      file-ent)))
X    (ange-ftp-real-file-symlink-p file)))
X
(defun ange-ftp-file-exists-p (path)
X  "Documented as original."
X  (setq path (expand-file-name path))
X  (if (ange-ftp-ftp-path path)
X      (if (ange-ftp-file-entry-p path)
X	  (let ((file-ent (ange-ftp-get-file-entry path)))
X	    (if (stringp file-ent)
X		(file-exists-p
X		 (ange-ftp-expand-symlink file-ent
X					  (file-name-directory
X					   (directory-file-name path))))
X	      t)))
X    (ange-ftp-real-file-exists-p path)))
X
(defun ange-ftp-file-directory-p (path)
X  "Documented as original."
X  (setq path (expand-file-name path))
X  (if (ange-ftp-ftp-path path)
X      ;; We do a file-name-as-directory on path here because some
X      ;; machines (VMS) use a .DIR to indicate the filename associated
X      ;; with a directory. This needs to be canonicalized.
X      (let ((file-ent (ange-ftp-get-file-entry
X		       (ange-ftp-file-name-as-directory path))))
X	(if (stringp file-ent)
X	    (file-directory-p
X	     (ange-ftp-expand-symlink file-ent
X				      (file-name-directory
X				       (directory-file-name path))))
X	  file-ent))
X    (ange-ftp-real-file-directory-p path)))
X
(defun ange-ftp-directory-files (directory &optional full match
X					   &rest v19-args)
X  "Documented as original."
X  (setq directory (expand-file-name directory))
X  (if (ange-ftp-ftp-path directory)
X      (progn
X	(ange-ftp-barf-if-not-directory directory)
X	(let ((tail (ange-ftp-hash-table-keys
X		     (ange-ftp-get-files directory)))
X	      files f)
X	  (setq directory (file-name-as-directory directory))
X	  (ange-ftp-save-match-data
X	    (while tail
X	      (setq f (car tail)
X		    tail (cdr tail))
X	      (if (or (not match) (string-match match f))
X		  (setq files
X			(cons (if full (concat directory f) f) files)))))
X	  (nreverse files)))
X    (apply 'ange-ftp-real-directory-files directory full match v19-args)))
X
(defun ange-ftp-file-attributes (file)
X  "Documented as original."
X  (setq file (expand-file-name file))
X  (let ((parsed (ange-ftp-ftp-path file)))
X    (if parsed
X	(let ((part (ange-ftp-get-file-part file))
X	      (files (ange-ftp-get-files (file-name-directory file))))
X	  (if (ange-ftp-hash-entry-exists-p part files)
X	      (let ((host (nth 0 parsed))
X		    (user (nth 1 parsed))
X		    (path (nth 2 parsed))
X		    (dirp (ange-ftp-get-hash-entry part files)))
X		(list (if (and (stringp dirp) (file-name-absolute-p dirp))
X			  (ange-ftp-expand-symlink dirp
X						   (file-name-directory file))
X			dirp)		;0 file type
X		      -1		;1 link count
X		      -1		;2 uid
X		      -1		;3 gid
X		      '(0 0)		;4 atime
X		      '(0 0)		;5 mtime
X		      '(0 0)		;6 ctime
X		      -1		;7 size
X		      (concat (if (stringp dirp) "l" (if dirp "d" "-"))
X			      "?????????") ;8 mode
X		      nil		;9 gid weird
X		      ;; Hack to give remote files a unique "inode number".
X		      ;; It's actually the sum of the characters in its name.
X		      (apply '+ (nconc (mapcar 'identity host)
X				       (mapcar 'identity user)
X				       (mapcar 'identity
X					       (directory-file-name path))))
X		      -1		;11 device number [v19 only]
X		      ))))
X      (ange-ftp-real-file-attributes file))))
X
(defun ange-ftp-file-writable-p (file)
X  "Documented as original."
X  (setq file (expand-file-name file))
X  (if (ange-ftp-ftp-path file)
X      (or (file-exists-p file)		;guess here for speed
X	  (file-directory-p (file-name-directory file)))
X    (ange-ftp-real-file-writable-p file)))
X
(defun ange-ftp-file-readable-p (file)
X  "Documented as original."
X  (setq file (expand-file-name file))
X  (if (ange-ftp-ftp-path file)
X      (file-exists-p file)
X    (ange-ftp-real-file-readable-p file)))
X
(defun ange-ftp-delete-file (file)
X  "Documented as original."
X  (interactive "fDelete file: ")
X  (setq file (expand-file-name file))
X  (let ((parsed (ange-ftp-ftp-path file)))
X    (if parsed
X	(let* ((host (nth 0 parsed))
X	       (user (nth 1 parsed))
X	       (path (ange-ftp-quote-string (nth 2 parsed)))
X	       (abbr (ange-ftp-abbreviate-filename file))
X	       (result (ange-ftp-send-cmd host user
X					  (list 'delete path)
X					  (format "Deleting %s" abbr))))
X	  (or (car result)
X	      (signal 'ftp-error
X		      (list
X		       "Removing old name"
X		       (format "FTP Error: \"%s\"" (cdr result))
X		       file)))
X	  (ange-ftp-delete-file-entry file))
X      (ange-ftp-real-delete-file file))))
X
(defun ange-ftp-verify-visited-file-modtime (buf)
X  "Documented as original."
X  (let ((name (buffer-file-name buf)))
X    (if (and (stringp name) (ange-ftp-ftp-path name))
X	t
X      (ange-ftp-real-verify-visited-file-modtime buf))))
X
(defun ange-ftp-backup-buffer ()
X  "Documented as original."
X  (let (parsed)
X    (if (and
X	 (listp ange-ftp-make-backup-files)
X	 (stringp buffer-file-name)
X	 (setq parsed (ange-ftp-ftp-path buffer-file-name))
X	 (or
X	  (null ange-ftp-make-backup-files)
X	  (not
X	   (memq
X	    (ange-ftp-host-type
X	     (car parsed))
X	    ange-ftp-make-backup-files))))
X	nil
X      (ange-ftp-real-backup-buffer))))
X
;;;; ------------------------------------------------------------
;;;; File copying support... totally re-written 6/24/92.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-barf-or-query-if-file-exists (absname querystring interactive)
X  (if (file-exists-p absname)
X      (if (not interactive)
X	  (signal 'file-already-exists (list absname))
X	(if (not (yes-or-no-p (format "File %s already exists; %s anyway? "
X				      absname querystring)))
X	    (signal 'file-already-exists (list absname))))))
X
;; async local copy commented out for now since I don't seem to get
;; the process sentinel called for some processes.
;;
;; (defun ange-ftp-copy-file-locally (filename newname ok-if-already-exists
;; 					    keep-date cont)
;;   "Kludge to copy a local file and call a continuation when the copy
;; finishes."
;;   ;; check to see if we can overwrite
;;   (if (or (not ok-if-already-exists)
;; 	  (numberp ok-if-already-exists))
;;       (ange-ftp-barf-or-query-if-file-exists newname "copy to it" 
;; 					     (numberp ok-if-already-exists)))
;;   (let ((proc (start-process " *copy*"
;; 			     (generate-new-buffer "*copy*")
;; 			     "cp"
;; 			     filename
;; 			     newname))
;; 	res)
;;     (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel))
;;     (process-kill-without-query proc)
;;     (save-excursion
;;       (set-buffer (process-buffer proc))
;;       (make-variable-buffer-local 'copy-cont)
;;       (setq copy-cont cont))))
;; 
;; (defun ange-ftp-copy-file-locally-sentinel (proc status)
;;   (save-excursion
;;     (set-buffer (process-buffer proc))
;;     (let ((cont copy-cont)
;; 	  (result (buffer-string)))
;;       (unwind-protect
;; 	  (if (and (string-equal status "finished\n")
;; 		   (zerop (length result)))
;; 	      (ange-ftp-call-cont cont t nil)
;; 	    (ange-ftp-call-cont cont
;; 				nil
;; 				(if (zerop (length result))
;; 				    (substring status 0 -1)
;; 				  (substring result 0 -1))))
;; 	(kill-buffer (current-buffer))))))
X
;; this is the extended version of ange-ftp-copy-file-internal that works
;; asyncronously if asked nicely.
(defun ange-ftp-copy-file-internal (filename newname ok-if-already-exists
X					     keep-date &optional msg cont nowait)
X  (setq filename (expand-file-name filename)
X	newname (expand-file-name newname))
X
X  ;; canonicalize newname if a directory.
X  (if (file-directory-p newname)
X      (setq newname (expand-file-name (file-name-nondirectory filename) newname)))
X
X  (let ((f-parsed (ange-ftp-ftp-path filename))
X	(t-parsed (ange-ftp-ftp-path newname)))
X
X    ;; local file to local file copy?
X    (if (and (not f-parsed) (not t-parsed))
X	(progn
X	  (ange-ftp-real-copy-file filename newname ok-if-already-exists
X				   keep-date)
X	  (if cont
X	      (ange-ftp-call-cont cont t "Copied locally")))
X      ;; one or both files are remote.
X      (let* ((f-host (and f-parsed (nth 0 f-parsed)))
X	     (f-user (and f-parsed (nth 1 f-parsed)))
X	     (f-path (and f-parsed (ange-ftp-quote-string (nth 2 f-parsed))))
X	     (f-abbr (ange-ftp-abbreviate-filename filename))
X	     (t-host (and t-parsed (nth 0 t-parsed)))
X	     (t-user (and t-parsed (nth 1 t-parsed)))
X	     (t-path (and t-parsed (ange-ftp-quote-string (nth 2 t-parsed))))
X	     (t-abbr (ange-ftp-abbreviate-filename newname filename))
X	     (binary (or (ange-ftp-binary-file filename)
X			 (ange-ftp-binary-file newname)))
X	     temp1
X	     temp2)
X
X	;; check to see if we can overwrite
X	(if (or (not ok-if-already-exists)
X		(numberp ok-if-already-exists))
X	    (ange-ftp-barf-or-query-if-file-exists newname "copy to it" 
X						   (numberp ok-if-already-exists)))
X
X	;; do the copying.
X	(if f-parsed
X	    
X	    ;; filename was remote.
X	    (progn
X	      (if (or (ange-ftp-use-gateway-p f-host)
X		      t-parsed)
X		  ;; have to use intermediate file if we are getting via
X		  ;; gateway machine or we are doing a remote to remote copy.
X		  (setq temp1 (ange-ftp-make-tmp-name f-host)))
X	      
X	      (if binary
X		  (ange-ftp-set-binary-mode f-host f-user))
X
X	      (ange-ftp-send-cmd
X	       f-host
X	       f-user
X	       (list 'get f-path (or temp1 newname))
X	       (or msg
X		   (if (and temp1 t-parsed)
X		       (format "Getting %s" f-abbr)
X		     (format "Copying %s to %s" f-abbr t-abbr)))
X	       (list (function ange-ftp-cf1)
X		     filename newname binary msg
X		     f-parsed f-host f-user f-path f-abbr
X		     t-parsed t-host t-user t-path t-abbr
X		     temp1 temp2 cont nowait)
X	       nowait))
X
X	  ;; filename wasn't remote.  newname must be remote.  call the
X	  ;; function which does the remainder of the copying work.
X	  (ange-ftp-cf1 t nil
X			filename newname binary msg
X			f-parsed f-host f-user f-path f-abbr
X			t-parsed t-host t-user t-path t-abbr
X			nil nil cont nowait))))))
X
;; next part of copying routine.
(defun ange-ftp-cf1 (result line
X			    filename newname binary msg
X			    f-parsed f-host f-user f-path f-abbr
X			    t-parsed t-host t-user t-path t-abbr
X			    temp1 temp2 cont nowait)
X  (if line
X      ;; filename must have been remote, and we must have just done a GET.
X      (unwind-protect
X	  (or result
X	      ;; GET failed for some reason.  Clean up and get out.
X	      (progn
X		(and temp1 (ange-ftp-del-tmp-name temp1))
X		(or cont
X		    (signal 'ftp-error (list "Opening input file"
X					     (format "FTP Error: \"%s\"" line)
X					     filename)))))
X	;; cleanup
X	(if binary
X	    (ange-ftp-set-ascii-mode f-host f-user))))
X
X  (if result
X      ;; We now have to copy either temp1 or filename to newname.
X      (if t-parsed
X      
X	  ;; newname was remote.
X	  (progn
X	    (if (ange-ftp-use-gateway-p t-host)
X		(setq temp2 (ange-ftp-make-tmp-name t-host)))
X	    
X	    ;; make sure data is moved into the right place for the
X	    ;; outgoing transfer.  gateway temporary files complicate
X	    ;; things nicely.
X	    (if temp1
X		(if temp2
X		    (if (string-equal temp1 temp2)
X			(setq temp1 nil)
X		      (ange-ftp-real-copy-file temp1 temp2 t))
X		  (setq temp2 temp1 temp1 nil))
X	      (if temp2
X		  (ange-ftp-real-copy-file filename temp2 t)))
X	    
X	    (if binary
X		(ange-ftp-set-binary-mode t-host t-user))
X
X	    ;; tell the process filter what size the file is.
X	    (let ((attr (file-attributes (or temp2 filename))))
X	      (if attr
X		  (ange-ftp-set-xfer-size t-host t-user (nth 7 attr))))
X
X	    (ange-ftp-send-cmd
X	     t-host
X	     t-user
X	     (list 'put (or temp2 filename) t-path)
X	     (or msg
X		 (if (and temp2 f-parsed)
X		     (format "Putting %s" newname)
X		   (format "Copying %s to %s" f-abbr t-abbr)))
X	     (list (function ange-ftp-cf2)
X		   newname t-host t-user binary temp1 temp2 cont)
X	     nowait))
X    
X	;; newname wasn't remote.
X	(ange-ftp-cf2 t nil newname t-host t-user binary temp1 temp2 cont))
X
X    ;; first copy failed, tell caller
X    (ange-ftp-call-cont cont result line)))
X
;; last part of copying routine.
(defun ange-ftp-cf2 (result line newname t-host t-user binary temp1 temp2 cont)
X  (unwind-protect
X      (if line
X	  ;; result from doing a local to remote copy.
X	  (unwind-protect
X	      (progn
X		(or result
X		    (or cont
X			(signal 'ftp-error
X				(list "Opening output file"
X				      (format "FTP Error: \"%s\"" line)
X				      newname))))
X		
X		(ange-ftp-add-file-entry newname))
X	    
X	    ;; cleanup.
X	    (if binary
X		(ange-ftp-set-ascii-mode t-host t-user)))
X	      
X	;; newname was local.
X	(if temp1
X	    (ange-ftp-real-copy-file temp1 newname t)))
X	  
X    ;; clean up
X    (and temp1 (ange-ftp-del-tmp-name temp1))
X    (and temp2 (ange-ftp-del-tmp-name temp2))
X    (ange-ftp-call-cont cont result line)))
X
(defun ange-ftp-copy-file (filename newname &optional ok-if-already-exists
X				    keep-date)
X  "Documented as original."
X  (interactive "fCopy file: \nFCopy %s to file: \np")
X  (ange-ftp-copy-file-internal filename
X			       newname
X			       ok-if-already-exists
X			       keep-date
X			       nil
X			       nil
X			       (interactive-p)))
X
;;;; ------------------------------------------------------------
;;;; File renaming support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-rename-remote-to-remote (filename newname f-parsed t-parsed
X						  binary)
X  "Rename remote file FILE to remote file NEWNAME."
X  (let ((f-host (nth 0 f-parsed))
X	(f-user (nth 1 f-parsed))
X	(t-host (nth 0 t-parsed))
X	(t-user (nth 1 t-parsed)))
X    (if (and (string-equal f-host t-host)
X	     (string-equal f-user t-user))
X	(let* ((f-path (ange-ftp-quote-string (nth 2 f-parsed)))
X	       (t-path (ange-ftp-quote-string (nth 2 t-parsed)))
X	       (cmd (list 'rename f-path t-path))
X	       (fabbr (ange-ftp-abbreviate-filename filename))
X	       (nabbr (ange-ftp-abbreviate-filename newname filename))
X	       (result (ange-ftp-send-cmd f-host f-user cmd
X					  (format "Renaming %s to %s"
X						  fabbr
X						  nabbr))))
X	  (or (car result)
X	      (signal 'ftp-error
X		      (list
X		       "Renaming"
X		       (format "FTP Error: \"%s\"" (cdr result))
X		       filename
X		       newname)))
X	  (ange-ftp-add-file-entry newname)
X	  (ange-ftp-delete-file-entry filename))
X      (ange-ftp-copy-file-internal filename newname t nil)
X      (delete-file filename))))
X
(defun ange-ftp-rename-local-to-remote (filename newname)
X  "Rename local FILE to remote file NEWNAME."
X  (let* ((fabbr (ange-ftp-abbreviate-filename filename))
X	 (nabbr (ange-ftp-abbreviate-filename newname filename))
X	 (msg (format "Renaming %s to %s" fabbr nabbr)))
X    (ange-ftp-copy-file-internal filename newname t nil msg)
X    (let (ange-ftp-process-verbose)
X      (delete-file filename))))
X
(defun ange-ftp-rename-remote-to-local (filename newname)
X  "Rename remote file FILE to local file NEWNAME."
X  (let* ((fabbr (ange-ftp-abbreviate-filename filename))
X	 (nabbr (ange-ftp-abbreviate-filename newname filename))
X	 (msg (format "Renaming %s to %s" fabbr nabbr)))
X    (ange-ftp-copy-file-internal filename newname t nil msg)
X    (let (ange-ftp-process-verbose)
X      (delete-file filename))))
X
(defun ange-ftp-rename-file (filename newname &optional ok-if-already-exists)
X  "Documented as original."
X  (interactive "fRename file: \nFRename %s to file: \np")
X  (setq filename (expand-file-name filename))
X  (setq newname (expand-file-name newname))
X  (let* ((f-parsed (ange-ftp-ftp-path filename))
X	 (t-parsed (ange-ftp-ftp-path newname))
X	 (binary (if (or f-parsed t-parsed) (ange-ftp-binary-file filename))))
X    (if (and (or f-parsed t-parsed)
X	     (or (not ok-if-already-exists)
X		 (numberp ok-if-already-exists)))
X	(ange-ftp-barf-or-query-if-file-exists
X	 newname
X	 "rename to it"
X	 (numberp ok-if-already-exists)))
X    (if f-parsed
X	(if t-parsed
X	    (ange-ftp-rename-remote-to-remote filename newname f-parsed
X					      t-parsed binary)
X	  (ange-ftp-rename-remote-to-local filename newname))
X      (if t-parsed
X	  (ange-ftp-rename-local-to-remote filename newname)
X	(ange-ftp-real-rename-file filename newname ok-if-already-exists)))))
X
;;;; ------------------------------------------------------------
;;;; Classic Dired support.
;;;; ------------------------------------------------------------
X
(defvar ange-ftp-dired-host-type nil
X  "The host type associated with a dired buffer. (buffer local)")
(make-variable-buffer-local 'ange-ftp-dired-host-type)
X
(defun ange-ftp-dired-readin (dirname buffer)
X  "Documented as original."
X  (let ((file (ange-ftp-abbreviate-filename dirname))
X	(parsed (ange-ftp-ftp-path dirname)))
X    (save-excursion
X      (ange-ftp-message "Reading directory %s..." file)
X      (set-buffer buffer)
X      (let ((buffer-read-only nil))
X	(widen)
X	(erase-buffer)
X	(setq dirname (expand-file-name dirname))
X	(if parsed
X	    (let ((host-type (ange-ftp-host-type (car parsed))))
X	      (setq ange-ftp-dired-host-type host-type)
X	      (insert (ange-ftp-ls dirname dired-listing-switches t)))
X	  (if (ange-ftp-real-file-directory-p dirname)
X	      (call-process "ls" nil buffer nil
X			    dired-listing-switches dirname)
X	    (let ((default-directory
X		    (ange-ftp-real-file-name-directory dirname)))
X	      (call-process
X	       shell-file-name nil buffer nil
X	       "-c" (concat
X		     "ls " dired-listing-switches " "
X		     (ange-ftp-real-file-name-nondirectory dirname))))))
X	(goto-char (point-min))
X	(while (not (eobp))
X	  (insert "  ")
X	  (forward-line 1))
X	(goto-char (point-min))))
X    (ange-ftp-message "Reading directory %s...done" file)))
X
(defun ange-ftp-dired-revert (&optional arg noconfirm)
X  "Documented as original."
X  (if (and dired-directory
X	   (ange-ftp-ftp-path (expand-file-name dired-directory)))
X      (setq ange-ftp-ls-cache-file nil))
X  (ange-ftp-real-dired-revert arg noconfirm))
X
;;;; ------------------------------------------------------------
;;;; Tree Dired support (ange & Sebastian Kremer)
;;;; ------------------------------------------------------------
X
(defvar ange-ftp-dired-re-exe-alist nil
X  "Association list of regexps \(strings\) which match file lines of
X executable files.")
X
(defvar ange-ftp-dired-re-dir-alist nil
X  "Association list of regexps \(strings\) which match file lines of
X subdirectories.")
X
(defvar ange-ftp-dired-insert-headerline-alist nil
X  "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
the function to be used by dired to insert the headerline of
the dired buffer.")
X
(defvar ange-ftp-dired-move-to-filename-alist nil
X  "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
the function to be used by dired to move to the beginning of a
filename.")
X
(defvar ange-ftp-dired-move-to-end-of-filename-alist nil
X  "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
the function to be used by dired to move to the end of a
filename.")
X
(defvar ange-ftp-dired-get-filename-alist nil
X  "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
the function to be used by dired to get a filename from the
current line.")
X
(defvar ange-ftp-dired-between-files-alist nil
X  "Association list of \(TYPE \. FUNC \) pairs, where FUNC is
the function to be used by dired to determine when the point
is on a line between files.")
X
(defvar ange-ftp-dired-ls-trim-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC is
a function which trims extraneous lines from a directory listing.")
X
(defvar ange-ftp-dired-clean-directory-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC is
a function which cleans out old versions of files in the OS TYPE.")
X
(defvar ange-ftp-dired-flag-backup-files-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC is
a functions which flags the backup files for deletion in the OS TYPE.")
X
(defvar ange-ftp-dired-backup-diff-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC diffs
a file with its backup. The backup file is determined according to
the OS TYPE.")
X
;; Could use dired-before-readin-hook here, instead of overloading
;; dired-readin. However, if people change this hook after ange-ftp
;; is loaded, they'll break things.
;; Also, why overload dired-readin rather than dired-mode?
;; Because I don't want to muck up virtual dired (see dired-x.el).
X
(defun ange-ftp-tree-dired-readin (dirname buffer)
X  "Documented as original."
X  (let ((parsed (ange-ftp-ftp-path dirname)))
X    (if parsed
X	(save-excursion
X	  (set-buffer buffer)
X	  (setq ange-ftp-dired-host-type
X		(ange-ftp-host-type (car parsed)))
X	  (and ange-ftp-dl-dir-regexp
X	       (eq ange-ftp-dired-host-type 'unix)
X	       (string-match ange-ftp-dl-dir-regexp dirname)
X	       (setq ange-ftp-dired-host-type 'unix:dl))
X	  (let ((eentry (assq ange-ftp-dired-host-type
X			      ange-ftp-dired-re-exe-alist))
X		(dentry (assq ange-ftp-dired-host-type
X			      ange-ftp-dired-re-dir-alist)))
X	    (if eentry
X		(set (make-local-variable 'dired-re-exe) (cdr eentry)))
X	    (if dentry
X		(set (make-local-variable 'dired-re-dir) (cdr dentry)))
X	    ;; No switches are sent to dumb hosts, so don't confuse dired.
X	    ;; I hope that dired doesn't get excited if it doesn't see the l
X	    ;; switch. If it does, then maybe fake things by setting this to
X	    ;; "-Al".
X	    (if (memq ange-ftp-dired-host-type ange-ftp-dumb-host-types)
X		(setq dired-actual-switches "-Al"))))))
X  (ange-ftp-real-dired-readin dirname buffer))
X
(defun ange-ftp-dired-insert-headerline (dir)
X  "Documented as original."
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-insert-headerline-alist)))
X	       'ange-ftp-real-dired-insert-headerline)
X	   dir))
X
(defun ange-ftp-dired-move-to-filename (&optional raise-error eol)
X  "Documented as original."
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-move-to-filename-alist)))
X	       'ange-ftp-real-dired-move-to-filename)
X	   raise-error eol))
X
(defun ange-ftp-dired-move-to-end-of-filename (&optional no-error)
X  "Documented as original."
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-move-to-end-of-filename-alist)))
X	       'ange-ftp-real-dired-move-to-end-of-filename)
X	   no-error))
X
(defun ange-ftp-dired-get-filename (&optional localp no-error-if-not-filep)
X  "Documented as original."
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-get-filename-alist)))
X	       'ange-ftp-real-dired-get-filename)
X	   localp no-error-if-not-filep))
X
(defun ange-ftp-dired-between-files ()
X  "Documented as original."
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-between-files-alist)))
X	       'ange-ftp-real-dired-between-files)))
X
(defvar ange-ftp-bob-version-alist nil
X  "Association list of pairs \( TYPE \. FUNC \), where FUNC is
a function to be used to bob the version number off of a filename
in OS TYPE.")
X
(defun ange-ftp-dired-find-file ()
X  "Documented as original."
X  (interactive)
X  (find-file (funcall (or (and ange-ftp-dired-host-type
X			       (cdr (assq ange-ftp-dired-host-type
X					  ange-ftp-bob-version-alist)))
X			  'identity)
X		      (dired-get-filename))))
X
;; Need the following functions for making filenames of compressed
;; files, because some OS's (unlike UNIX) do not allow a filename to
;; have two extensions.
X
(defvar ange-ftp-dired-compress-make-compressed-filename-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC converts a
filename to the filename of the associated compressed file.")
X
(defun ange-ftp-dired-compress-make-compressed-filename (name &optional reverse)
X  "Converts a filename to the filename of the associated compressed
file. With an optional reverse argument, the reverse conversion is done."
X  (let ((parsed (ange-ftp-ftp-path name))
X	conversion-func)
X    (if (and parsed
X	     (setq conversion-func
X		   (cdr (assq (ange-ftp-host-type (car parsed))
X			      ange-ftp-dired-compress-make-compressed-filename-alist))))
X	(funcall conversion-func name reverse)
X      (if reverse
X	  (if (string-match "\\.Z$" name)
X	      (substring name 0 (match-beginning 0))
X	    name)
X	(concat name ".Z")))))
X
(defun ange-ftp-dired-clean-directory (keep)
X  "Documented as original."
X  (interactive "P")
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-clean-directory-alist)))
X	       'ange-ftp-real-dired-clean-directory)
X	   keep))
X
(defun ange-ftp-dired-backup-diff (&optional switches)
X  "Documented as original."
X  (interactive (list (if (fboundp 'diff-read-switches)
X			 (diff-read-switches "Diff with switches: "))))
X  (funcall (or (and ange-ftp-dired-host-type
X		    (cdr (assq ange-ftp-dired-host-type
X			       ange-ftp-dired-backup-diff-alist)))
X	       'ange-ftp-real-dired-backup-diff)
X	   switches))
X
X
(defun ange-ftp-dired-fixup-subdirs (start file)
X  "Turn each subdir name into a valid ange-ftp filename."
X
X  ;; We haven't indented the listing yet.
X  ;; Must be careful about filelines ending in a colon: exclude spaces!
X  (let ((subdir-regexp "^\\([^ \n\r]+\\)\\(:\\)[\n\r]"))
X    (save-restriction
X      (save-excursion
X	(narrow-to-region start (point))
X	(goto-char start)
X	(while (re-search-forward subdir-regexp nil t)
X	  (goto-char (match-beginning 1))
X	  (let ((name (buffer-substring (point)
X					(match-end 1))))
X	    (delete-region (point) (match-end 1))
X	    (insert (ange-ftp-replace-path-component
X		     file
X		     name))))))))
X
(defun ange-ftp-dired-ls (file switches &optional wildcard full-directory-p)
X  "Documented as original."
X  (let ((parsed (ange-ftp-ftp-path file)))
X    (if parsed
X	(let* ((pt (point))
X	       (path (nth 2 parsed))
X	       (host-type (ange-ftp-host-type (car parsed)))
X	       (dumb (memq host-type ange-ftp-dumb-host-types))
X	       trim-func case-fold-search)
X	  ;; Make sure that case-fold-search is nil
X	  ;; so that we can look at the switches.
X	  (if wildcard
X	      (if (not (memq host-type '(unix dumb-unix)))
X		  (insert (ange-ftp-ls file switches nil))
X		;; Prevent ls from inserting subdirs, as the subdir header
X		;; line format would be wrong (it would have no "/user@host:"
X		;; prefix)
X		(insert (ange-ftp-ls file (concat switches "d") nil))
X
X		;; Quoting the path part of the file name seems to be a good
X		;; idea (using dired.el's shell-quote function), but ftpd
X		;; always globs ls args before passing them to /bin/ls or even
X		;; doing the ls formatting itself.  --> So wildcard characters
X		;; in FILE lose.  Sigh...
X
X		;; When using wildcards, some ftpd's put the whole directory
X		;; name in front of each filename.  Walk down the listing
X		;; generated and remove this stuff.
X		(let ((dir (ange-ftp-real-file-name-directory path)))
X		  (if dir
X		      (let ((dirq (regexp-quote dir)))
X			(save-restriction
X			  (save-excursion
X			    (narrow-to-region pt (point))
X			    (goto-char pt)
X			    (while (not (eobp))
X			      (if (dired-move-to-filename)
X				  (if (re-search-forward dirq nil t)
X				      (replace-match "")))
X			      (forward-line 1))))))))
X
X               ;;;;;;;;;;;;;;;;;;;;;;;;;;
X               ;; Big issue here Andy! ;;
X	       ;;;;;;;;;;;;;;;;;;;;;;;;;;
X	       ;; In tree dired V5.245 Sebastian has used the following
X	       ;; trick to resolve symbolic links to directories. This causes
X	       ;; havoc with ange-ftp, because ange-ftp expands dots, with
X	       ;; expand-file-name before it sends them. This means that this
X	       ;; trick currently fails for remote SysV machines. But worse,
X	       ;; /vms:/DEV:/FOO/. expands to /vms:/DEV:/FOO, which converts
X	       ;; to DEV:FOO and not DEV:[FOO]. i.e it is only in UNIX that
X	       ;; we can play fast and loose with the difference between
X	       ;; directory names and their associated filenames.
X	       ;; My temporary fix is to knock Sebastian's dot off.
X	       ;; Maybe things can be made real clever in
X	       ;; the future, so that Sebastian can have his way with remote
X	       ;; SysV machines.
X	       ;; Sebastian in dired-readin-insert says:
X
X	          ;; On SysV derived system, symbolic links to
X		  ;; directories are not resolved, while on BSD
X		  ;; derived it suffices to let DIRNAME end in slash.
X		  ;; We always let it end in "/." since it does no
X		  ;; harm on BSD and makes Dired work on such links on
X		  ;; SysV.
X
X	    (if (string-match "/\\.$" path)
X		(setq
X		 file
X		 (ange-ftp-replace-path-component
X		  file (substring path 0 -1))))
X	    (if (string-match "R" switches)
X		(progn
X		  (insert (ange-ftp-ls file switches nil))
X		  ;; fix up the subdirectory names in the recursive
X		  ;; listing.
X		  (ange-ftp-dired-fixup-subdirs pt file))
X	      (insert
X	       (ange-ftp-ls file
X			    switches
X			    (and (or dumb (string-match "[aA]" switches))
X				 full-directory-p))))
X	    (if (and (null full-directory-p)
X		     (setq trim-func
X			   (cdr (assq host-type
X				      ange-ftp-dired-ls-trim-alist))))
X		;; If full-directory-p and wild-card are null, then only one
X		;; line per file must be inserted.
X		;; Some OS's (like VMS) insert other crap. Clean it out.
X		(save-restriction
X		  (narrow-to-region pt (point))
X		  (funcall trim-func)))))
X      (ange-ftp-real-dired-ls file switches wildcard full-directory-p))))
X
(defvar ange-ftp-remote-shell-file-name
X  (if (memq system-type '(hpux usg-unix-v)) ; hope that's right
X      "remsh"
X    "rsh")
X  "Remote shell used by ange-ftp.")
X
(defun ange-ftp-dired-run-shell-command (command &optional in-background)
X  "Documented as original."
X  (let* ((parsed (ange-ftp-ftp-path default-directory))
X	 (host (nth 0 parsed))
X	 (user (nth 1 parsed))
X	 (path (nth 2 parsed)))
X    (if (not parsed)
X	(ange-ftp-real-dired-run-shell-command command in-background)
X      (if (> (length path) 0)		; else it's $HOME
X	  (setq command (concat "cd " path "; " command)))
X      (setq command
X	    (format  "%s %s \"%s\""	; remsh -l USER does not work well
X					; on a hp-ux machine I tried
X		     ange-ftp-remote-shell-file-name host command))
X      (ange-ftp-message "Remote command '%s' ..." command)
X      ;; Cannot call ange-ftp-real-dired-run-shell-command here as it
X      ;; would prepend "cd default-directory" --- which bombs because
X      ;; default-directory is in ange-ftp syntax for remote path names.
X      (if in-background
X	  (comint::background command)
X	(shell-command command)))))
X
(defun ange-ftp-make-directory (dir)
X  "Documented as original."
X  (interactive (list (expand-file-name (read-file-name "Make directory: "))))
X  (if (file-exists-p dir)
X      (error "Cannot make directory %s: file already exists" dir)
X    (let ((parsed (ange-ftp-ftp-path dir)))
X      (if parsed
X	  (let* ((host (nth 0 parsed))
X		 (user (nth 1 parsed))
X		 ;; Some ftp's on unix machines (at least on Suns)
X		 ;; insist that mkdir take a filename, and not a
X		 ;; directory-name name as an arg. Argh!! This is a bug.
X		 ;; Non-unix machines will probably always insist
X		 ;; that mkdir takes a directory-name as an arg
X		 ;; (as the ftp man page says it should).
X		 (path (ange-ftp-quote-string
X			(if (eq (ange-ftp-host-type host) 'unix)
X			    (ange-ftp-real-directory-file-name (nth 2 parsed))
X			  (ange-ftp-real-file-name-as-directory
X			   (nth 2 parsed)))))
X		 (abbr (ange-ftp-abbreviate-filename dir))
X		 (result (ange-ftp-send-cmd host user
X					    (list 'mkdir path)
X					    (format "Making directory %s"
X						    abbr))))
X	    (or (car result)
X		(ange-ftp-error host user
X				(format "Could not make directory %s: %s"
X					dir
X					(cdr result))))
X	    (ange-ftp-add-file-entry dir t))
X	(ange-ftp-real-make-directory dir)))))
X
(defun ange-ftp-remove-directory (dir)
X  "Documented as original."
X  (interactive 
X   (list (expand-file-name (read-file-name "Remove directory: "
X					   nil nil 'confirm)))) 
X  (if (file-directory-p dir)
X      (let ((parsed (ange-ftp-ftp-path dir)))
X	(if parsed
X	    (let* ((host (nth 0 parsed))
X		   (user (nth 1 parsed))
X		   ;; Some ftp's on unix machines (at least on Suns)
X		   ;; insist that rmdir take a filename, and not a
X		   ;; directory-name name as an arg. Argh!! This is a bug.
X		   ;; Non-unix machines will probably always insist
X		   ;; that rmdir takes a directory-name as an arg
X		   ;; (as the ftp man page says it should).
X		   (path (ange-ftp-quote-string
X			  (if (eq (ange-ftp-host-type host) 'unix)
X			      (ange-ftp-real-directory-file-name
X			       (nth 2 parsed))
X			    (ange-ftp-real-file-name-as-directory
X			     (nth 2 parsed)))))
X		  (abbr (ange-ftp-abbreviate-filename dir))
X		  (result (ange-ftp-send-cmd host user
X					     (list 'rmdir path)
X					     (format "Removing directory %s"
X						     abbr))))
X	      (or (car result)
X		  (ange-ftp-error host user
X				  (format "Could not remove directory %s: %s"
X					  dir
X					  (cdr result))))
X	      (ange-ftp-delete-file-entry dir t))
X	  (ange-ftp-real-remove-directory dir)))
X    (error "Not a directory: %s" dir)))
X
(defun ange-ftp-diff (fn1 fn2 &optional switches)
X  "Documented as original."
X  (interactive (diff-read-args "Diff: " "Diff %s with: "
X			       "Diff with switches: "))
X  (or (and (stringp fn1)
X	   (stringp fn2))
X      (error  "diff: arguments must be strings: %s %s" fn1 fn2))
X  (or switches
X      (setq switches (if (stringp diff-switches)
X			 diff-switches
X		       (if (listp diff-switches)
X			   (mapconcat 'identity diff-switches " ")
X			 ""))))
X  (let* ((fn1 (expand-file-name fn1))
X	 (fn2 (expand-file-name fn2))
X	 (pa1 (ange-ftp-ftp-path fn1))
X	 (pa2 (ange-ftp-ftp-path fn2)))
X    (if (or pa1 pa2)
X	(let* ((tmp1 (and pa1 (ange-ftp-make-tmp-name (car pa1))))
X	       (tmp2 (and pa2 (ange-ftp-make-tmp-name (car pa2))))
X	       (bin1 (and pa1 (ange-ftp-binary-file fn1)))
X	       (bin2 (and pa2 (ange-ftp-binary-file fn2)))
X	       (dir1 (file-directory-p fn1))
X	       (dir2 (file-directory-p fn2))
X	       (old-dir default-directory)
X	       (default-directory "/tmp")) ;fool FTP-smart compile.el
X	  (unwind-protect
X	      (progn
X		(if (and dir1 dir2)
X		    (error "can't compare remote directories"))
X		(if dir1
X		    (setq fn1 (expand-file-name (file-name-nondirectory fn2)
X						fn1)
X			  pa1 (ange-ftp-ftp-path fn1)
X			  bin1 (ange-ftp-binary-file fn1)))
X		(if dir2
X		    (setq fn2 (expand-file-name (file-name-nondirectory fn1)
X						fn2)
X			  pa2 (ange-ftp-ftp-path fn2)
X			  bin2 (ange-ftp-binary-file fn2)))
X		(and pa1 (ange-ftp-copy-file-internal fn1 tmp1 t nil
X				   (format "Getting %s" fn1)))
X		(and pa2 (ange-ftp-copy-file-internal fn2 tmp2 t nil
X				   (format "Getting %s" fn2)))
X		(and ange-ftp-process-verbose
X		     (ange-ftp-message "doing diff..."))
X		(sit-for 0)
X		(ange-ftp-real-diff (or tmp1 fn1) (or tmp2 fn2) switches)
X		(cond ((boundp 'compilation-process)
X		       (while (and compilation-process
X				   (eq (process-status compilation-process)
X				       'run))
X			 (accept-process-output compilation-process)))
X		      ((boundp 'compilation-last-buffer)
X		       (while (and compilation-last-buffer
X				   (buffer-name compilation-last-buffer)
X				   (get-buffer-process
X				    compilation-last-buffer)
X				   (eq (process-status
X					(get-buffer-process
X					 compilation-last-buffer))
X				       'run))
X			 (accept-process-output))))
X		(and ange-ftp-process-verbose
X		     (ange-ftp-message "doing diff...done"))
X		(save-excursion
X		  (set-buffer (get-buffer-create "*compilation*"))
X
X		  ;; replace the default directory that we munged earlier.
SHAR_EOF
true || echo 'restore of ange-ftp.el failed'
fi
echo 'End of part 4, continue with part 5'
echo 5 > _shar_seq_.tmp
exit 0
Xref: sparky gnu.emacs.sources:617 alt.mud.tiny:8