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

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

---- Cut Here and feed the following to sh ----
#!/bin/sh
# this is ange-ftp.03 (part 3 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" != 3; 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' &&
;; as user, if necessary. For efficiency, I have tried to give this
;; optional second argument only when necessary. Have I missed any calls
;; to ange-ftp-host-type where it should have been supplied?
X
(defun ange-ftp-host-type (host &optional user)
X  "Return a symbol which represents the type of the HOST given.
If the optional argument USER is given, attempts to guess the
host-type by logging in as USER."
X  (if (eq host ange-ftp-host-cache)
X      ange-ftp-host-type-cache
X    ;; Trigger an ftp connection, in case we need to guess at the host type.
X    (if (and user (ange-ftp-get-process host user) (eq host ange-ftp-host-cache))
X	ange-ftp-host-type-cache
X      (setq ange-ftp-host-cache host
X	    ange-ftp-host-type-cache
X	    (cond ((ange-ftp-dumb-unix-host host)
X		   'dumb-unix)
X		  ((and (fboundp 'ange-ftp-vos-host)
X			(ange-ftp-vos-host host))
X		   'vos)
X		  ((and (fboundp 'ange-ftp-vms-host)
X			(ange-ftp-vms-host host))
X		   'vms)
X		  ((and (fboundp 'ange-ftp-mts-host)
X			(ange-ftp-mts-host host))
X		   'mts)
X		  ((and (fboundp 'ange-ftp-cms-host)
X			(ange-ftp-cms-host host))
X		   'cms)
X		  (t
X		   'unix))))))
X
;; It would be nice to abstract the functions ange-ftp-TYPE-host and
;; ange-ftp-add-TYPE-host. The trick is to abstract these functions
;; without sacrificing speed. Also, having separate variables
;; ange-ftp-TYPE-regexp is more user friendly then requiring the user to
;; set an alist to indicate that a host is of a given type. Even with
;; automatic host type recognition, setting a regexp is still a good idea
;; (for efficiency) if you log into a particular non-UNIX host frequently.
X
(defvar ange-ftp-fix-path-func-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
which can change a UNIX path into a path more suitable for a host of type
TYPE.")
X
(defvar ange-ftp-fix-dir-path-func-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where FUNC is a routine
which can change UNIX directory path into a directory path more suitable
for a host of type TYPE.")
X
;; *** Perhaps the sense of this variable should be inverted, since there
;; *** is only 1 host type that can take ls-style listing options.
(defvar ange-ftp-dumb-host-types '(dumb-unix)
X  "List of host types that can't take UNIX ls-style listing options.")
X
(defun ange-ftp-send-cmd (host user cmd &optional msg cont nowait)
X  "Find an ftp process connected to HOST logged in as USER and send it CMD.
MSG is an optional status message to be output before and after issuing the
command.
See the documentation for ange-ftp-raw-send-cmd for a description of CONT
and NOWAIT."
X  ;; Handle conversion to remote pathname syntax and remote ls option
X  ;; capability.
X  (let ((cmd0 (car cmd))
X	(cmd1 (nth 1 cmd))
X	cmd2 cmd3 host-type fix-pathname-func)
X
X    (cond
X     
X     ;; pwd case (We don't care what host-type.)
X     ((null cmd1))
X     
X     ;; cmd == 'dir "remote-path" "local-path" "ls-switches"
X     ((progn
X       (setq cmd2 (nth 2 cmd)
X	     host-type (ange-ftp-host-type host user))
X       ;; This will trigger an FTP login, if one doesn't exist
X       (eq cmd0 'dir))
X      (setq cmd1 (funcall
X		  (or (cdr (assq host-type ange-ftp-fix-dir-path-func-alist))
X		      'identity)
X		  cmd1)
X	    cmd3 (nth 3 cmd))
X      ;; Need to deal with the HP-UX ftp bug. This should also allow
X      ;; us to resolve symlinks to directories on SysV machines. (Sebastian will
X      ;; be happy.)
X      (and (eq host-type 'unix)
X	   (string-match "/$" cmd1)
X	   (not (string-match "R" cmd3))
X	   (setq cmd1 (concat cmd1 ".")))
X      ;; If the remote ls can take switches, put them in
X      (or (memq host-type ange-ftp-dumb-host-types)
X	  (setq cmd0 'ls
X		cmd1 (format "\"%s %s\"" cmd3 cmd1))))
X     
X     ;; First argument is the remote pathname
X     ((progn
X	(setq fix-pathname-func (or (cdr (assq host-type
X					       ange-ftp-fix-path-func-alist))
X				    'identity))
X	(memq cmd0 '(get delete mkdir rmdir cd)))
X      (setq cmd1 (funcall fix-pathname-func cmd1)))
X
X     ;; Second argument is the remote pathname
X     ((memq cmd0 '(append put chmod))
X      (setq cmd2 (funcall fix-pathname-func cmd2)))
X
X     ;; Both arguments are remote pathnames
X     ((eq cmd0 'rename)
X      (setq cmd1 (funcall fix-pathname-func cmd1)
X	    cmd2 (funcall fix-pathname-func cmd2))))
X	  
X    ;; Turn the command into one long string 
X    (setq cmd0 (symbol-name cmd0))
X    (setq cmd (concat cmd0
X		      (and cmd1 (concat " " cmd1))
X		      (and cmd2 (concat " " cmd2))))
X
X    ;; Actually send the resulting command.
X    (let (afsc-result
X	  afsc-line)
X      (ange-ftp-raw-send-cmd
X       (ange-ftp-get-process host user)
X       cmd
X       msg
X       (list
X	(function (lambda (result line host user
X				  cmd msg cont nowait)
X		    (or cont
X			(setq afsc-result result
X			      afsc-line line))
X		    (if result
X			(ange-ftp-call-cont cont result line)
X		      (ange-ftp-raw-send-cmd
X		       (ange-ftp-get-process host user)
X		       cmd
X		       msg
X		       (list
X			(function (lambda (result line cont)
X				    (or cont
X					(setq afsc-result result
X					      afsc-line line))
X				    (ange-ftp-call-cont cont result line)))
X			cont)
X		       nowait))))
X	host user cmd msg cont nowait)
X       nowait)
X
X      (if nowait
X	  nil
X	(if cont
X	    nil
X	  (cons afsc-result afsc-line))))))
X
;; It might be nice to message users about the host type identified,
;; but there is so much other messaging going on, it would not be
;; seen. No point in slowing things down just so users can read
;; a host type message.
X
(defconst ange-ftp-cms-path-template
X  (concat
X   "^[-A-Z0-9$*][-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?"
X   "[-A-Z0-9$*]?[-A-Z0-9$*]?[-A-Z0-9$*]?\\.[0-9][0-9][0-9A-Z]$"))
(defconst ange-ftp-vms-path-template
X  "^[-A-Z0-9_$]+:\\[[-A-Z0-9_$]+\\(\\.[-A-Z0-9_$]+\\)*\\]$")
(defconst ange-ftp-mts-path-template
X  "^[A-Z0-9._][A-Z0-9._][A-Z0-9._][A-Z0-9._]:$")
X
(defun ange-ftp-guess-host-type (host user)
X  "Guess at the the host type of HOST by doing a pwd, and examining
the directory syntax."
X  (let ((host-type (ange-ftp-host-type host))
X	(key (concat host "/" user "/~")))
X    (if (eq host-type 'unix)
X	;; Note that ange-ftp-host-type returns unix as the default value.
X	(ange-ftp-save-match-data
X	  (let* ((result (ange-ftp-get-pwd host user))
X		 (dir (car result))
X		 fix-path-func)
X	    (cond ((null dir)
X		   (message "Warning! Unable to get home directory")
X		   (sit-for 1)
X		   (if (string-match
X			"^450 No current working directory defined$"
X			(cdr result))
X		       
X		       ;; We'll assume that if pwd bombs with this
X		       ;; error message, then it's CMS.
X		       (progn
X			 (ange-ftp-add-cms-host host)
X			 (setq ange-ftp-host-cache host
X			       ange-ftp-host-type-cache 'cms))))
X
X		  ;; try for VMS
X		  ((string-match ange-ftp-vms-path-template dir)
X		   (ange-ftp-add-vms-host host)
X		   ;; The add-host functions clear the host type cache.
X		   ;; Therefore, need to set the cache afterwards.
X		   (setq ange-ftp-host-cache host
X			 ange-ftp-host-type-cache 'vms))
X
X		  ;; try for MTS
X		  ((string-match ange-ftp-mts-path-template dir)
X		   (ange-ftp-add-mts-host host)
X		   (setq ange-ftp-host-cache host
X			 ange-ftp-host-type-cache 'mts))
X		  
X		  ;; try for CMS
X		  ((string-match ange-ftp-cms-path-template dir)
X		   (ange-ftp-add-cms-host host)
X		   (setq ange-ftp-host-cache host
X			 ange-ftp-host-type-cache 'cms))
X
X		  ;; assume UN*X
X		  (t
X		   (setq ange-ftp-host-cache host
X			 ange-ftp-host-type-cache 'unix)))
X
X	    ;; Now that we have done a pwd, might as well put it in
X	    ;; the expand-dir hashtable.
X	    (setq fix-path-func (cdr (assq ange-ftp-host-type-cache
X					   ange-ftp-fix-path-func-alist)))
X	    (if fix-path-func
X		(setq dir (funcall fix-path-func dir 'reverse)))
X	    (ange-ftp-put-hash-entry key dir
X				     ange-ftp-expand-dir-hashtable))))
X
X    ;; In the special case of CMS make sure that know the
X    ;; expansion of the home minidisk now, because we will
X    ;; be doing a lot of cd's.
X    (if (and (eq host-type 'cms)
X	     (not (ange-ftp-hash-entry-exists-p
X		   key ange-ftp-expand-dir-hashtable)))
X	(let ((dir (car (ange-ftp-get-pwd host user))))
X	  (if dir
X	      (ange-ftp-put-hash-entry key (concat "/" dir)
X				       ange-ftp-expand-dir-hashtable)
X	    (message "Warning! Unable to get home directory")
X	    (sit-for 1))))))
X
X
;;;; ------------------------------------------------------------
;;;; Simple FTP process shell support.
;;;; ------------------------------------------------------------
X
(defvar ange-ftp-shell-mode-map nil)
X
(defun ange-ftp-shell-mode ()
X  "Major mode for interacting with an FTP process.
Return at end of buffer sends line as input.
Return not at end copies rest of line to end and sends it.
X
The following commands imitate the usual Unix interrupt and editing
control characters:
\\{ange-ftp-shell-mode-map}
Runs ange-ftp-shell-mode-hook if not nil."
X  (interactive)
X  (let ((proc (get-buffer-process (current-buffer))))
X    (kill-all-local-variables)
X    (if (not ange-ftp-shell-mode-map)
X	(progn
X	  (require 'shell)
X	  (setq ange-ftp-shell-mode-map (copy-keymap shell-mode-map))
X	  (define-key
X	    ange-ftp-shell-mode-map "\C-m" 'ange-ftp-shell-send-input)))
X    (use-local-map ange-ftp-shell-mode-map)
X    (setq major-mode 'ange-ftp-shell-mode)
X    (setq mode-name "ange-ftp")
X    (setq mode-line-process '(": %s"))
X    (make-local-variable 'last-input-start)
X    (setq last-input-start (make-marker))
X    (make-local-variable 'last-input-end)
X    (setq last-input-end (make-marker))
X    (goto-char (point-max))
X    (set-marker (process-mark proc) (point))
X    (make-local-variable 'ange-ftp-process-string)
X    (setq ange-ftp-process-string "")
X    (make-local-variable 'ange-ftp-process-busy)
X    (make-local-variable 'ange-ftp-process-result)
X    (make-local-variable 'ange-ftp-process-msg)
X    (make-local-variable 'ange-ftp-process-multi-skip)
X    (make-local-variable 'ange-ftp-process-result-line)
X    (make-local-variable 'ange-ftp-process-continue)
X    (make-local-variable 'ange-ftp-hash-mark-count)
X    (make-local-variable 'ange-ftp-binary-hash-mark-size)
X    (make-local-variable 'ange-ftp-ascii-hash-mark-size)
X    (make-local-variable 'ange-ftp-hash-mark-unit)
X    (make-local-variable 'ange-ftp-xfer-size)
X    (make-local-variable 'ange-ftp-last-percent)
X    (setq ange-ftp-hash-mark-count 0)
X    (setq ange-ftp-xfer-size 0)
X    (setq ange-ftp-process-result-line "")
X    (run-hooks 'ange-ftp-shell-mode-hook)))
X
(defun ange-ftp-shell-send-input ()
X  "Send input to FTP process.
At end of buffer, sends all text after last output as input to the subshell,
including a newline inserted at the end.  When not at end, copies current line
to the end of the buffer and sends it, after first attempting to discard any
prompt at the beginning of the line."
X  (interactive)
X  (let ((process (get-buffer-process (current-buffer))))
X    (or process
X	(error "Current buffer has no process"))
X    (end-of-line)
X    (if (eobp)
X	(progn
X	  (move-marker last-input-start
X		       (process-mark process))
X	  (insert ?\n)
X	  (move-marker last-input-end (point)))
X      (beginning-of-line)
X      (re-search-forward "ftp> *"
X			 (save-excursion (end-of-line) (point))
X			 t)
X      (let ((copy (buffer-substring (point)
X				    (progn (forward-line 1) (point)))))
X	(goto-char (point-max))
X	(move-marker last-input-start (point))
X	(insert copy)
X	(move-marker last-input-end (point))))
X    (process-send-region process last-input-start last-input-end)
X    (set-marker (process-mark process) (point))))
X
;;;; ------------------------------------------------------------
;;;; Remote file and directory listing support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-dumb-unix-host (host)
X  "Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands
to take switch arguments."
X  (and ange-ftp-dumb-unix-host-regexp
X       (ange-ftp-save-match-data
X	 (string-match ange-ftp-dumb-unix-host-regexp host))))
X
(defun ange-ftp-add-dumb-unix-host (host)
X  "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp."
X  (interactive
X   (list (read-string "Host: "
X		      (let ((name (or (buffer-file-name)
X				      (and (eq major-mode 'dired-mode)
X					   dired-directory))))
X			(and name (car (ange-ftp-ftp-path name)))))))
X  (if (not (ange-ftp-dumb-unix-host host))
X      (setq ange-ftp-dumb-unix-host-regexp
X	    (concat "^" (regexp-quote host) "$"
X		    (and ange-ftp-dumb-unix-host-regexp "\\|")
X		    ange-ftp-dumb-unix-host-regexp)
X	    ange-ftp-host-cache nil)))
X
(defvar ange-ftp-parse-list-func-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs.  The FUNC is a routine
which can parse the output from a DIR listing for a host of type TYPE.")
X
;; With no-error nil, this function returns:
;; an error if file is not an ange-ftp-path
;;                      (This should never happen.) 
;; an error if either the listing is unreadable or there is an ftp error.
;; the listing (a string), if everything works.
;; 
;; With no-error t, it returns:
;; an error if not an ange-ftp-path
;; error if listing is unreable (most likely caused by a slow connection)
;; nil if ftp error (this is because although asking to list a nonexistent
;;                   directory on a remote unix machine usually (except
;;                   maybe for dumb hosts) returns an ls error, but no
;;                   ftp error, if the same is done on a VMS machine,
;;                   an ftp error is returned. Need to trap the error
;;                   so we can go on and try to list the parent.)
;; the listing, if everything works.
X
(defun ange-ftp-ls (file lsargs parse &optional no-error)
X  "Return the output of an `DIR' or `ls' command done over ftp.
FILE is the full name of the remote file, LSARGS is any args to pass to the
`ls' command, and PARSE specifies that the output should be parsed and stored
away in the internal cache."
X  ;; If parse is t, we assume that file is a directory. i.e. we only parse
X  ;; full directory listings.
X  (setq file (ange-ftp-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	       (key (directory-file-name file))
X	       (host-type (ange-ftp-host-type host user))
X	       (dumb (memq host-type ange-ftp-dumb-host-types))
X	       result
X	       temp
X	       lscmd parse-func)
X	  (if (string-equal path "")
X	      (setq path
X		    (ange-ftp-real-file-name-as-directory
X		          (ange-ftp-expand-dir host user "~"))))
X	  (if (and ange-ftp-ls-cache-file
X		   (string-equal key ange-ftp-ls-cache-file)
X		   ;; Don't care about lsargs for dumb hosts.
X		   (or dumb (string-equal lsargs ange-ftp-ls-cache-lsargs)))
X	      ange-ftp-ls-cache-res
X	    (setq temp (ange-ftp-make-tmp-name host))
X	    (setq lscmd (list 'dir path temp lsargs))
X	    (unwind-protect
X		(if (car (setq result (ange-ftp-send-cmd
X				       host
X				       user
X				       lscmd
X				       (format "Listing %s"
X					       (ange-ftp-abbreviate-filename
X						file)))))
X		    (save-excursion
X		      (set-buffer (get-buffer-create
X				   ange-ftp-data-buffer-name))
X		      (erase-buffer)
X		      (if (ange-ftp-real-file-readable-p temp)
X			  (ange-ftp-real-insert-file-contents temp)
X			(sleep-for ange-ftp-retry-time)
X					;wait for file to possibly appear
X			(if (ange-ftp-real-file-readable-p temp)
X			    ;; Try again.
X			    (ange-ftp-real-insert-file-contents temp)
X			  (ange-ftp-error host user
X					  (format
X					   "list data file %s not readable"
X					   temp))))
X		      (if parse
X			  (ange-ftp-set-files
X			   file
X			   (if (setq
X				parse-func
X				(cdr (assq host-type
X					   ange-ftp-parse-list-func-alist)))
X			       (funcall parse-func)
X			     (ange-ftp-parse-dired-listing lsargs))))
X		      (setq ange-ftp-ls-cache-file key
X			    ange-ftp-ls-cache-lsargs lsargs
X					; For dumb hosts-types this is
X					; meaningless but harmless.
X			    ange-ftp-ls-cache-res (buffer-string))
X		      ;; (kill-buffer (current-buffer))
X		      ange-ftp-ls-cache-res)
X		  (if no-error
X		      nil
X		    (ange-ftp-error host user
X				    (concat "DIR failed: " (cdr result)))))
X	      (ange-ftp-del-tmp-name temp))))
X      (error "Should never happen. Please report. Bug ref. no.: 1"))))
X
;;;; ------------------------------------------------------------
;;;; Directory information caching support.
;;;; ------------------------------------------------------------
X
(defconst ange-ftp-date-regexp
X  (concat
X   " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct"
X   "\\|Nov\\|Dec\\) +[0-3]?[0-9] "))
X
(defvar ange-ftp-add-file-entry-alist nil
X  "Association list of pairs \( TYPE \. FUNC \), where FUNC
is a function to be used to add a file entry for the OS TYPE. The
main reason for this alist is to deal with file versions in VMS.")
X
(defvar ange-ftp-delete-file-entry-alist nil
X  "Association list of pairs \( TYPE \. FUNC \), where FUNC
is a function to be used to delete a file entry for the OS TYPE.
The main reason for this alist is to deal with file versions in
VMS.")
X
(defun ange-ftp-add-file-entry (path &optional dir-p)
X  "Given a PATH, add the file entry for it, if its directory
info exists."
X  (funcall (or (cdr (assq (ange-ftp-host-type
X			   (car (ange-ftp-ftp-path path)))
X			  ange-ftp-add-file-entry-alist))
X	       'ange-ftp-internal-add-file-entry)
X	   path dir-p)
X  (setq ange-ftp-ls-cache-file nil))
X
(defun ange-ftp-delete-file-entry (path &optional dir-p)
X  "Given a PATH, delete the file entry for it, if its directory
info exists."
X  (funcall (or (cdr (assq (ange-ftp-host-type
X			   (car (ange-ftp-ftp-path path)))
X			  ange-ftp-delete-file-entry-alist))
X	       'ange-ftp-internal-delete-file-entry)
X	   path dir-p)
X  (setq ange-ftp-ls-cache-file nil))
X
(defmacro ange-ftp-parse-filename ()
X  ;;Extract the filename from the current line of a dired-like listing.
X  (` (let ((eol (progn (end-of-line) (point))))
X       (beginning-of-line)
X       (if (re-search-forward ange-ftp-date-regexp eol t)
X	   (progn
X	     (skip-chars-forward " ")
X	     (skip-chars-forward "^ " eol)
X	     (skip-chars-forward " " eol)
X	     ;; We bomb on filenames starting with a space.
X	     (buffer-substring (point) eol))))))
X  
;; This deals with the F switch. Should also do something about
;; unquoting names obtained with the SysV b switch and the GNU Q
;; switch. See Sebastian's dired-get-filename.
X
(defmacro ange-ftp-ls-parser ()
X  ;; Note that switches is dynamically bound.
X  ;; Meant to be called by ange-ftp-parse-dired-listing
X  (` (let ((tbl (ange-ftp-make-hashtable))
X	   (used-F (and (stringp switches)
X			(string-match "F" switches)))
X	   file-type symlink directory file)
X       (while (setq file (ange-ftp-parse-filename))
X	 (beginning-of-line)
X	 (skip-chars-forward "\t 0-9")
X	 (setq file-type (following-char)
X	       directory (eq file-type ?d))
X	 (if (eq file-type ?l)
X	     (if (string-match " -> " file)
X		 (setq symlink (substring file (match-end 0))
X		       file (substring file 0 (match-beginning 0)))
X	       ;; Shouldn't happen
X	       (setq symlink ""))
X	   (setq symlink nil))
X	 ;; Only do a costly regexp search if the F switch was used.
X	 (if (and used-F
X		  (not (string-equal file ""))
X		  (looking-at
X		   ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))
X	     (let ((socket (eq file-type ?s))
X		   (executable
X		    (and (not symlink) ; x bits don't mean a thing for symlinks
X			 (string-match "[xst]"
X				       (concat
X					(buffer-substring
X					 (match-beginning 1)
X					 (match-end 1))
X					(buffer-substring
X					 (match-beginning 2)
X					 (match-end 2))
X					(buffer-substring
X					 (match-beginning 3)
X					 (match-end 3)))))))
X	       ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
X	       ;; and others don't. (sigh...) Beware, that some Unix's don't
X	       ;; seem to believe in the F-switch
X	       (if (or (and symlink (string-match "@$" file))
X		       (and directory (string-match "/$" file))
X		       (and executable (string-match "*$" file))
X		       (and socket (string-match "=$" file)))
X		   (setq file (substring file 0 -1)))))
X	 (ange-ftp-put-hash-entry file (or symlink directory) tbl)
X	 (forward-line 1))
X       (ange-ftp-put-hash-entry "." t tbl)
X       (ange-ftp-put-hash-entry ".." t tbl)
X       tbl)))
X
;;; The dl stuff for descriptive listings
X
(defvar ange-ftp-dl-dir-regexp nil
X  "Regexp matching directories which are listed in dl format. This regexp
shouldn't be anchored with a trailing $ so that it will match subdirectories
as well.")
X
(defun ange-ftp-add-dl-dir (dir)
X  "Interactively adds a given directory to ange-ftp-dl-dir-regexp."
X  (interactive
X   (list (read-string "Directory: "
X		      (let ((name (or (buffer-file-name)
X				      (and (eq major-mode 'dired-mode)
X					   dired-directory))))
X			(and name (ange-ftp-ftp-path name)
X			     (file-name-directory name))))))
X  (if (not (and ange-ftp-dl-dir-regexp
X		(string-match ange-ftp-dl-dir-regexp dir)))
X      (setq ange-ftp-dl-dir-regexp
X	    (concat "^" (regexp-quote dir)
X		    (and ange-ftp-dl-dir-regexp "\\|")
X		    ange-ftp-dl-dir-regexp))))
X
(defmacro ange-ftp-dl-parser ()
X  ;; Parse the current buffer, which is assumed to be a descriptive
X  ;; listing, and return a hashtable.
X  (` (let ((tbl (ange-ftp-make-hashtable)))
X       (while (not (eobp))
X	 (ange-ftp-put-hash-entry
X	  (buffer-substring (point)
X			    (progn
X			      (skip-chars-forward "^ /\n")
X			      (point)))
X	  (eq (following-char) ?/)
X	  tbl)
X	 (forward-line 1))
X       (ange-ftp-put-hash-entry "." t tbl)
X       (ange-ftp-put-hash-entry ".." t tbl)
X       tbl)))
X
(defun ange-ftp-parse-dired-listing (&optional switches)
X  "Parse the current buffer which is assumed to be in a dired-like listing
format, and return a hashtable as the result. If the listing is not really
a listing, then return nil."
X  (ange-ftp-save-match-data
X    (cond
X     ((looking-at "^total [0-9]+$")
X      (forward-line 1)
X      (ange-ftp-ls-parser))
X     ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
X      ;; It's an ls error message.
X      nil)
X     ((eobp) ; i.e. (zerop (buffer-size))
X      ;; This could be one of:
X      ;; (1) An Ultrix ls error message
X      ;; (2) A listing with the A switch of an empty directory
X      ;;     on a machine which doesn't give a total line.
X      ;; (3) The twilight zone.
X      ;; We'll assume (1) for now.
X      nil)
X     ((re-search-forward ange-ftp-date-regexp nil t)
X      (beginning-of-line)
X      (ange-ftp-ls-parser))
X     ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
X      ;; It's a dl listing (I hope).
X      ;; file is bound by the call to ange-ftp-ls
X      (ange-ftp-add-dl-dir file)
X      (beginning-of-line)
X      (ange-ftp-dl-parser))
X     (t nil))))
X
(defun ange-ftp-set-files (directory files)
X  "For a given DIRECTORY, set or change the associated FILES hashtable."
X  (and files (ange-ftp-put-hash-entry (file-name-as-directory directory)
X				      files ange-ftp-files-hashtable)))
X
(defun ange-ftp-get-files (directory &optional no-error)
X  "Given a given DIRECTORY, return a hashtable of file entries.
This will give an error or return nil, depending on the value of
NO-ERROR, if a listing for DIRECTORY cannot be obtained."
X  (setq directory (file-name-as-directory directory)) ;normalize
X  (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)
X      (ange-ftp-save-match-data
X	(and (ange-ftp-ls directory
X			  ;; This is an efficiency hack. We try to
X			  ;; anticipate what sort of listing dired
X			  ;; might want, and cache just such a listing.
X			  (if (and (boundp 'dired-actual-switches)
X				   (stringp dired-actual-switches)
X				   ;; We allow the A switch, which lists
X				   ;; all files except "." and "..".
X				   ;; This is OK because we manually
X				   ;; insert these entries
X				   ;; in the hash table.
X				   (string-match
X				    "[aA]" dired-actual-switches)
X				   (string-match
X				    "l" dired-actual-switches)
X				   (not (string-match
X					 "R" dired-actual-switches)))
X			      dired-actual-switches
X			    (if (and (boundp 'dired-listing-switches)
X				     (stringp dired-listing-switches)
X				     (string-match
X				      "[aA]" dired-listing-switches)
X				     (string-match
X				      "l" dired-listing-switches)
X				     (not (string-match
X					   "R" dired-listing-switches)))
X				dired-listing-switches
X			      "-al"))
X			  t no-error)
X	     (ange-ftp-get-hash-entry
X	      directory ange-ftp-files-hashtable)))))
X
(defmacro ange-ftp-get-file-part (path)
X  "Given PATH, return the file part that can be used for looking up the
file's entry in a hashtable."
X  (` (let ((file (file-name-nondirectory (, path))))
X       (if (string-equal file "")
X	   "."
X	 file))))
X
(defmacro ange-ftp-allow-child-lookup (dir file)
X  "Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are
allowed to determine if PATH is a sub-directory by listing it directly,
rather than listing its parent directory. This is used for efficiency so
that a wasted listing is not done:
1. When looking for a .dired file in dired-x.el.
2. The syntax of FILE and DIR make it impossible that FILE could be a valid
X    subdirectory. This is of course an OS dependent judgement."
X  (` (not
X      (let* ((efile (, file)) ; expand once.
X	     (edir (, dir))
X	     (parsed (ange-ftp-ftp-path edir))
X	     (host-type (ange-ftp-host-type
X			 (car parsed))))
X	(or
X	 ;; Deal with dired
X	 (and (boundp 'dired-local-variables-file)
X	      (stringp dired-local-variables-file)
X	      (string-equal dired-local-variables-file efile))
X	 ;; No dots in dir names in vms.
X	 (and (eq host-type 'vms)
X	      (string-match "\\." efile))
X	 ;; No subdirs in mts of cms.
X	 (and (memq host-type '(mts cms))
X	      (not (string-equal "/" (nth 2 parsed)))))))))
X
(defun ange-ftp-file-entry-p (path)
X  "Given PATH, return whether there is a file entry for it."
X  (let* ((path (directory-file-name path))
X	 (dir (file-name-directory path))
X	 (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
X	 (file (ange-ftp-get-file-part path)))
X    (if ent
X	(ange-ftp-hash-entry-exists-p file ent)
X      (or (and (ange-ftp-allow-child-lookup dir file)
X	       (setq ent (ange-ftp-get-files path t))
X	       ;; Try a child lookup. i.e. try to list file as a
X	       ;; subdirectory of dir. This is a good idea because
X	       ;; we may not have read permission for file's parent. Also,
X	       ;; people tend to work down directory trees anyway. We use
X	       ;; no-error ;; because if file does not exist as a subdir.,
X	       ;; then dumb hosts will give an ftp error. Smart unix hosts
X	       ;; will simply send back the ls
X	       ;; error message.
X	       (ange-ftp-get-hash-entry "." ent))
X	  ;; Child lookup failed. Try the parent. If this bombs,
X	  ;; we are at wits end -- signal an error.
X	  ;; Problem: If this signals an error, the error message
X	  ;; may  not have a lot to do with what went wrong.
X	  (ange-ftp-hash-entry-exists-p file
X					(ange-ftp-get-files dir))))))
X
(defun ange-ftp-get-file-entry (path)
X  "Given PATH, return the given file entry which will be either t for a
directory, nil for a normal file, or a string for a symlink. If the file
isn't in the hashtable, this also returns nil."
X  (let* ((path (directory-file-name path))
X	 (dir (file-name-directory path))
X	 (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))
X	 (file (ange-ftp-get-file-part path)))
X    (if ent
X	(ange-ftp-get-hash-entry file ent)
X      (or (and (ange-ftp-allow-child-lookup dir file)
X	       (setq ent (ange-ftp-get-files path t))
X	       (ange-ftp-get-hash-entry "." ent))
X	       ;; i.e. it's a directory by child lookup
X	  (ange-ftp-get-hash-entry file
X				   (ange-ftp-get-files dir))))))
X
(defun ange-ftp-internal-delete-file-entry (path &optional dir-p)
X  (if dir-p
X      (progn 
X	(setq path (file-name-as-directory path))
X	(ange-ftp-del-hash-entry path ange-ftp-files-hashtable)
X	(setq path (directory-file-name path))))
X  ;; Note that file-name-as-directory followed by directory-file-name
X  ;; serves to canonicalize directory file names to their unix form.
X  ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO
X  (let ((files (ange-ftp-get-hash-entry (file-name-directory path)
X					ange-ftp-files-hashtable)))
X    (if files
X	(ange-ftp-del-hash-entry (ange-ftp-get-file-part path)
X				 files))))
X
(defun ange-ftp-internal-add-file-entry (path &optional dir-p)
X  (and dir-p
X       (setq path (directory-file-name path)))
X  (let ((files (ange-ftp-get-hash-entry (file-name-directory path)
X					ange-ftp-files-hashtable)))
X    (if files
X	(ange-ftp-put-hash-entry (ange-ftp-get-file-part path)
X				 dir-p
X				 files))))
X
(defun ange-ftp-wipe-file-entries (host user)
X  "Replace the file entry information hashtable with one that doesn't have any
entries for the given HOST, USER pair."
X  (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable))))
X    (ange-ftp-map-hashtable
X     (function
X      (lambda (key val)
X	(let ((parsed (ange-ftp-ftp-path key)))
X	  (if parsed
X	      (let ((h (nth 0 parsed))
X		    (u (nth 1 parsed)))
X		(or (and (equal host h) (equal user u))
X		    (ange-ftp-put-hash-entry key val new-tbl)))))))
X     ange-ftp-files-hashtable)
X    (setq ange-ftp-files-hashtable new-tbl)))
X
;;;; ------------------------------------------------------------
;;;; File transfer mode support.
;;;; ------------------------------------------------------------
X
(defun ange-ftp-set-binary-mode (host user)
X  "Tell the ftp process for the given HOST & USER to switch to binary mode."
X  (let ((result (ange-ftp-send-cmd host user '(type "binary"))))
X    (if (not (car result))
X	(ange-ftp-error host user (concat "BINARY failed: " (cdr result)))
X      (save-excursion
X	(set-buffer (process-buffer (ange-ftp-get-process host user)))
X	(setq ange-ftp-hash-mark-unit (ash ange-ftp-binary-hash-mark-size -4))))))
X
(defun ange-ftp-set-ascii-mode (host user)
X  "Tell the ftp process for the given HOST & USER to switch to ascii mode."
X  (let ((result (ange-ftp-send-cmd host user '(type "ascii"))))
X    (if (not (car result))
X	(ange-ftp-error host user (concat "ASCII failed: " (cdr result)))
X      (save-excursion
X	(set-buffer (process-buffer (ange-ftp-get-process host user)))
X	(setq ange-ftp-hash-mark-unit (ash ange-ftp-ascii-hash-mark-size -4))))))
X
;;; ------------------------------------------------------------
;;; expand-file-name and friends...
;;; ------------------------------------------------------------
X
(defun ange-ftp-cd (host user dir)
X  (let ((result (ange-ftp-send-cmd host user (list 'cd dir) "Doing CD")))
X    (or (car result)
X	(ange-ftp-error host user (concat "CD failed: " (cdr result))))))
X
(defun ange-ftp-get-pwd (host user)
X  "Attempts to get the current working directory for the given HOST/USER pair.
Returns \( DIR . LINE \) where DIR is either the directory or NIL if not found,
and LINE is the relevant success or fail line from the FTP-client."
X  (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD"))
X	 (line (cdr result))
X	 dir)
X    (if (car result)
X	(ange-ftp-save-match-data
X	  (and (or (string-match "\"\\([^\"]*\\)\"" line)
X		   (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
X	       (setq dir (substring line
X				    (match-beginning 1)
X				    (match-end 1))))))
X    (cons dir line)))
X
(defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable))
X
(defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")
X
(defun ange-ftp-expand-dir (host user dir)
X  "Return the result of doing a PWD in the current FTP session to machine HOST
logged in as user USER and cd'd to directory DIR."
X  (let* ((host-type (ange-ftp-host-type host user))
X	 ;; It is more efficient to call ange-ftp-host-type
X	 ;; before binding res, because ange-ftp-host-type sometimes
X	 ;; adds to the info in the expand-dir-hashtable.
X	 (fix-pathname-func
X	  (cdr (assq host-type ange-ftp-fix-path-func-alist)))
X	 (key (concat host "/" user "/" dir))
X	 (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable)))
X    (or res
X	(progn
X	  (or
X	   (string-equal user "anonymous")
X	   (string-equal user "ftp")
X	   (not (eq host-type 'unix))
X	   (let* ((ange-ftp-good-msgs (concat ange-ftp-expand-dir-regexp
X					      "\\|"
X					      ange-ftp-good-msgs))
X		  (result (ange-ftp-send-cmd host user
X					     (list 'get dir "/dev/null")
X					     (format "expanding %s" dir)))
X		  (line (cdr result)))
X	     (setq res
X		   (if (string-match ange-ftp-expand-dir-regexp line)
X		       (substring line 
X				  (match-beginning 1)
X				  (match-end 1))))))
X	  (or res
X	      (if (string-equal dir "~")
X		  (setq res (car (ange-ftp-get-pwd host user)))
X		(let ((home (ange-ftp-expand-dir host user "~")))
X		  (unwind-protect
X		      (and (ange-ftp-cd host user dir)
X			   (setq res (car (ange-ftp-get-pwd host user))))
X		    (ange-ftp-cd host user home)))))
X	  (if res
X	      (progn
X		(if fix-pathname-func
X		    (setq res (funcall fix-pathname-func res 'reverse)))
X		(ange-ftp-put-hash-entry
X		 key res ange-ftp-expand-dir-hashtable)))
X	  res))))
X
(defun ange-ftp-canonize-filename (n)
X  "Take a string and short-circuit //, /. and /.."
X  (if (string-match ".+//" n)		;don't upset Apollo users
X      (setq n (substring n (1- (match-end 0)))))
X  (let ((parsed (ange-ftp-ftp-path n)))
X    (if parsed
X	(let ((host (car parsed))
X	      (user (nth 1 parsed))
X	      (path (nth 2 parsed)))
X	  
X	  ;; See if remote path is absolute.  If so then just expand it and
X	  ;; replace the path component of the overall path.
X	  (cond ((string-match "^/" path)
X		 path)
X		
X		;; Path starts with ~ or ~user.  Resolve that part of the path
X		;; making it absolute then re-expand it.
X		((string-match "^~[^/]*" path)
X		 (let* ((tilda (substring path
X					  (match-beginning 0) 
X					  (match-end 0)))
X			(rest (substring path (match-end 0)))
X			(dir (ange-ftp-expand-dir host user tilda)))
X		   (if dir
X		       (setq path (concat dir rest))
X		     (error "User \"%s\" is not known" 
X			    (substring tilda 1)))))
X		
X		;; relative path.  Tack on homedir and re-expand.
X		(t
X		 (let ((dir (ange-ftp-expand-dir host user "~")))
X		   (if dir
X		       (setq path (concat
X				   (ange-ftp-real-file-name-as-directory dir)
X				   path))
X		     (error "Unable to obtain CWD")))))
X	  
X	  (setq path (ange-ftp-real-expand-file-name path))
X	  
X	  ;; see if hit real expand-file-name bug...  this will probably annoy
X	  ;; some Apollo people.  I'll wait until they shout, however.
X	  (if (string-match "^//" path)
X	      (setq path (substring path 1)))
X	  
X	  ;; Now substitute the expanded path back into the overall filename.
X	  (ange-ftp-replace-path-component n path))
X      
X      ;; non-ange-ftp path.  Just expand normally.
X      (if (eq (string-to-char n) ?/)
X	  (ange-ftp-real-expand-file-name n)
X	(ange-ftp-real-expand-file-name
X	 (ange-ftp-real-file-name-nondirectory n)
X	 (ange-ftp-real-file-name-directory n))))))
X
(defun ange-ftp-expand-file-name (name &optional default)
X  "Documented as original."
X  (ange-ftp-save-match-data
X    (if (eq (string-to-char name) ?/)
X	(while (cond ((string-match ".+//" name) ;don't upset Apollo users
X		      (setq name (substring name (1- (match-end 0)))))
X		     ((string-match "/~" name)
X		      (setq name (substring name (1- (match-end 0))))))))
X    (cond ((eq (string-to-char name) ?~)
X	   (ange-ftp-real-expand-file-name name))
X	  ((eq (string-to-char name) ?/)
X	   (ange-ftp-canonize-filename name))
X	  ((zerop (length name))
X	   (ange-ftp-canonize-filename (or default default-directory)))
X	  ((ange-ftp-canonize-filename
X	    (concat (file-name-as-directory (or default default-directory))
X		    name))))))
X
;;;; ------------------------------------------------------------
;;;; Redefinitions of standard GNU Emacs functions.
;;;; ------------------------------------------------------------
X
(defvar ange-ftp-file-name-as-directory-alist nil
X  "Association list of \( TYPE \. FUNC \) pairs, where
FUNC converts a filename to a directory name for the operating
system TYPE.")
X
(defun ange-ftp-file-name-as-directory (name)
X  "Documented as original."
X  (let ((parsed (ange-ftp-ftp-path name)))
X    (if parsed
X	(if (string-equal (nth 2 parsed) "")
X	    name
X	  (funcall (or (cdr (assq
X			     (ange-ftp-host-type (car parsed))
X			     ange-ftp-file-name-as-directory-alist))
X		       'ange-ftp-real-file-name-as-directory)
X		   name))
X      (ange-ftp-real-file-name-as-directory name))))
X 	
(defun ange-ftp-file-name-directory (name)
X  "Documented as original."
X  (let ((parsed (ange-ftp-ftp-path name)))
X    (if parsed
X	(let ((path (nth 2 parsed)))
X	  (if (ange-ftp-save-match-data
X		(string-match "^~[^/]*$" path))
X	      name
X	    (ange-ftp-replace-path-component
X	     name
X	     (ange-ftp-real-file-name-directory path))))
X      (ange-ftp-real-file-name-directory name))))
X
(defun ange-ftp-file-name-nondirectory (name)
X  "Documented as original."
X  (let ((parsed (ange-ftp-ftp-path name)))
X    (if parsed
X	(let ((path (nth 2 parsed)))
X	  (if (ange-ftp-save-match-data
X		(string-match "^~[^/]*$" path))
X	      ""
X	    (ange-ftp-real-file-name-nondirectory path)))
X      (ange-ftp-real-file-name-nondirectory name))))
X
(defun ange-ftp-directory-file-name (dir)
X  "Documented as original."
X  (let ((parsed (ange-ftp-ftp-path dir)))
X    (if parsed
X	(ange-ftp-replace-path-component
X	   dir
X	   (ange-ftp-real-directory-file-name (nth 2 parsed)))
X      (ange-ftp-real-directory-file-name dir))))
X
(defun ange-ftp-binary-file (file)
X  "Returns whether the given FILE is to be considered as a binary file for
ftp transfers."
X  (ange-ftp-save-match-data
X    (string-match ange-ftp-binary-file-name-regexp file)))
X
(defun ange-ftp-write-region (start end filename &optional append visit)
X  "Documented as original."
X  (interactive "r\nFWrite region to file: ")
X  (setq filename (expand-file-name filename))
X  (let ((parsed (ange-ftp-ftp-path filename)))
X    (if parsed
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	       (cmd (if append 'append 'put))
X	       (abbr (ange-ftp-abbreviate-filename filename)))
X	  (unwind-protect
X	      (progn
X		(let ((executing-macro t)
X		      (filename (buffer-file-name))
X		      (mod-p (buffer-modified-p)))
X		  (unwind-protect
X		      (ange-ftp-real-write-region start end temp nil visit)
X		    ;; cleanup forms
X		    (setq buffer-file-name filename)
X		    (set-buffer-modified-p mod-p)))
X		(if binary
X		    (ange-ftp-set-binary-mode host user))
X
X		;; tell the process filter what size the transfer will be.
X		(let ((attr (file-attributes temp)))
X		  (if attr
X		      (ange-ftp-set-xfer-size host user (nth 7 attr))))
X
X		;; put or append the file.
X		(let ((result (ange-ftp-send-cmd host user
X						 (list cmd temp path)
X						 (format "Writing %s" abbr))))
X		  (or (car result)
X		      (signal 'ftp-error
X			      (list
X			       "Opening output file"
X			       (format "FTP Error: \"%s\"" (cdr result))
SHAR_EOF
true || echo 'restore of ange-ftp.el failed'
fi
echo 'End of part 3, continue with part 4'
echo 4 > _shar_seq_.tmp
exit 0
Newsgroups: gnu.emacs.sources