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

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

---- Cut Here and feed the following to sh ----
#!/bin/sh
# this is ange-ftp.05 (part 5 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" != 5; 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		  (goto-char (point-min))
X		  (if (search-forward (concat "cd " default-directory) nil t)
X		      (replace-match (concat "cd " old-dir)))
X		  (setq default-directory old-dir)
X
X		  ;; massage the diff output, replacing the temporary file-
X		  ;; names with their original names.
X		  (if tmp1
X		      (let ((q1 (shell-quote tmp1)))
X			(goto-char (point-min))
X			(while (search-forward q1 nil t)
X			  (replace-match fn1))))
X		  (if tmp2
X		      (let ((q2 (shell-quote tmp2)))
X			(goto-char (point-min))
X			(while (search-forward q2 nil t)
X			  (replace-match fn2))))))
X	    (and tmp1 (ange-ftp-del-tmp-name tmp1))
X	    (and tmp2 (ange-ftp-del-tmp-name tmp2))))
X      (ange-ftp-real-diff fn1 fn2 switches))))
X	    
(defun ange-ftp-dired-call-process (program discard &rest arguments)
X  "Documented as original."
X  ;; PROGRAM is always one of those below in the cond in dired.el.
X  ;; The ARGUMENTS are (nearly) always files.
X  (if (ange-ftp-ftp-path default-directory)
X      ;; Can't use ange-ftp-dired-host-type here because the current
X      ;; buffer is *dired-check-process output*
X      (condition-case oops
X	  (cond ((equal "compress" program)
X		 (ange-ftp-call-compress arguments))
X		((equal "uncompress" program)
X		 (ange-ftp-call-uncompress arguments))
X		((equal "chmod" program)
X		 (ange-ftp-call-chmod arguments))
X		;; ((equal "chgrp" program))
X		;; ((equal dired-chown-program program))
X		(t (error "Unknown remote command: %s" program)))
X	(ftp-error (insert (format "%s: %s, %s\n"
X				    (nth 1 oops)
X				    (nth 2 oops)
X				    (nth 3 oops))))
X	(error (insert (format "%s\n" (nth 1 oops)))))
X    (apply 'call-process program nil (not discard) nil arguments)))
X
X
(defun ange-ftp-call-compress (args)
X  "Perform a compress command on a remote file.
Works by taking a copy of the file, compressing it and copying the file
back."
X  (if (or (not (= (length args) 2))
X	  (not (string-equal "-f" (car args))))
X      (error
X       "ange-ftp-call-compress: missing -f flag and/or missing filename: %s"
X       args))
X  (let* ((file (nth 1 args))
X	 (parsed (ange-ftp-ftp-path file))
X	 (tmp1 (ange-ftp-make-tmp-name (car parsed)))
X	 (tmp2 (ange-ftp-make-tmp-name (car parsed)))
X	 (abbr (ange-ftp-abbreviate-filename file))
X	 (nfile (ange-ftp-dired-compress-make-compressed-filename file))
X	 (nabbr (ange-ftp-abbreviate-filename nfile))
X	 (msg1 (format "Getting %s" abbr))
X	 (msg2 (format "Putting %s" nabbr)))
X    (unwind-protect
X	(progn
X	  (ange-ftp-copy-file-internal file tmp1 t nil msg1)
X	  (and ange-ftp-process-verbose
X	       (ange-ftp-message "Compressing %s..." abbr))
X	  (call-process-region (point)
X			       (point)
X			       shell-file-name
X			       nil
X			       t
X			       nil
X			       "-c"
X			       (format "compress -f -c < %s > %s" tmp1 tmp2))
X	  (and ange-ftp-process-verbose
X	       (ange-ftp-message "Compressing %s...done" abbr))
X	  (if (zerop (buffer-size))
X	      (progn
X		(let (ange-ftp-process-verbose)
X		  (delete-file file))
X		(ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
X      (ange-ftp-del-tmp-name tmp1)
X      (ange-ftp-del-tmp-name tmp2))))
X    
(defun ange-ftp-call-uncompress (args)
X  "Perform an uncompress command on a remote file.
Works by taking a copy of the file, uncompressing it and copying the file
back."
X  (if (not (= (length args) 1))
X      (error "ange-ftp-call-uncompress: missing filename: %s" args))
X  (let* ((file (car args))
X	 (parsed (ange-ftp-ftp-path file))
X	 (tmp1 (ange-ftp-make-tmp-name (car parsed)))
X	 (tmp2 (ange-ftp-make-tmp-name (car parsed)))
X	 (abbr (ange-ftp-abbreviate-filename file))
X	 (nfile (ange-ftp-dired-compress-make-compressed-filename file 'reverse))
X	 (nabbr (ange-ftp-abbreviate-filename nfile))
X	 (msg1 (format "Getting %s" abbr))
X	 (msg2 (format "Putting %s" nabbr))
;;	 ;; Cheap hack because of problems with binary file transfers from
;;	 ;; VMS hosts.
;;	 (gbinary (not (eq 'vms (ange-ftp-host-type (car parsed)))))
X	 )
X    (unwind-protect
X	(progn
X	  (ange-ftp-copy-file-internal file tmp1 t nil msg1)
X	  (and ange-ftp-process-verbose
X	       (ange-ftp-message "Uncompressing %s..." abbr))
X	  (call-process-region (point)
X			       (point)
X			       shell-file-name
X			       nil
X			       t
X			       nil
X			       "-c"
X			       (format "uncompress -c < %s > %s" tmp1 tmp2))
X	  (and ange-ftp-process-verbose
X	       (ange-ftp-message "Uncompressing %s...done" abbr))
X	  (if (zerop (buffer-size))
X	      (progn
X		(let (ange-ftp-process-verbose)
X		  (delete-file file))
X		(ange-ftp-copy-file-internal tmp2 nfile t nil msg2))))
X      (ange-ftp-del-tmp-name tmp1)
X      (ange-ftp-del-tmp-name tmp2))))
X
(defun ange-ftp-call-chmod (args)
X  (if (< (length args) 2)
X      (error "ange-ftp-call-chmod: missing mode and/or filename: %s" args))
X  (let ((mode (car args)))
X    (mapcar
X     (function
X      (lambda (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 'chmod mode path)
X						(format "doing chmod %s"
X							abbr))))
X		(or (car result)
X		    (ange-ftp-error host user
X				    (format "chmod: %s: \"%s\""
X					    file 
X					    (cdr result)))))))))
X     (cdr args)))
X  (setq ange-ftp-ls-cache-file nil))	;stop confusing dired
X
;; Need to abstract the way dired computes the names of compressed files.
;; I feel badly about these two overloads.
X
(defun ange-ftp-dired-compress ()
X  ;; Compress current file.  Return nil for success, offending filename else.
X  (let* (buffer-read-only
X	 (from-file (dired-get-filename))
X	 (to-file (ange-ftp-dired-compress-make-compressed-filename from-file)))
X    (cond ((save-excursion (beginning-of-line)
X			   (looking-at dired-re-sym))
X	   (dired-log (concat "Attempt to compress a symbolic link:\n"
X			      from-file))
X	   (dired-make-relative from-file))
X	  ((dired-check-process (concat "Compressing " from-file)
X				"compress" "-f" from-file)
X	   ;; errors from the process are already logged by
X	   ;; dired-check-process
X	   (dired-make-relative from-file))
X	  (t
X	 (dired-update-file-line to-file)
X	 nil))))
X
(defun ange-ftp-dired-uncompress ()
X  ;; Uncompress current file.  Return nil for success,
X  ;; offending filename else.
X  (let* (buffer-read-only
X	 (from-file (dired-get-filename))
X	 (to-file (ange-ftp-dired-compress-make-compressed-filename from-file 'reverse)))
X    (if (dired-check-process (concat "Uncompressing " from-file)
X			     "uncompress" from-file)
X	(dired-make-relative from-file)
X      (dired-update-file-line to-file)
X      nil)))
X
(defun ange-ftp-dired-flag-backup-files (&optional unflag-p)
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-flag-backup-files-alist)))
X	       'ange-ftp-real-dired-flag-backup-files)
X	   unflag-p))
X
;;; ------------------------------------------------------------
;;; Noddy support for async copy-file within dired.
;;; ------------------------------------------------------------
X
(defun ange-ftp-dired-copy-file (from to ok-flag &optional cont nowait)
X  "Documented as original."
X  (dired-handle-overwrite to)
X  (ange-ftp-copy-file-internal from to ok-flag dired-copy-preserve-time nil
X			       cont nowait))
X
(defun ange-ftp-dired-do-create-files (op-symbol file-creator operation arg
X						 &optional marker-char op1
X						 how-to)
X  "Documented as original."
X  ;; we need to let ange-ftp-dired-create-files know that we indirectly
X  ;; called it rather than somebody else.
X  (let ((ange-ftp-dired-do-create-files t)) ; tell who caller is
X    (ange-ftp-real-dired-do-create-files op-symbol file-creator operation
X					 arg marker-char op1 how-to)))
X
(defun ange-ftp-dired-create-files (file-creator operation fn-list name-constructor
X						 &optional marker-char)
X  "Documented as original."
X  (if (and (boundp 'ange-ftp-dired-do-create-files)
X	   ;; called from ange-ftp-dired-do-create-files?
X	   ange-ftp-dired-do-create-files
X	   ;; any files worth copying?
X	   fn-list
X	   ;; we only support async copy-file at the mo.
X	   (eq file-creator 'dired-copy-file)
X	   ;; it is only worth calling the alternative function for remote files
X	   ;; as we tie ourself in recursive knots otherwise.
X	   (or (ange-ftp-ftp-path (car fn-list))
X	       ;; we can only call the name constructor for dired-do-create-files
X	       ;; since the one for regexps starts prompting here, there and
X	       ;; everywhere.
X	       (ange-ftp-ftp-path (funcall name-constructor (car fn-list)))))
X      ;; use the process-filter driven routine rather than the iterative one.
X      (ange-ftp-dcf-1 file-creator
X   		      operation
X 		      fn-list
X 		      name-constructor
X 		      (and (boundp 'target) target)	;dynamically bound
X 		      marker-char
X 		      (current-buffer)
X 		      nil	;overwrite-query
X 		      nil	;overwrite-backup-query
X 		      nil	;failures
X 		      nil	;skipped
X 		      0		;success-count
X 		      (length fn-list) ;total
X 		      )
X    ;; normal case... use the interative routine... much cheaper.
X    (ange-ftp-real-dired-create-files file-creator operation fn-list
X				      name-constructor marker-char)))
X
(defun ange-ftp-dcf-1 (file-creator operation fn-list name-constructor
X		       target marker-char buffer overwrite-query 
X		       overwrite-backup-query failures skipped
X		       success-count total)
X  (let ((old-buf (current-buffer)))
X    (unwind-protect
X	(progn
X	  (set-buffer buffer)
X	  (if (null fn-list)
X	      (ange-ftp-dcf-3 failures operation total skipped
X			      success-count buffer)
X	    
X	    (let* ((from (car fn-list))
X		   (to (funcall name-constructor from)))
X	      (if (equal to from)
X		  (progn
X		    (setq to nil)
X		    (dired-log "Cannot %s to same file: %s\n"
X			       (downcase operation) from)))
X	      (if (not to)
X		  (ange-ftp-dcf-1 file-creator
X				  operation
X				  (cdr fn-list)
X				  name-constructor
X				  target
X				  marker-char
X				  buffer
X				  overwrite-query
X				  overwrite-backup-query
X				  failures
X				  (cons (dired-make-relative from) skipped)
X				  success-count
X				  total)
X		(let* ((overwrite (file-exists-p to))
X		       (overwrite-confirmed	; for dired-handle-overwrite
X			(and overwrite
X			     (let ((help-form '(format "\
Type SPC or `y' to overwrite file `%s',
DEL or `n' to skip to next,
ESC or `q' to not overwrite any of the remaining files,
`!' to overwrite all remaining files with no more questions." to)))
X			       (dired-query 'overwrite-query
X					    "Overwrite `%s'?" to))))
X		       ;; must determine if FROM is marked before file-creator
X		       ;; gets a chance to delete it (in case of a move).
X		       (actual-marker-char
X			(cond  ((integerp marker-char) marker-char)
X			       (marker-char (dired-file-marker from)) ; slow
X			       (t nil))))
X		  (condition-case err
X		      (funcall file-creator from to overwrite-confirmed
X			       (list (function ange-ftp-dcf-2)
X				     nil	;err
X				     file-creator operation fn-list
X				     name-constructor
X				     target
X				     marker-char actual-marker-char
X				     buffer to from
X				     overwrite
X				     overwrite-confirmed
X				     overwrite-query 
X				     overwrite-backup-query
X				     failures skipped success-count
X				     total)
X			       t)
X		    (file-error		; FILE-CREATOR aborted
X		     (ange-ftp-dcf-2 nil ;result
X				     nil ;line
X				     err
X				     file-creator operation fn-list
X				     name-constructor
X				     target
X				     marker-char actual-marker-char
X				     buffer to from
X				     overwrite
X				     overwrite-confirmed
X				     overwrite-query 
X				     overwrite-backup-query
X				     failures skipped success-count
X				     total))))))))
X      (set-buffer old-buf))))
X
(defun ange-ftp-dcf-2 (result line err
X			      file-creator operation fn-list
X			      name-constructor
X			      target
X			      marker-char actual-marker-char
X			      buffer to from
X			      overwrite
X			      overwrite-confirmed
X			      overwrite-query 
X			      overwrite-backup-query
X			      failures skipped success-count
X			      total)
X  (let ((old-buf (current-buffer)))
X    (unwind-protect
X	(progn
X	  (set-buffer buffer)
X	  (if (or err (not result))
X	      (progn
X		(setq failures (cons (dired-make-relative from) failures))
X		(dired-log "%s `%s' to `%s' failed:\n%s\n"
X			   operation from to (or err line)))
X	    (if overwrite
X		;; If we get here, file-creator hasn't been aborted
X		;; and the old entry (if any) has to be deleted
X		;; before adding the new entry.
X		(dired-remove-file to))
X	    (setq success-count (1+ success-count))
X	    (message "%s: %d of %d" operation success-count total)
X	    (dired-add-file to actual-marker-char))
X	  
X	  (ange-ftp-dcf-1 file-creator operation (cdr fn-list)
X			  name-constructor
X			  target
X			  marker-char
X			  buffer
X			  overwrite-query 
X			  overwrite-backup-query
X			  failures skipped success-count
X			  total))
X      (set-buffer old-buf))))
X
(defun ange-ftp-dcf-3 (failures operation total skipped success-count
X				buffer)
X  (let ((old-buf (current-buffer)))
X    (unwind-protect
X	(progn
X	  (set-buffer buffer)
X	  (cond
X	   (failures
X	    (dired-log-summary
X	     (message "%s failed for %d of %d file%s %s"
X		      operation (length failures) total
X		      (dired-plural-s total) failures)))
X	   (skipped
X	    (dired-log-summary
X	     (message "%s: %d of %d file%s skipped %s"
X		      operation (length skipped) total
X		      (dired-plural-s total) skipped)))
X	   (t
X	    (message "%s: %s file%s."
X		     operation success-count (dired-plural-s success-count))))
X	  (dired-move-to-filename))
X      (set-buffer old-buf))))
X
;;;; -----------------------------------------------
;;;; Unix Descriptive Listing (dl) Support
;;;; -----------------------------------------------
X
(defconst ange-ftp-dired-dl-re-dir
X  "^. [^ /]+/[ \n]"
X  "Regular expression to use to search for dl directories.")
X
(or (assq 'unix:dl ange-ftp-dired-re-dir-alist)
X    (setq ange-ftp-dired-re-dir-alist
X	  (cons (cons 'unix:dl  ange-ftp-dired-dl-re-dir)
X		ange-ftp-dired-re-dir-alist)))
X
(defun ange-ftp-dired-dl-move-to-filename (&optional raise-error eol)
X  "In dired, move to the first character of the filename on this line."
X  ;; This is the Unix dl version.
X  (or eol (setq eol (progn (end-of-line) (point))))
X  (let (case-fold-search)
X    (beginning-of-line)
X    (if (looking-at ". [^ ]+ +\\([0-9]+\\|-\\|=\\) ")
X	(goto-char (+ (point) 2))
X      (if raise-error
X	  (error "No file on this line")
X	nil))))
X
(or (assq 'unix:dl ange-ftp-dired-move-to-filename-alist)
X    (setq ange-ftp-dired-move-to-filename-alist
X	  (cons '(unix:dl . ange-ftp-dired-dl-move-to-filename)
X		ange-ftp-dired-move-to-filename-alist)))
X
(defun ange-ftp-dired-dl-move-to-end-of-filename (&optional no-error eol)
X  ;; Assumes point is at beginning of filename.
X  ;; So, it should be called only after (dired-move-to-filename t).
X  ;; On failure, signals an error or returns nil.
X  ;; This is the Unix dl version.
X  (let ((opoint (point))
X	case-fold-search hidden)
X    (or eol (setq eol (save-excursion (end-of-line) (point))))
X    (setq hidden (and selective-display
X		       (save-excursion
X			 (search-forward "\r" eol t))))
X    (if hidden
X	(if no-error
X	    nil
X	  (error
X	   (substitute-command-keys
X	    "File line is hidden, type \\[dired-hide-subdir] to unhide")))
X      (skip-chars-forward "^ /" eol)
X      (if (eq opoint (point))
X	  (if no-error
X	      nil
X	    (error "No file on this line"))
X	(point)))))
X
(or (assq 'unix:dl ange-ftp-dired-move-to-end-of-filename-alist)
X    (setq ange-ftp-dired-move-to-end-of-filename-alist
X	  (cons '(unix:dl . ange-ftp-dired-dl-move-to-end-of-filename)
X		ange-ftp-dired-move-to-end-of-filename-alist)))
X
;;;; ------------------------------------------------------------
;;;; File name completion support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-file-entry-active-p (sym)
X  "If the file entry is a symlink, returns whether the file pointed to exists.
Note that DIR is dynamically bound."
X  (let ((val (get sym 'val)))
X    (or (not (stringp val))
X	(file-exists-p (ange-ftp-expand-symlink val dir)))))
X
(defun ange-ftp-file-entry-not-ignored-p (sym)
X  "If the file entry is not a directory (nor a symlink pointing to a directory)
returns whether the file (or file pointed to by the symlink) is ignored
by completion-ignored-extensions.
Note that DIR and COMPLETION-IGNORED-PATTERN are dynamically bound."
X  (let ((val (get sym 'val))
X	(symname (symbol-name sym)))
X    (if (stringp val)
X	(let ((file (ange-ftp-expand-symlink val dir)))
X	  (or (file-directory-p file)
X	      (and (file-exists-p file)
X		   (not (string-match completion-ignored-pattern
X				      symname)))))
X      (or val ; is a directory name
X	  (not (string-match completion-ignored-pattern symname))))))
X
(defun ange-ftp-file-name-all-completions (file dir)
X  "Documented as original."
X  (setq dir (expand-file-name dir))
X  (if (ange-ftp-ftp-path dir)
X      (progn
X	(ange-ftp-barf-if-not-directory dir)
X	(setq dir (ange-ftp-real-file-name-as-directory dir))
X	(let* ((tbl (ange-ftp-get-files dir))
X	       (completions
X		(all-completions file tbl
X				 (function ange-ftp-file-entry-active-p))))
X	  
X	  ;; see whether each matching file is a directory or not...
X	  (mapcar
X	   (function
X	    (lambda (file)
X	      (let ((ent (ange-ftp-get-hash-entry file tbl)))
X		(if (and ent
X			 (or (not (stringp ent))
X			     (file-directory-p
X			      (ange-ftp-expand-symlink ent dir))))
X		    (concat file "/")
X		  file))))
X	   completions)))
X	
X    (if (string-equal "/" dir)
X	(nconc (all-completions file (ange-ftp-generate-root-prefixes))
X	       (ange-ftp-real-file-name-all-completions file dir))
X      (ange-ftp-real-file-name-all-completions file dir))))
X
(defun ange-ftp-file-name-completion (file dir)
X  "Documented as original."
X  (setq dir (expand-file-name dir))
X  (if (ange-ftp-ftp-path dir)
X      (progn
X	(ange-ftp-barf-if-not-directory dir)
X	(if (equal file "")
X	    ""
X	  (setq dir (ange-ftp-real-file-name-as-directory dir))	;real?
X	  (let* ((tbl (ange-ftp-get-files dir))
X		 (completion-ignored-pattern
X		  (mapconcat (function
X			      (lambda (s) (if (stringp s)
X					      (concat (regexp-quote s) "$")
X					    "/"))) ; / never in filename
X			     completion-ignored-extensions
X			     "\\|")))
X	    (ange-ftp-save-match-data
X	      (or (ange-ftp-file-name-completion-1
X		   file tbl dir (function ange-ftp-file-entry-not-ignored-p))
X		  (ange-ftp-file-name-completion-1
X		   file tbl dir (function ange-ftp-file-entry-active-p)))))))
X    (if (string-equal "/" dir)
X	(try-completion
X	 file
X	 (nconc (ange-ftp-generate-root-prefixes)
X		(mapcar 'list
X			(ange-ftp-real-file-name-all-completions file "/"))))
X      (ange-ftp-real-file-name-completion file dir))))
X
X
(defun ange-ftp-file-name-completion-1 (file tbl dir predicate)
X  "Internal subroutine for ange-ftp-file-name-completion.  Do not call this."
X  (let ((bestmatch (try-completion file tbl predicate)))
X    (if bestmatch
X	(if (eq bestmatch t)
X	    (if (file-directory-p (expand-file-name file dir))
X		(concat file "/")
X	      t)
X	  (if (and (eq (try-completion bestmatch tbl predicate) t)
X		   (file-directory-p
X		    (expand-file-name bestmatch dir)))
X	      (concat bestmatch "/")
X	    bestmatch)))))
X
(defun ange-ftp-quote-filename (file)
X  "Quote `$' as `$$' in FILE to get it past function `substitute-in-file-name.'"
X  (let ((pos 0))
X    (while (setq pos (string-match "\\$" file pos))
X      (setq file (concat (substring file 0 pos)
X			 "$";; precede by escape character (also a $)
X			 (substring file pos))
X	    ;; add 2 instead 1 since another $ was inserted
X	    pos (+ 2 pos)))
X    file))
X
(defun ange-ftp-read-file-name-internal (string dir action)
X  "Documented as original."
X  (let (name realdir)
X    (if (eq action 'lambda)
X	(if (> (length string) 0)
X	    (file-exists-p (substitute-in-file-name string)))
X      (if (zerop (length string))
X	 (setq name string realdir dir)
X       (setq string (substitute-in-file-name string)
X	      name (file-name-nondirectory string)
X	      realdir (file-name-directory string))
X	(setq realdir (if realdir (expand-file-name realdir dir) dir)))
X     (if action
X	  (file-name-all-completions name realdir)
X	(let ((specdir (file-name-directory string))
X	      (val (file-name-completion name realdir)))
X	  (if (and specdir (stringp val))
X	      (ange-ftp-quote-filename (concat specdir val))
X	    val))))))
X
;; Put these lines uncommmented in your .emacs if you want C-r to refresh
;; ange-ftp's cache whilst doing filename completion.
;;
;;(define-key minibuffer-local-completion-map "\C-r" 'ange-ftp-re-read-dir)
;;(define-key minibuffer-local-must-match-map "\C-r" 'ange-ftp-re-read-dir)
X
(defun ange-ftp-re-read-dir (&optional dir)
X  "Forces a re-read of the directory DIR.  If DIR is omitted then it defaults
to the directory part of the contents of the current buffer."
X  (interactive)
X  (if dir
X      (setq dir (expand-file-name dir))
X    (setq dir (file-name-directory (expand-file-name (buffer-string)))))
X  (if (ange-ftp-ftp-path dir)
X      (progn
X	(setq ange-ftp-ls-cache-file nil)
X	(ange-ftp-del-hash-entry dir ange-ftp-files-hashtable)
X	(ange-ftp-get-files dir t))))
X
;;;; ------------------------------------------------------------
;;;; Bits and bobs to bolt ange-ftp into GNU Emacs.
;;;; ------------------------------------------------------------
X
(defvar ange-ftp-overwrite-msg
X  "Note: This function has been modified to work with ange-ftp.")
X
(defun ange-ftp-safe-documentation (fun)
X  "A documentation function that isn't quite as fragile."
X  (condition-case ()
X      (documentation fun)
X    (error nil)))
X
(defun ange-ftp-overwrite-fn (fun)
X  "Replace FUN's function definition with ange-ftp-FUN's, saving the
original definition as ange-ftp-real-FUN.  The original documentation is
placed on the new definition suitably augmented."
X  (let* ((name (symbol-name fun))
X	 (saved (intern (concat "ange-ftp-real-" name)))
X	 (new (intern (concat "ange-ftp-" name)))
X	 (nfun (symbol-function new))
X	 (exec-directory (if (or (equal (nth 3 command-line-args) "dump")
X				 (equal (nth 4 command-line-args) "dump"))
X			     "../etc/"
X			   exec-directory)))			 
X    
X    ;; *** This is unnecessary for any ange-ftp function (I think):
X    (while (symbolp nfun)
X      (setq nfun (symbol-function nfun)))
X    
X    ;; Interpose the ange-ftp function between the function symbol and the
X    ;; original definition of the function symbol AT TIME OF FIRST LOAD.
X    ;; We must only redefine the symbol-function of FUN the very first
X    ;; time, to avoid blowing away stuff that overloads FUN after this.
X    
X    ;; We direct the function symbol to the ange-ftp's function symbol
X    ;; rather than function definition to allow reloading of this file or
X    ;; redefining of the individual function (e.g., during debugging)
X    ;; later after some other code has been loaded on top of our stuff.
X    
X    (or (fboundp saved)
X	(progn
X	  (fset saved (symbol-function fun))
X	  (fset fun new)))
X    
X    ;; Rewrite the doc string on the new ange-ftp function.  This should
X    ;; be done every time the file is loaded (or a function is redefined),
X    ;; because the underlying overloaded function may have changed its doc
X    ;; string.
X    
X    (let* ((doc-str (ange-ftp-safe-documentation saved))
X	   (ndoc-str (concat doc-str (and doc-str "\n")
X			     ange-ftp-overwrite-msg)))
X      
X      (cond ((listp nfun)
X	     ;; Probe to test whether function is in preloaded read-only
X	     ;; memory, and if so make writable copy:
X	     (condition-case nil
X		 (setcar nfun (car nfun))
X	       (error
X		(setq nfun (copy-sequence nfun)) ; shallow copy only
X		(fset new nfun)))
X	     (let ((ndoc-cdr (nthcdr 2 nfun)))
X	       (if (stringp (car ndoc-cdr))
X		   ;; Replace the existing docstring.
X		   (setcar ndoc-cdr ndoc-str)
X		 ;; There is no docstring.  Insert the overwrite msg.
X		 (setcdr ndoc-cdr (cons (car ndoc-cdr) (cdr ndoc-cdr)))
X		 (setcar ndoc-cdr ange-ftp-overwrite-msg))))
X	    (t
X	     ;; it's an emacs19 compiled-code object
X	     (let ((new-code (append nfun nil))) ; turn it into a list
X	       (if (nthcdr 4 new-code)
X		   (setcar (nthcdr 4 new-code) ndoc-str)
X		 (setcdr (nthcdr 3 new-code) (cons ndoc-str nil)))
X	       (fset new (apply 'make-byte-code new-code))))))))
X
(defun ange-ftp-overwrite-dired ()
X  (if (not (fboundp 'dired-ls))		;dired should have been loaded by now
X      (ange-ftp-overwrite-fn 'dired-readin) ; classic dired
X    (ange-ftp-overwrite-fn 'make-directory) ; tree dired and v19 stuff
X    (ange-ftp-overwrite-fn 'remove-directory)
X    (ange-ftp-overwrite-fn 'diff)
X    (ange-ftp-overwrite-fn 'dired-run-shell-command)
X    (ange-ftp-overwrite-fn 'dired-ls)
X    (ange-ftp-overwrite-fn 'dired-call-process)
X    ;; Can't use (fset 'ange-ftp-dired-readin 'ange-ftp-tree-dired-readin)
X    ;; here because it confuses ange-ftp-overwrite-fn.
X    (fset 'ange-ftp-dired-readin (symbol-function 'ange-ftp-tree-dired-readin))
X    (ange-ftp-overwrite-fn 'dired-readin)
X    (ange-ftp-overwrite-fn 'dired-insert-headerline)
X    (ange-ftp-overwrite-fn 'dired-move-to-filename)
X    (ange-ftp-overwrite-fn 'dired-move-to-end-of-filename)
X    (ange-ftp-overwrite-fn 'dired-get-filename)
X    (ange-ftp-overwrite-fn 'dired-between-files)
X    (ange-ftp-overwrite-fn 'dired-clean-directory)
X    (ange-ftp-overwrite-fn 'dired-flag-backup-files)
X    (ange-ftp-overwrite-fn 'dired-backup-diff)
X    (if (fboundp 'dired-do-create-files)
X	;; dired 6.0 or later.
X	(progn
X	  (ange-ftp-overwrite-fn 'dired-copy-file)
X	  (ange-ftp-overwrite-fn 'dired-create-files)
X	  (ange-ftp-overwrite-fn 'dired-do-create-files)))
X    (if (fboundp 'dired-compress-make-compressed-filename)
X	;; it's V5.255 or later
X	(ange-ftp-overwrite-fn 'dired-compress-make-compressed-filename)
X      ;; ange-ftp-overwrite-fn confuses dired-mark-map here.
X      (fset 'ange-ftp-real-dired-compress (symbol-function 'dired-compress))
X      (fset 'dired-compress 'ange-ftp-dired-compress)
X      (fset 'ange-ftp-real-dired-uncompress (symbol-function 'dired-uncompress))
X      (fset 'dired-uncompress 'ange-ftp-dired-uncompress)))
X
X  (ange-ftp-overwrite-fn 'dired-find-file)
X  (ange-ftp-overwrite-fn 'dired-revert))
X
;; Attention!
;; It would be nice if ange-ftp-add-hook was generalized to
;; (defun ange-ftp-add-hook (hook-var hook-function &optional postpend),
;; where the optional postpend variable stipulates that hook-function
;; should be post-pended to the hook-var, rather than prepended.
;; Then, maybe we should overwrite dired with
;; (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired t).
;; This is because dired-load-hook is commonly used to add the dired extras
;; features (dired-x.el, dired-trns.el, dired-nstd.el, ...). Some of these
;; extras features overwrite functions in dired.el with fancier versions.
;; The "extras" overwrites would then clobber the ange-ftp overwrites.
;; As long as the ange-ftp overwrites are carefully written to use
;; ange-ftp-real-... when the directory is local, then doing the ange-ftp
;; overwrites after the extras overwites should be OK.
;; At the moment, I think that there aren't any conflicts between the extras
;; overwrites, and the ange-ftp overwrites. This may not last though.
X
(defun ange-ftp-add-hook (hook-var hook-function)
X  "Prepend hook-function to hook-var's value, if it is not already an element.
hook-var's value may be a single function or a list of functions."
X  (if (boundp hook-var)
X      (let ((value (symbol-value hook-var)))
X        (if (and (listp value) (not (eq (car value) 'lambda)))
X            (and (not (memq hook-function value))
X                 (set hook-var
X                      (if value (cons hook-function value) hook-function)))
X          (and (not (eq hook-function value))
X               (set hook-var
X                    (list hook-function value)))))
X    (set hook-var hook-function)))
X
;; To load ange-ftp and not dired (leaving it to autoload), define
;; dired-load-hook and make sure dired.el ends with:
;;	(run-hooks 'dired-load-hook)
;;
(if (and (boundp 'dired-load-hook)
X	 (not (featurep 'dired)))
X    (ange-ftp-add-hook 'dired-load-hook 'ange-ftp-overwrite-dired)
X  (require 'dired)
X  (ange-ftp-overwrite-dired))
X
;; In case v19 or emacs-19.el already loaded:
;; (Can't use fboundp to check if emacs-19.el is
;; loaded, because these functions are probably
;; bound to autoloads.)
X
(if (and (fboundp 'make-directory)
X	 (not (and (listp (symbol-function 'make-directory))
X		   (eq (car (symbol-function 'make-directory)) 'autoload))))
X    (ange-ftp-overwrite-fn 'make-directory))
(if (and (fboundp 'remove-directory)
X	 (not (and (listp (symbol-function 'remove-directory))
X		   (eq (car (symbol-function 'remove-directory)) 'autoload))))
X    (ange-ftp-overwrite-fn 'remove-directory))
(if (and (fboundp 'diff)
X	 (not (and (listp (symbol-function 'diff))
X		   (eq (car (symbol-function 'diff)) 'autoload))))
X      (ange-ftp-overwrite-fn 'diff))
X
(ange-ftp-overwrite-fn 'insert-file-contents)
(ange-ftp-overwrite-fn 'directory-files)
(ange-ftp-overwrite-fn 'file-directory-p)
(ange-ftp-overwrite-fn 'file-writable-p)
(ange-ftp-overwrite-fn 'file-readable-p)
(ange-ftp-overwrite-fn 'file-symlink-p)
(ange-ftp-overwrite-fn 'delete-file)
(ange-ftp-overwrite-fn 'read-file-name-internal)
(ange-ftp-overwrite-fn 'verify-visited-file-modtime)
(ange-ftp-overwrite-fn 'file-exists-p)
(ange-ftp-overwrite-fn 'write-region)
(ange-ftp-overwrite-fn 'backup-buffer)
(ange-ftp-overwrite-fn 'copy-file)
(ange-ftp-overwrite-fn 'rename-file)
(ange-ftp-overwrite-fn 'file-attributes)
(ange-ftp-overwrite-fn 'file-name-directory)
(ange-ftp-overwrite-fn 'file-name-nondirectory)
(ange-ftp-overwrite-fn 'file-name-as-directory)
(ange-ftp-overwrite-fn 'directory-file-name)
(ange-ftp-overwrite-fn 'expand-file-name)
(ange-ftp-overwrite-fn 'file-name-all-completions)
(ange-ftp-overwrite-fn 'file-name-completion)
X
(or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
X    (setq find-file-hooks
X	  (cons 'ange-ftp-set-buffer-mode find-file-hooks)))
X
X
;;;; ------------------------------------------------------------
;;;; VOS support (VOS support is probably broken,
;;;; but I don't know anything about VOS.)
;;;; ------------------------------------------------------------
;
;(defun ange-ftp-fix-path-for-vos (path &optional reverse)
;  (setq path (copy-sequence path))
;  (let ((from (if reverse ?\> ?\/))
;	(to (if reverse ?\/ ?\>))
;	(i (1- (length path))))
;    (while (>= i 0)
;      (if (= (aref path i) from)
;	  (aset path i to))
;      (setq i (1- i)))
;    path))
;
;(or (assq 'vos ange-ftp-fix-path-func-alist)
;    (setq ange-ftp-fix-path-func-alist
;	  (cons '(vos . ange-ftp-fix-path-for-vos)
;		ange-ftp-fix-path-func-alist)))
;
;(or (memq 'vos ange-ftp-dumb-host-types)
;    (setq ange-ftp-dumb-host-types
;	  (cons 'vos ange-ftp-dumb-host-types)))
;
;(defun ange-ftp-fix-dir-path-for-vos (dir-path)
;  (ange-ftp-fix-path-for-vos
;   (concat dir-path
;	   (if (eq ?/ (aref dir-path (1- (length dir-path))))
;	       "" "/")
;	   "*")))
;
;(or (assq 'vos ange-ftp-fix-dir-path-func-alist)
;    (setq ange-ftp-fix-dir-path-func-alist
;	  (cons '(vos . ange-ftp-fix-dir-path-for-vos)
;		ange-ftp-fix-dir-path-func-alist)))
;
;(defvar ange-ftp-vos-host-regexp nil
;  "If a host matches this regexp then it is assumed to be running VOS.")
;
;(defun ange-ftp-vos-host (host)
;  (and ange-ftp-vos-host-regexp
;       (ange-ftp-save-match-data
;	 (string-match ange-ftp-vos-host-regexp host))))
;
;(defun ange-ftp-parse-vos-listing ()
;  "Parse the current buffer which is assumed to be in VOS list -all
;format, and return a hashtable as the result."
;  (let ((tbl (ange-ftp-make-hashtable))
;	(type-list
;	 '(("^Files: [0-9]+ +Blocks: [0-9]+\n+" nil 40)
;	   ("^Dirs: [0-9]+\n+" t 30)))
;	type-regexp type-is-dir type-col file)
;    (goto-char (point-min))
;    (ange-ftp-save-match-data
;      (while type-list
;	(setq type-regexp (car (car type-list))
;	      type-is-dir (nth 1 (car type-list))
;	      type-col (nth 2 (car type-list))
;	      type-list (cdr type-list))
;	(if (re-search-forward type-regexp nil t)
;	    (while (eq (char-after (point)) ? )
;	      (move-to-column type-col)
;	      (setq file (buffer-substring (point)
;					   (progn
;					     (end-of-line 1)
;					     (point))))
;	      (ange-ftp-put-hash-entry file type-is-dir tbl)
;	      (forward-line 1))))
;      (ange-ftp-put-hash-entry "." 'vosdir tbl)
;      (ange-ftp-put-hash-entry ".." 'vosdir tbl))
;    tbl))
;
;(or (assq 'vos ange-ftp-parse-list-func-alist)
;    (setq ange-ftp-parse-list-func-alist
;	  (cons '(vos . ange-ftp-parse-vos-listing)
;		ange-ftp-parse-list-func-alist)))
X
;;;; ------------------------------------------------------------
;;;; VMS support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-fix-path-for-vms (path &optional reverse)
X  "Convert PATH from UNIX-ish to VMS.  If REVERSE given then convert from VMS
to UNIX-ish."
X  (ange-ftp-save-match-data
X    (if reverse
X	(if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" path)
X	    (let (drive dir file)
X	      (if (match-beginning 1)
X		  (setq drive (substring path
X					 (match-beginning 1)
X					 (match-end 1))))
X	      (if (match-beginning 2)
X		  (setq dir
X			(substring path (match-beginning 2) (match-end 2))))
X	      (if (match-beginning 3)
X		  (setq file
X			(substring path (match-beginning 3) (match-end 3))))
X	      (and dir
X		   (setq dir (apply (function concat)
X				    (mapcar (function
X					     (lambda (char)
X					       (if (= char ?.)
X						   (vector ?/)
X						 (vector char))))
X					    (substring dir 1 -1)))))
X	      (concat (and drive
X			   (concat "/" drive "/"))
X		      dir (and dir "/")
X		      file))
X	  (error "path %s didn't match" path))
X      (let (drive dir file tmp)
X	(if (string-match "^/[^:]+:/" path)
X	    (setq drive (substring path 1
X				   (1- (match-end 0)))
X		  path (substring path (match-end 0))))
X	(setq tmp (file-name-directory path))
X	(if tmp
X	    (setq dir (apply (function concat)
X			     (mapcar (function
X				      (lambda (char)
X					(if (= char ?/)
X					    (vector ?.)
X					  (vector char))))
X				     (substring tmp 0 -1)))))
X	(setq file (file-name-nondirectory path))
X	(concat drive
X		(and dir (concat "[" (if drive nil ".") dir "]"))
X		file)))))
X
;; (ange-ftp-fix-path-for-vms "/PUB$:/ANONYMOUS/SDSCPUB/NEXT/Readme.txt;1")
;; (ange-ftp-fix-path-for-vms "/PUB$:[ANONYMOUS.SDSCPUB.NEXT]Readme.txt;1" t)
X
(or (assq 'vms ange-ftp-fix-path-func-alist)
X    (setq ange-ftp-fix-path-func-alist
X	  (cons '(vms . ange-ftp-fix-path-for-vms)
X		ange-ftp-fix-path-func-alist)))
X
(or (memq 'vms ange-ftp-dumb-host-types)
X    (setq ange-ftp-dumb-host-types
X	  (cons 'vms ange-ftp-dumb-host-types)))
X
;; It is important that this function barf for directories for which we know
;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/".
;; This is because it saves an unnecessary FTP error, or possibly the listing
;; might succeed, but give erroneous info. This last case is particularly
;; likely for OS's (like MTS) for which we need to use a wildcard in order
;; to list a directory.
X
(defun ange-ftp-fix-dir-path-for-vms (dir-path)
X  "Convert path from UNIX-ish to VMS ready for a DIRectory listing."
X  ;; Should there be entries for .. -> [-] and . -> [] below. Don't
X  ;; think so, because expand-filename should have already short-circuited
X  ;; them.
X  (cond ((string-equal dir-path "/")
X	 (error "Cannot get listing for fictitious \"/\" directory."))
X	((string-match "^/[-A-Z0-9_$]+:/$" dir-path)
X	 (error "Cannot get listing for device."))
X	((ange-ftp-fix-path-for-vms dir-path))))
X  
(or (assq 'vms ange-ftp-fix-dir-path-func-alist)
X    (setq ange-ftp-fix-dir-path-func-alist
X	  (cons '(vms . ange-ftp-fix-dir-path-for-vms)
X		ange-ftp-fix-dir-path-func-alist)))
X
(defvar ange-ftp-vms-host-regexp nil)
X
(defun ange-ftp-vms-host (host)
X  "Return whether HOST is running VMS."
X  (and ange-ftp-vms-host-regexp
X       (ange-ftp-save-match-data
X	 (string-match ange-ftp-vms-host-regexp host))))
X
;; Because some VMS ftp servers convert filenames to lower case
;; we allow a-z in the filename regexp. I'm not too happy about this.
X
(defconst ange-ftp-vms-filename-regexp
X  (concat
X   "\\(\\([_A-Za-z0-9$]?\\|[_A-Za-z0-9$][_A-Za-z0-9$---]*\\)\\."
X   "[_A-Za-z0-9$---]*;+[0-9]*\\)")
X  "Regular expression to match for a valid VMS file name in Dired buffer.
Stupid freaking bug! Position of _ and $ shouldn't matter but they do.
Having [A-Z0-9$_] bombs on filename _$$CHANGE_LOG$.TXT$ and $CHANGE_LOG$.TX
Other orders of $ and _ seem to all work just fine.")
X
;; These parsing functions are as general as possible because the syntax
;; of ftp listings from VMS hosts is a bit erratic. What saves us is that
;; the VMS filename syntax is so rigid. If they bomb on a listing in the
;; standard VMS Multinet format, then this is a bug. If they bomb on a listing
;; from vms.weird.net, then too bad.
X
(defun ange-ftp-parse-vms-filename ()
X  "Extract the next filename from a VMS dired-like listing."
X  (if (re-search-forward
X	 ange-ftp-vms-filename-regexp
X	 nil t)
X	(buffer-substring (match-beginning 0) (match-end 0))))
X
(defun ange-ftp-parse-vms-listing ()
X  "Parse the current buffer which is assumed to be in MultiNet FTP dir
format, and return a hashtable as the result."
X  (let ((tbl (ange-ftp-make-hashtable))
X	file)
X    (goto-char (point-min))
X    (ange-ftp-save-match-data
X      (while (setq file (ange-ftp-parse-vms-filename))
X	(if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
X	    ;; deal with directories
X	    (ange-ftp-put-hash-entry
X	     (substring file 0 (match-beginning 0)) t tbl)
X	  (ange-ftp-put-hash-entry file nil tbl)
X	  (if (string-match ";[0-9]+$" file) ; deal with extension
X	      ;; sans extension
X	      (ange-ftp-put-hash-entry
X	       (substring file 0 (match-beginning 0)) nil tbl)))
X	(forward-line 1))
X      ;; Would like to look for a "Total" line, or a "Directory" line to
X      ;; make sure that the listing isn't complete garbage before putting
X      ;; in "." and "..", but we can't even count on all VAX's giving us
X      ;; either of these.
X	   (ange-ftp-put-hash-entry "." t tbl)
X	   (ange-ftp-put-hash-entry ".." t tbl))
X    tbl))
X
(or (assq 'vms ange-ftp-parse-list-func-alist)
X    (setq ange-ftp-parse-list-func-alist
X	  (cons '(vms . ange-ftp-parse-vms-listing)
X		ange-ftp-parse-list-func-alist)))
X
;; This version only deletes file entries which have
;; explicit version numbers, because that is all VMS allows.
X
;; Can the following two functions be speeded up using file
;; completion functions?
X
(defun ange-ftp-vms-delete-file-entry (path &optional dir-p)
X  (if dir-p
X      (ange-ftp-internal-delete-file-entry path t)
X    (ange-ftp-save-match-data
X      (let ((file (ange-ftp-get-file-part path)))
X	(if (string-match ";[0-9]+$" file)
X	    ;; In VMS you can't delete a file without an explicit	
X	    ;; version number, or wild-card (e.g. FOO;*)
X	    ;; For now, we give up on wildcards.
SHAR_EOF
true || echo 'restore of ange-ftp.el failed'
fi
echo 'End of part 5, continue with part 6'
echo 6 > _shar_seq_.tmp
exit 0
Newsgroups: gnu.emacs.sources