emacs: lisp/ange-ftp.el comparison

comparison lisp/ange-ftp.el @ 10244:3d95ea97eb9e

(ange-ftp-save-match-data): Macro deleted. Most callers use save-match-data. (ange-ftp-process-filter, ange-ftp-process-sentinel) (ange-ftp-gwp-filter): Don't save the match data explicitly. (ange-ftp-process-filter, ange-ftp-gwp-filter): After comint output processing, update STR.

author	Richard M. Stallman <rms@gnu.org>
date	Sun, 25 Dec 1994 14:35:19 +0000
parents	7e22057e9516
children	8b26137996f9

comparison

equal deleted inserted replaced

-:ea9dda158056
+:3d95ea97eb9e
 ;; New error symbols.
 (put 'ftp-error 'error-conditions '(ftp-error file-error error))
 ;; (put 'ftp-error 'error-message "FTP error")
 ;;; ------------------------------------------------------------
-;;; Match-data support (stolen from Kyle I think)
-;;; ------------------------------------------------------------
-(defmacro ange-ftp-save-match-data (&rest body)
-"Execute the BODY forms, restoring the global value of the match data.
-Also makes matching case-sensitive within BODY."
-(let ((original (make-symbol "match-data"))
-	case-fold-search)
-(list
-'let (list (list original '(match-data)))
-(list 'unwind-protect
-(cons 'progn body)
-(list 'store-match-data original)))))
-(put 'ange-ftp-save-match-data 'lisp-indent-hook 0)
-(put 'ange-ftp-save-match-data 'edebug-form-hook '(&rest form))
-;;; ------------------------------------------------------------
 ;;; Enhanced message support.
 ;;; ------------------------------------------------------------
 (defun ange-ftp-message (fmt &rest args)
 "Display message in echo area, but indicate if truncated.
 (defun ange-ftp-abbreviate-filename (file &optional new)
 "Abbreviate the file name FILE relative to the default-directory.
 If the optional parameter NEW is given and the non-directory parts match,
 only return the directory part of FILE."
-(ange-ftp-save-match-data
+(save-match-data
 (if (and default-directory
 	     (string-match (concat "^"
 				   (regexp-quote default-directory)
 				   ".") file))
 	(setq file (substring file (1- (match-end 0)))))
 (ange-ftp-map-hashtable
 (function (lambda (host val)
 		 (if (ange-ftp-lookup-passwd host user)
 		     (throw 'found-one host))))
 ange-ftp-user-hashtable)
-(ange-ftp-save-match-data
+(save-match-data
 (ange-ftp-map-hashtable
 (function
 	(lambda (key value)
 	  (if (string-match "^[^/]*\\(/\\).*$" key)
 	      (let ((host (substring key 0 (match-beginning 1))))
 (let* ((file (ange-ftp-chase-symlinks
 		(ange-ftp-real-expand-file-name ange-ftp-netrc-filename)))
 	 (attr (ange-ftp-real-file-attributes file)))
 (if (and attr			; file exists.
 	     (not (equal (nth 5 attr) ange-ftp-netrc-modtime)))	; file changed
-	(ange-ftp-save-match-data
+	(save-match-data
 	  (if (or ange-ftp-disable-netrc-security-check
 		  (and (eq (nth 2 attr) (user-uid)) ; Same uids.
 		       (string-match ".r..------" (nth 8 attr))))
 	      (save-excursion
 		;; we are cheating a bit here.  I'm trying to do the equivalent
 ;; Return a list of prefixes of the form 'user@host:' to be used when
 ;; completion is done in the root directory.
 (defun ange-ftp-generate-root-prefixes ()
 (ange-ftp-parse-netrc)
-(ange-ftp-save-match-data
+(save-match-data
 (let (res)
 (ange-ftp-map-hashtable
 (function
 	(lambda (key value)
 	  (if (string-match "^[^/]*\\(/\\).*$" key)
 (defun ange-ftp-ftp-name (name)
 (if (string-equal name ange-ftp-ftp-name-arg)
 ange-ftp-ftp-name-res
 (setq ange-ftp-ftp-name-arg name
 	  ange-ftp-ftp-name-res
-	  (ange-ftp-save-match-data
+	  (save-match-data
 	    (if (string-match (car ange-ftp-name-format) name)
 		(let* ((ns (cdr ange-ftp-name-format))
 		       (host (ange-ftp-ftp-name-component 0 ns name))
 		       (user (ange-ftp-ftp-name-component 1 ns name))
 		       (name (ange-ftp-ftp-name-component 2 ns name)))
 	      nil)))))
 ;; Take a FULLNAME that matches according to ange-ftp-name-format and
 ;; replace the name component with NAME.
 (defun ange-ftp-replace-name-component (fullname name)
-(ange-ftp-save-match-data
+(save-match-data
 (if (string-match (car ange-ftp-name-format) fullname)
 	(let* ((ns (cdr ange-ftp-name-format))
 	       (elt (nth 2 ns)))
 	  (concat (substring fullname 0 (match-beginning elt))
 		  name
 	(old-buffer (current-buffer)))
 ;; see if the buffer is still around... it could have been deleted.
 (if (buffer-name buffer)
 	(unwind-protect
-	    (ange-ftp-save-match-data
+	    (progn
 	      (set-buffer (process-buffer proc))
 	      ;; handle hash mark printing
 	      (and ange-ftp-hash-mark-unit
 		   ange-ftp-process-busy
 		   (string-match "^#+$" str)
 		   (setq str (ange-ftp-process-handle-hash str)))
 	      (comint-output-filter proc str)
+	      ;; Replace STR by the result of the comint processing.
+	      (setq str (buffer-substring comint-last-output-start
+					  (process-mark proc)))
 	      (if ange-ftp-process-busy
 		  (progn
 		    (setq ange-ftp-process-string (concat ange-ftp-process-string
 							  str))
 					      ange-ftp-process-result-line))))))
 	  (set-buffer old-buffer)))))
 (defun ange-ftp-process-sentinel (proc str)
 "When ftp process changes state, nuke all file-entries in cache."
-(ange-ftp-save-match-data
+(let ((name (process-name proc)))
-(let ((name (process-name proc)))
+(if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name)
-(if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)*" name)
+	(let ((user (substring name (match-beginning 1) (match-end 1)))
-	  (let ((user (substring name (match-beginning 1) (match-end 1)))
+	      (host (substring name (match-beginning 2) (match-end 2))))
-		(host (substring name (match-beginning 2) (match-end 2))))
+	  (ange-ftp-wipe-file-entries host user))))
-	    (ange-ftp-wipe-file-entries host user))))
+(setq ange-ftp-ls-cache-file nil))
-(setq ange-ftp-ls-cache-file nil)))
 ;;;; ------------------------------------------------------------
 ;;;; Gateway support.
 ;;;; ------------------------------------------------------------
 (defun ange-ftp-use-gateway-p (host)
 "Returns whether to access this host via a normal (non-smart) gateway."
 ;; yes, I know that I could simplify the following expression, but it is
 ;; clearer (to me at least) this way.
 (and (not ange-ftp-smart-gateway)
-(ange-ftp-save-match-data
+(save-match-data
 	 (not (string-match ange-ftp-local-host-regexp host)))))
 (defun ange-ftp-use-smart-gateway-p (host)
 "Returns whether to access this host via a smart gateway."
 (and ange-ftp-smart-gateway
-(ange-ftp-save-match-data
+(save-match-data
 	 (not (string-match ange-ftp-local-host-regexp host)))))
 ;;; ------------------------------------------------------------
 ;;; Temporary file location and deletion...
 (defun ange-ftp-gwp-sentinel (proc str)
 (setq ange-ftp-gwp-running nil))
 (defun ange-ftp-gwp-filter (proc str)
-(ange-ftp-save-match-data
+(comint-output-filter proc str)
-(comint-output-filter proc str)
+;; Replace STR by the result of the comint processing.
-(cond ((string-match "login: *$" str)
+(setq str (buffer-substring comint-last-output-start (process-mark proc)))
-	   (send-string proc
+(cond ((string-match "login: *$" str)
-			(concat
+	 (send-string proc
-			 (let ((ange-ftp-default-user t))
+		      (concat
-			   (ange-ftp-get-user ange-ftp-gateway-host))
+		       (let ((ange-ftp-default-user t))
-			 "\n")))
+			 (ange-ftp-get-user ange-ftp-gateway-host))
-	  ((string-match "Password: *$" str)
+		       "\n")))
-	   (send-string proc
+	((string-match "Password: *$" str)
-			(concat
+	 (send-string proc
-			 (ange-ftp-get-passwd ange-ftp-gateway-host
+		      (concat
-					      (ange-ftp-get-user
+		       (ange-ftp-get-passwd ange-ftp-gateway-host
-					       ange-ftp-gateway-host))
+					    (ange-ftp-get-user
-			 "\n")))
+					     ange-ftp-gateway-host))
-	  ((string-match ange-ftp-gateway-fatal-msgs str)
+		       "\n")))
-	   (delete-process proc)
+	((string-match ange-ftp-gateway-fatal-msgs str)
-	   (setq ange-ftp-gwp-running nil))
+	 (delete-process proc)
-	  ((string-match ange-ftp-gateway-prompt-pattern str)
+	 (setq ange-ftp-gwp-running nil))
-	   (setq ange-ftp-gwp-running nil
+	((string-match ange-ftp-gateway-prompt-pattern str)
-		 ange-ftp-gwp-status t)))))
+	 (setq ange-ftp-gwp-running nil
+	       ange-ftp-gwp-status t))))
 (defun ange-ftp-gwp-start (host user name args)
 "Login to the gateway machine and fire up an ftp process."
 (let* ((gw-user (ange-ftp-get-user ange-ftp-gateway-host))
 	 ;; It would be nice to make process-connection-type nil,
 	      cmd (concat cmd "\n"))
 	(and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg))
 	(goto-char (point-max))
 	(move-marker comint-last-input-start (point))
 	;; don't insert the password into the buffer on the USER command.
-	(ange-ftp-save-match-data
+	(save-match-data
 	  (if (string-match "^user \"[^\"]*\"" cmd)
 	      (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n")
 	    (insert cmd)))
 	(move-marker comint-last-input-end (point))
 	(send-string proc cmd)
 (save-excursion
 	(set-buffer (process-buffer proc))
 	(let* ((status (ange-ftp-raw-send-cmd proc "hash"))
 	       (result (car status))
 	       (line (cdr status)))
-	  (ange-ftp-save-match-data
+	  (save-match-data
 	    (if (string-match ange-ftp-hash-mark-msgs line)
 		(let ((size (string-to-int
 			    (substring line
 				       (match-beginning 1)
 				       (match-end 1)))))
 Works by doing a pwd and examining the directory syntax."
 (let ((host-type (ange-ftp-host-type host))
 	(key (concat host "/" user "/~")))
 (if (eq host-type 'unix)
 	;; Note that ange-ftp-host-type returns unix as the default value.
-	(ange-ftp-save-match-data
+	(save-match-data
 	  (let* ((result (ange-ftp-get-pwd host user))
 		 (dir (car result))
 		 fix-name-func)
 	    (cond ((null dir)
 		   (message "Warning! Unable to get home directory")
 ;; Returns whether HOST's FTP server doesn't like \'ls\' or \'dir\' commands
 ;; to take switch arguments.
 (defun ange-ftp-dumb-unix-host (host)
 (and ange-ftp-dumb-unix-host-regexp
-(ange-ftp-save-match-data
+(save-match-data
 	 (string-match ange-ftp-dumb-unix-host-regexp host))))
 (defun ange-ftp-add-dumb-unix-host (host)
 "Interactively adds a given HOST to ange-ftp-dumb-unix-host-regexp."
 (interactive
 ;; 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.
 (defun ange-ftp-parse-dired-listing (&optional switches)
-(ange-ftp-save-match-data
+(save-match-data
 (cond
 ((looking-at "^total [0-9]+$")
 (forward-line 1)
 ;; Some systems put in a blank line here.
 (if (eolp) (forward-line 1))
 "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."
 (setq directory (file-name-as-directory directory)) ;normalize
 (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)
-(ange-ftp-save-match-data
+(save-match-data
 	(and (ange-ftp-ls directory
 			  ;; This is an efficiency hack. We try to
 			  ;; anticipate what sort of listing dired
 			  ;; might want, and cache just such a listing.
 			  (if (and (boundp 'dired-actual-switches)
 and LINE is the relevant success or fail line from the FTP-client."
 (let* ((result (ange-ftp-send-cmd host user '(pwd) "Getting PWD"))
 	 (line (cdr result))
 	 dir)
 (if (car result)
-	(ange-ftp-save-match-data
+	(save-match-data
 	  (and (or (string-match "\"\\([^\"]*\\)\"" line)
 		   (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
 	       (setq dir (substring line
 				    (match-beginning 1)
 				    (match-end 1))))))
 	 (ange-ftp-real-file-name-nondirectory n)
 	 (ange-ftp-real-file-name-directory n))))))
 (defun ange-ftp-expand-file-name (name &optional default)
 "Documented as original."
-(ange-ftp-save-match-data
+(save-match-data
 (if (eq (string-to-char name) ?/)
 	(while (cond ((string-match "[^:]+//" name) ;don't upset Apollo users
 		      (setq name (substring name (1- (match-end 0)))))
 		     ((string-match "/~" name)
 		      (setq name (substring name (1- (match-end 0))))))))
 (defun ange-ftp-file-name-directory (name)
 "Documented as original."
 (let ((parsed (ange-ftp-ftp-name name)))
 (if parsed
 	(let ((filename (nth 2 parsed)))
-	  (if (ange-ftp-save-match-data
+	  (if (save-match-data
 		(string-match "^~[^/]*$" filename))
 	      name
 	    (ange-ftp-replace-name-component
 	     name
 	     (ange-ftp-real-file-name-directory filename))))
 (defun ange-ftp-file-name-nondirectory (name)
 "Documented as original."
 (let ((parsed (ange-ftp-ftp-name name)))
 (if parsed
 	(let ((filename (nth 2 parsed)))
-	  (if (ange-ftp-save-match-data
+	  (if (save-match-data
 		(string-match "^~[^/]*$" filename))
 	      ""
 	    (ange-ftp-real-file-name-nondirectory name)))
 (ange-ftp-real-file-name-nondirectory name))))
 ;;; Hooks that handle Emacs primitives.
 ;; Returns non-nil if should transfer FILE in binary mode.
 (defun ange-ftp-binary-file (file)
-(ange-ftp-save-match-data
+(save-match-data
 (string-match ange-ftp-binary-file-name-regexp file)))
 (defun ange-ftp-write-region (start end filename &optional append visit)
 (setq filename (expand-file-name filename))
 (let ((parsed (ange-ftp-ftp-name filename)))
 	(ange-ftp-barf-if-not-directory directory)
 	(let ((tail (ange-ftp-hash-table-keys
 		     (ange-ftp-get-files directory)))
 	      files f)
 	  (setq directory (file-name-as-directory directory))
-	  (ange-ftp-save-match-data
+	  (save-match-data
 	    (while tail
 	      (setq f (car tail)
 		    tail (cdr tail))
 	      (if (or (not match) (string-match match f))
 		  (setq files
 				(lambda (s) (if (stringp s)
 						(concat (regexp-quote s) "$")
 					      "/"))) ; / never in filename
 			       completion-ignored-extensions
 			       "\\|")))
-	      (ange-ftp-save-match-data
+	      (save-match-data
 		(or (ange-ftp-file-name-completion-1
 		     file tbl ange-ftp-this-dir
 		     (function ange-ftp-file-entry-not-ignored-p))
 		    (ange-ftp-file-name-completion-1
 		     file tbl ange-ftp-this-dir
 (if (and parsed
 	     (setq conversion-func
 		   (cdr (assq (ange-ftp-host-type (car parsed))
 			      ange-ftp-make-compressed-filename-alist))))
 	(let* ((decision
-		(ange-ftp-save-match-data (funcall conversion-func name)))
+		(save-match-data (funcall conversion-func name)))
 	       (compressing (car decision))
 	       (newfile (nth 1 decision)))
 	  (if compressing
 	      (ange-ftp-compress name newfile)
 	    (ange-ftp-uncompress name newfile)))
 ;(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
+;       (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."
 ;	(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
+;    (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))
 ;;;; ------------------------------------------------------------
 ;; Convert NAME from UNIX-ish to VMS.  If REVERSE given then convert from VMS
 ;; to UNIX-ish.
 (defun ange-ftp-fix-name-for-vms (name &optional reverse)
-(ange-ftp-save-match-data
+(save-match-data
 (if reverse
 	(if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
 	    (let (drive dir file)
 	      (if (match-beginning 1)
 		  (setq drive (substring name
 (defvar ange-ftp-vms-host-regexp nil)
 ;; Return non-nil if HOST is running VMS.
 (defun ange-ftp-vms-host (host)
 (and ange-ftp-vms-host-regexp
-(ange-ftp-save-match-data
+(save-match-data
 	 (string-match ange-ftp-vms-host-regexp host))))
 ;; 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.
 ;; format, and return a hashtable as the result.
 (defun ange-ftp-parse-vms-listing ()
 (let ((tbl (ange-ftp-make-hashtable))
 	file)
 (goto-char (point-min))
-(ange-ftp-save-match-data
+(save-match-data
 (while (setq file (ange-ftp-parse-vms-filename))
 	(if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
 	    ;; deal with directories
 	    (ange-ftp-put-hash-entry
 	     (substring file 0 (match-beginning 0)) t tbl)
 ;; completion functions?
 (defun ange-ftp-vms-delete-file-entry (name &optional dir-p)
 (if dir-p
 (ange-ftp-internal-delete-file-entry name t)
-(ange-ftp-save-match-data
+(save-match-data
 (let ((file (ange-ftp-get-file-part name)))
 	(if (string-match ";[0-9]+$" file)
 	    ;; In VMS you can't delete a file without an explicit
 	    ;; version number, or wild-card (e.g. FOO;*)
 	    ;; For now, we give up on wildcards.
 (let ((files (ange-ftp-get-hash-entry
 		  (file-name-directory name)
 		  ange-ftp-files-hashtable)))
 (if files
 	  (let ((file (ange-ftp-get-file-part name)))
-	    (ange-ftp-save-match-data
+	    (save-match-data
 	      (if (string-match ";[0-9]+$" file)
 		  (ange-ftp-put-hash-entry
 		   (substring file 0 (match-beginning 0))
 		   nil files)
 		;; Need to figure out what version of the file
 		    ange-ftp-vms-host-regexp)
 	    ange-ftp-host-cache nil)))
 (defun ange-ftp-vms-file-name-as-directory (name)
-(ange-ftp-save-match-data
+(save-match-data
 (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
 	(setq name (substring name 0 (match-beginning 0))))
 (ange-ftp-real-file-name-as-directory name)))
 (or (assq 'vms ange-ftp-file-name-as-directory-alist)
 ;;    (setq ange-ftp-dired-ls-trim-alist
 ;;	  (cons '(vms . ange-ftp-dired-vms-ls-trim)
 ;;		ange-ftp-dired-ls-trim-alist)))
 (defun ange-ftp-vms-sans-version (name)
-(ange-ftp-save-match-data
+(save-match-data
 (if (string-match ";[0-9]+$" name)
 	(substring name 0 (match-beginning 0))
 name)))
 (or (assq 'vms ange-ftp-sans-version-alist)
 ;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from
 ;; MTS to UNIX-ish.
 (defun ange-ftp-fix-name-for-mts (name &optional reverse)
-(ange-ftp-save-match-data
+(save-match-data
 (if reverse
 	(if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
 	    (let (acct file)
 	      (if (match-beginning 1)
 		  (setq acct (substring name 0 (match-end 1))))
 (defvar ange-ftp-mts-host-regexp nil)
 ;; Return non-nil if HOST is running MTS.
 (defun ange-ftp-mts-host (host)
 (and ange-ftp-mts-host-regexp
-(ange-ftp-save-match-data
+(save-match-data
 	 (string-match ange-ftp-mts-host-regexp host))))
 ;; Parse the current buffer which is assumed to be in mts ftp dir format.
 (defun ange-ftp-parse-mts-listing ()
 (let ((tbl (ange-ftp-make-hashtable)))
 (goto-char (point-min))
-(ange-ftp-save-match-data
+(save-match-data
 (while (re-search-forward ange-ftp-date-regexp nil t)
 	(end-of-line)
 	(skip-chars-backward " ")
 	(let ((end (point)))
 	  (skip-chars-backward "-A-Z0-9_.!")
 ;; usually close the connection after 5 minutes of inactivity.
 ;; Have I got the filename character set right?
 (defun ange-ftp-fix-name-for-cms (name &optional reverse)
-(ange-ftp-save-match-data
+(save-match-data
 (if reverse
 	;; Since we only convert output from a pwd in this direction,
 	;; we'll assume that it's a minidisk, and make it into a
 	;; directory file name. Note that the expand-dir-hashtable
 	;; stores directories without the trailing /. Is this
 "Regular expression to match hosts running the CMS operating system.")
 ;; Return non-nil if HOST is running CMS.
 (defun ange-ftp-cms-host (host)
 (and ange-ftp-cms-host-regexp
-(ange-ftp-save-match-data
+(save-match-data
 	 (string-match ange-ftp-cms-host-regexp host))))
 (defun ange-ftp-add-cms-host (host)
 "Mark HOST as the name of a CMS host."
 (interactive
 ;      (ange-ftp-put-hash-entry "." t root-tbl)
 ;      (ange-ftp-set-files root root-tbl)))
 ;; Now do the usual parsing
 (let ((tbl (ange-ftp-make-hashtable)))
 (goto-char (point-min))
-(ange-ftp-save-match-data
+(save-match-data
 (while
 	  (re-search-forward
 	   "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
 	(ange-ftp-put-hash-entry
 	 (concat (buffer-substring (match-beginning 1)

Mercurial > emacs

comparison lisp/ange-ftp.el @ 10244:3d95ea97eb9e