/[emacs]/emacs/lisp/net/ange-ftp.el
ViewVC logotype

Diff of /emacs/lisp/net/ange-ftp.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.35 by monnier, Fri May 24 22:01:56 2002 UTC revision 1.35.2.1 by miles, Fri Apr 4 06:20:30 2003 UTC
# Line 428  Line 428 
428  ;; ange-ftp-bs2000-special-prefix because names starting with # or @  ;; ange-ftp-bs2000-special-prefix because names starting with # or @
429  ;; are reserved for temporary files.  ;; are reserved for temporary files.
430  ;; This is especially important for auto-save files.  ;; This is especially important for auto-save files.
431  ;; Valid file generations are ending with ([+|-|*]0-9...) .  ;; Valid file generations are ending with ([+|-|*]0-9...) .
432  ;; File generations are not supported yet!  ;; File generations are not supported yet!
433  ;; A filename must at least contain one character (A-Z) and cannot be longer  ;; A filename must at least contain one character (A-Z) and cannot be longer
434  ;; than 41 characters.  ;; than 41 characters.
# Line 543  Line 543 
543  ;; aspects of ange-ftp.  New versions of ange-ftp are posted periodically to  ;; aspects of ange-ftp.  New versions of ange-ftp are posted periodically to
544  ;; the mailing list.  ;; the mailing list.
545    
 ;; [The following information about lists may be obsolete.]  
   
546  ;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the  ;; To [un]subscribe to ange-ftp-lovers, or to report mailer problems with the
547  ;; list, please mail one of the following addresses:  ;; list, please mail one of the following addresses:
548  ;;  ;;
549  ;;     ange-ftp-lovers-request@anorman.hpl.hp.com  ;;     ange-ftp-lovers-request@hplb.hpl.hp.com
 ;; or  
 ;;     ange-ftp-lovers-request%anorman.hpl.hp.com@hplb.hpl.hp.com  
550  ;;  ;;
551  ;; Please don't forget the -request part.  ;; Please don't forget the -request part.
552  ;;  ;;
553  ;; For mail to be posted directly to ange-ftp-lovers, send to one of the  ;; For mail to be posted directly to ange-ftp-lovers, send to one of the
554  ;; following addresses:  ;; following addresses:
555  ;;  ;;
556  ;;     ange-ftp-lovers@anorman.hpl.hp.com  ;;     ange-ftp-lovers@hplb.hpl.hp.com
 ;; or  
 ;;     ange-ftp-lovers%anorman.hpl.hp.com@hplb.hpl.hp.com  
557  ;;  ;;
558  ;; Alternatively, there is a mailing list that only gets announcements of new  ;; Alternatively, there is a mailing list that only gets announcements of new
559  ;; ange-ftp releases.  This is called ange-ftp-lovers-announce, and can be  ;; ange-ftp releases.  This is called ange-ftp-lovers-announce, and can be
560  ;; subscribed to by e-mailing to the -request address as above.  Please make  ;; subscribed to by e-mailing to the -request address as above.  Please make
561  ;; it clear in the request which mailing list you wish to join.  ;; it clear in the request which mailing list you wish to join.
   
 ;; The archives for ange-ftp-lovers can be found via anonymous ftp under:  
 ;;  
 ;;     ftp.reed.edu:pub/mailing-lists/ange-ftp/  
562    
563  ;; -----------------------------------------------------------  ;; -----------------------------------------------------------
564  ;; Technical information on this package:  ;; Technical information on this package:
# Line 738  parenthesized expressions in REGEXP for Line 728  parenthesized expressions in REGEXP for
728            "^Data connection \\|"            "^Data connection \\|"
729            "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"            "^local:\\|^Trying\\|^125 \\|^550-\\|^221 .*oodbye\\|"
730            "^500 .*AUTH \\(KERBEROS\\|GSSAPI\\)\\|^KERBEROS\\|"            "^500 .*AUTH \\(KERBEROS\\|GSSAPI\\)\\|^KERBEROS\\|"
731              "^530 Please login with USER and PASS\\|" ; non kerberised vsFTPd
732            "^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT")            "^22[789] .*[Pp]assive\\|^200 EPRT\\|^500 .*EPRT")
733    "*Regular expression matching ftp messages that can be ignored."    "*Regular expression matching ftp messages that can be ignored."
734    :group 'ange-ftp    :group 'ange-ftp
# Line 916  This command should stop the terminal fr Line 907  This command should stop the terminal fr
907  arrange to strip out trailing ^M characters.")  arrange to strip out trailing ^M characters.")
908    
909  (defcustom ange-ftp-smart-gateway nil  (defcustom ange-ftp-smart-gateway nil
910    "*Non-nil means the ftp gateway and/or the gateway ftp program is smart.    "*Non-nil says the ftp gateway (proxy) or gateway ftp program is smart.
911    
912  Don't bother telnetting, etc., already connected to desired host transparently,  Don't bother telnetting, etc., already connected to desired host transparently,
913  or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil."  or just issue a user@host command in case \`ange-ftp-gateway-host\' is non-nil.
914    See also `ange-ftp-smart-gateway-port'."
915    :group 'ange-ftp    :group 'ange-ftp
916    :type 'boolean)    :type 'boolean)
917    
# Line 1020  or nil meaning don't change it." Line 1012  or nil meaning don't change it."
1012    
1013  (require 'backquote)  (require 'backquote)
1014    
 (defun ange-ftp-make-hashtable (&optional size)  
   "Make an obarray suitable for use as a hashtable.  
 SIZE, if supplied, should be a prime number."  
   (make-vector (or size 31) 0))  
   
 (defun ange-ftp-map-hashtable (fun tbl)  
   "Call FUNCTION on each key and value in HASHTABLE."  
   (mapatoms  
    (function  
     (lambda (sym)  
       (funcall fun (get sym 'key) (get sym 'val))))  
    tbl))  
   
 (defmacro ange-ftp-make-hash-key (key)  
   "Convert KEY into a suitable key for a hashtable."  
   `(if (stringp ,key)  
        ,key  
      (prin1-to-string ,key)))  
   
 (defun ange-ftp-get-hash-entry (key tbl)  
   "Return the value associated with KEY in HASHTABLE."  
   (let ((sym (intern-soft (ange-ftp-make-hash-key key) tbl)))  
     (and sym (get sym 'val))))  
   
 (defun ange-ftp-put-hash-entry (key val tbl)  
   "Record an association between KEY and VALUE in HASHTABLE."  
   (let ((sym (intern (ange-ftp-make-hash-key key) tbl)))  
     (put sym 'val val)  
     (put sym 'key key)))  
   
 (defun ange-ftp-del-hash-entry (key tbl)  
   "Copy all symbols except KEY in HASHTABLE and return modified hashtable."  
   (let* ((len (length tbl))  
          (new-tbl (ange-ftp-make-hashtable len))  
          (i (1- len)))  
     (ange-ftp-map-hashtable  
      (function  
       (lambda (k v)  
         (or (equal k key)  
             (ange-ftp-put-hash-entry k v new-tbl))))  
      tbl)  
     (while (>= i 0)  
       (aset tbl i (aref new-tbl i))  
       (setq i (1- i)))  
     tbl))  
   
1015  (defun ange-ftp-hash-entry-exists-p (key tbl)  (defun ange-ftp-hash-entry-exists-p (key tbl)
1016    "Return whether there is an association for KEY in TABLE."    "Return whether there is an association for KEY in TABLE."
1017    (intern-soft (ange-ftp-make-hash-key key) tbl))    (not (eq (gethash key tbl 'unknown) 'unknown)))
1018    
1019  (defun ange-ftp-hash-table-keys (tbl)  (defun ange-ftp-hash-table-keys (tbl)
1020    "Return a sorted list of all the active keys in TABLE, as strings."    "Return a sorted list of all the active keys in TABLE, as strings."
1021    (sort (all-completions "" tbl)    ;; (let ((keys nil))
1022          (function string-lessp)))    ;;   (maphash (lambda (k v) (push k keys)) tbl)
1023      ;;   (sort keys 'string-lessp))
1024      (sort (all-completions "" tbl) 'string-lessp))
1025    
1026  ;;;; ------------------------------------------------------------  ;;;; ------------------------------------------------------------
1027  ;;;; Internal variables.  ;;;; Internal variables.
# Line 1085  SIZE, if supplied, should be a prime num Line 1033  SIZE, if supplied, should be a prime num
1033  (defvar ange-ftp-netrc-modtime nil  (defvar ange-ftp-netrc-modtime nil
1034    "Last modified time of the netrc file from file-attributes.")    "Last modified time of the netrc file from file-attributes.")
1035    
1036  (defvar ange-ftp-user-hashtable (ange-ftp-make-hashtable)  (defvar ange-ftp-user-hashtable (make-hash-table :test 'equal)
1037    "Hash table holding associations between HOST, USER pairs.")    "Hash table holding associations between HOST, USER pairs.")
1038    
1039  (defvar ange-ftp-passwd-hashtable (ange-ftp-make-hashtable)  (defvar ange-ftp-passwd-hashtable (make-hash-table :test 'equal)
1040    "Mapping between a HOST, USER pair and a PASSWORD for them.    "Mapping between a HOST, USER pair and a PASSWORD for them.
1041  All HOST values should be in lower case.")  All HOST values should be in lower case.")
1042    
1043  (defvar ange-ftp-account-hashtable (ange-ftp-make-hashtable)  (defvar ange-ftp-account-hashtable (make-hash-table :test 'equal)
1044    "Mapping between a HOST, USER pair and a ACCOUNT password for them.")    "Mapping between a HOST, USER pair and a ACCOUNT password for them.")
1045    
1046  (defvar ange-ftp-files-hashtable (ange-ftp-make-hashtable 97)  (defvar ange-ftp-files-hashtable (make-hash-table :test 'equal :size 97)
1047    "Hash table for storing directories and their respective files.")    "Hash table for storing directories and their respective files.")
1048    
1049  (defvar ange-ftp-inodes-hashtable (ange-ftp-make-hashtable 97)  (defvar ange-ftp-inodes-hashtable (make-hash-table :test 'equal :size 97)
1050    "Hash table for storing file names and their \"inode numbers\".")    "Hash table for storing file names and their \"inode numbers\".")
1051    
1052  (defvar ange-ftp-next-inode-number 1  (defvar ange-ftp-next-inode-number 1
# Line 1113  All HOST values should be in lower case. Line 1061  All HOST values should be in lower case.
1061  (defvar ange-ftp-ls-cache-res nil  (defvar ange-ftp-ls-cache-res nil
1062    "Last result returned from ange-ftp-ls.")    "Last result returned from ange-ftp-ls.")
1063    
1064  (defconst ange-ftp-expand-dir-hashtable (ange-ftp-make-hashtable))  (defconst ange-ftp-expand-dir-hashtable (make-hash-table :test 'equal))
1065    
1066  (defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")  (defconst ange-ftp-expand-dir-regexp "^5.0 \\([^: ]+\\):")
1067    
# Line 1151  All HOST values should be in lower case. Line 1099  All HOST values should be in lower case.
1099  (defun ange-ftp-message (fmt &rest args)  (defun ange-ftp-message (fmt &rest args)
1100    "Display message in echo area, but indicate if truncated.    "Display message in echo area, but indicate if truncated.
1101  Args are as in `message': a format string, plus arguments to be formatted."  Args are as in `message': a format string, plus arguments to be formatted."
1102    (let ((msg (apply (function format) fmt args))    (let ((msg (apply 'format fmt args))
1103          (max (window-width (minibuffer-window))))          (max (window-width (minibuffer-window))))
1104      (if noninteractive      (if noninteractive
1105          msg          msg
# Line 1183  only return the directory part of FILE." Line 1131  only return the directory part of FILE."
1131  (defun ange-ftp-set-user (host user)  (defun ange-ftp-set-user (host user)
1132    "For a given HOST, set or change the default USER."    "For a given HOST, set or change the default USER."
1133    (interactive "sHost: \nsUser: ")    (interactive "sHost: \nsUser: ")
1134    (ange-ftp-put-hash-entry host user ange-ftp-user-hashtable))    (puthash host user ange-ftp-user-hashtable))
1135    
1136  (defun ange-ftp-get-user (host)  (defun ange-ftp-get-user (host)
1137    "Given a HOST, return the default USER."    "Given a HOST, return the default USER."
1138    (ange-ftp-parse-netrc)    (ange-ftp-parse-netrc)
1139    (let ((user (ange-ftp-get-hash-entry host ange-ftp-user-hashtable)))    (let ((user (gethash host ange-ftp-user-hashtable)))
1140      (or user      (or user
1141          (prog1          (prog1
1142              (setq user              (setq user
# Line 1214  only return the directory part of FILE." Line 1162  only return the directory part of FILE."
1162    `(concat (downcase ,host) "/" ,user))    `(concat (downcase ,host) "/" ,user))
1163    
1164  (defmacro ange-ftp-lookup-passwd (host user)  (defmacro ange-ftp-lookup-passwd (host user)
1165    `(ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key ,host ,user)    `(gethash (ange-ftp-generate-passwd-key ,host ,user)
1166                              ange-ftp-passwd-hashtable))              ange-ftp-passwd-hashtable))
1167    
1168  (defun ange-ftp-set-passwd (host user passwd)  (defun ange-ftp-set-passwd (host user passwd)
1169    "For a given HOST and USER, set or change the associated PASSWORD."    "For a given HOST and USER, set or change the associated PASSWORD."
1170    (interactive (list (read-string "Host: ")    (interactive (list (read-string "Host: ")
1171                       (read-string "User: ")                       (read-string "User: ")
1172                       (read-passwd "Password: ")))                       (read-passwd "Password: ")))
1173    (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)    (puthash (ange-ftp-generate-passwd-key host user)
1174                             passwd             passwd ange-ftp-passwd-hashtable))
                            ange-ftp-passwd-hashtable))  
1175    
1176  (defun ange-ftp-get-host-with-passwd (user)  (defun ange-ftp-get-host-with-passwd (user)
1177    "Given a USER, return a host we know the password for."    "Given a USER, return a host we know the password for."
1178    (ange-ftp-parse-netrc)    (ange-ftp-parse-netrc)
1179    (catch 'found-one    (catch 'found-one
1180      (ange-ftp-map-hashtable      (maphash
1181       (function (lambda (host val)       (lambda (host val)
1182                   (if (ange-ftp-lookup-passwd host user)         (if (ange-ftp-lookup-passwd host user) (throw 'found-one host)))
                      (throw 'found-one host))))  
1183       ange-ftp-user-hashtable)       ange-ftp-user-hashtable)
1184      (save-match-data      (save-match-data
1185        (ange-ftp-map-hashtable        (maphash
1186         (function         (lambda (key value)
1187          (lambda (key value)           (if (string-match "^[^/]*\\(/\\).*$" key)
1188            (if (string-match "^[^/]*\\(/\\).*$" key)               (let ((host (substring key 0 (match-beginning 1))))
1189                (let ((host (substring key 0 (match-beginning 1))))                 (if (and (string-equal user (substring key (match-end 1)))
1190                  (if (and (string-equal user (substring key (match-end 1)))                          value)
1191                           value)                     (throw 'found-one host)))))
                     (throw 'found-one host))))))  
1192         ange-ftp-passwd-hashtable))         ange-ftp-passwd-hashtable))
1193      nil))      nil))
1194    
# Line 1310  only return the directory part of FILE." Line 1255  only return the directory part of FILE."
1255    (interactive (list (read-string "Host: ")    (interactive (list (read-string "Host: ")
1256                       (read-string "User: ")                       (read-string "User: ")
1257                       (read-passwd "Account password: ")))                       (read-passwd "Account password: ")))
1258    (ange-ftp-put-hash-entry (ange-ftp-generate-passwd-key host user)    (puthash (ange-ftp-generate-passwd-key host user)
1259                             account             account ange-ftp-account-hashtable))
                            ange-ftp-account-hashtable))  
1260    
1261  (defun ange-ftp-get-account (host user)  (defun ange-ftp-get-account (host user)
1262    "Given a HOST and USER, return the FTP account."    "Given a HOST and USER, return the FTP account."
1263    (ange-ftp-parse-netrc)    (ange-ftp-parse-netrc)
1264    (or (ange-ftp-get-hash-entry (ange-ftp-generate-passwd-key host user)    (or (gethash (ange-ftp-generate-passwd-key host user)
1265                                 ange-ftp-account-hashtable)                 ange-ftp-account-hashtable)
1266        (and (stringp ange-ftp-default-user)        (and (stringp ange-ftp-default-user)
1267             (string-equal user ange-ftp-default-user)             (string-equal user ange-ftp-default-user)
1268             ange-ftp-default-account)             ange-ftp-default-account)
# Line 1434  only return the directory part of FILE." Line 1378  only return the directory part of FILE."
1378                  (setq buffer-file-name file)                  (setq buffer-file-name file)
1379                  (setq default-directory (file-name-directory file))                  (setq default-directory (file-name-directory file))
1380                  (normal-mode t)                  (normal-mode t)
1381                  (mapcar 'funcall find-file-hooks)                  (run-hooks 'find-file-hook)
1382                  (setq buffer-file-name nil)                  (setq buffer-file-name nil)
1383                  (goto-char (point-min))                  (goto-char (point-min))
1384                  (skip-chars-forward " \t\r\n")                  (skip-chars-forward " \t\r\n")
# Line 1453  only return the directory part of FILE." Line 1397  only return the directory part of FILE."
1397    (ange-ftp-parse-netrc)    (ange-ftp-parse-netrc)
1398    (save-match-data    (save-match-data
1399      (let (res)      (let (res)
1400        (ange-ftp-map-hashtable        (maphash
1401         (function         (lambda (key value)
1402          (lambda (key value)           (if (string-match "^[^/]*\\(/\\).*$" key)
1403            (if (string-match "^[^/]*\\(/\\).*$" key)               (let ((host (substring key 0 (match-beginning 1)))
1404                (let ((host (substring key 0 (match-beginning 1)))                     (user (substring key (match-end 1))))
1405                      (user (substring key (match-end 1))))                 (push (concat user "@" host ":") res))))
                 (push (concat user "@" host ":") res)))))  
1406         ange-ftp-passwd-hashtable)         ange-ftp-passwd-hashtable)
1407        (ange-ftp-map-hashtable        (maphash
1408         (function (lambda (host user)         (lambda (host user) (push (concat host ":") res))
                    (push (concat host ":") res)))  
1409         ange-ftp-user-hashtable)         ange-ftp-user-hashtable)
1410        (or res (list nil)))))        (or res (list nil)))))
1411    
# Line 1474  only return the directory part of FILE." Line 1416  only return the directory part of FILE."
1416  (defmacro ange-ftp-ftp-name-component (n ns name)  (defmacro ange-ftp-ftp-name-component (n ns name)
1417    "Extract the Nth ftp file name component from NS."    "Extract the Nth ftp file name component from NS."
1418    `(let ((elt (nth ,n ,ns)))    `(let ((elt (nth ,n ,ns)))
1419      (if (match-beginning elt)       (match-string elt ,name)))
         (substring ,name (match-beginning elt) (match-end elt)))))  
1420    
1421  (defvar ange-ftp-ftp-name-arg "")  (defvar ange-ftp-ftp-name-arg "")
1422  (defvar ange-ftp-ftp-name-res nil)  (defvar ange-ftp-ftp-name-res nil)
# Line 1562  then kill the related ftp process." Line 1503  then kill the related ftp process."
1503    
1504  (defun ange-ftp-quote-string (string)  (defun ange-ftp-quote-string (string)
1505    "Quote any characters in STRING that may confuse the ftp process."    "Quote any characters in STRING that may confuse the ftp process."
1506    (apply (function concat)    (apply 'concat
1507           (mapcar (function           (mapcar (lambda (char)
1508                    ;; This is said to be wrong; ftp is said to                     ;; This is said to be wrong; ftp is said to
1509                    ;; need quoting only for ", and that by doubling it.                     ;; need quoting only for ", and that by doubling it.
1510                    ;; But experiment says this kind of quoting is correct                     ;; But experiment says this kind of quoting is correct
1511                    ;; when talking to ftp on GNU/Linux systems.                     ;; when talking to ftp on GNU/Linux systems.
1512                     (lambda (char)                     (if (or (<= char ? )
1513                       (if (or (<= char ? )                             (> char ?\~)
1514                               (> char ?\~)                             (= char ?\")
1515                               (= char ?\")                             (= char ?\\))
1516                               (= char ?\\))                         (vector ?\\ char)
1517                           (vector ?\\ char)                       (vector char)))
                        (vector char))))  
1518                   string)))                   string)))
1519    
1520  (defun ange-ftp-barf-if-not-directory (directory)  (defun ange-ftp-barf-if-not-directory (directory)
# Line 1596  Try to categorize it into one of four ca Line 1536  Try to categorize it into one of four ca
1536  good, skip, fatal, or unknown."  good, skip, fatal, or unknown."
1537    (cond ((string-match ange-ftp-xfer-size-msgs line)    (cond ((string-match ange-ftp-xfer-size-msgs line)
1538           (setq ange-ftp-xfer-size           (setq ange-ftp-xfer-size
1539                 (/ (string-to-number (substring line                 (/ (string-to-number (match-string 1 line))
                                                (match-beginning 1)  
                                                (match-end 1)))  
1540                    1024)))                    1024)))
1541          ((string-match ange-ftp-skip-msgs line)          ((string-match ange-ftp-skip-msgs line)
1542           t)           t)
# Line 1653  good, skip, fatal, or unknown." Line 1591  good, skip, fatal, or unknown."
1591         (let ((kbytes (ash (* ange-ftp-hash-mark-unit         (let ((kbytes (ash (* ange-ftp-hash-mark-unit
1592                               ange-ftp-hash-mark-count)                               ange-ftp-hash-mark-count)
1593                            -6)))                            -6)))
1594         (if (zerop ange-ftp-xfer-size)           (if (zerop ange-ftp-xfer-size)
1595             (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)               (ange-ftp-message "%s...%dk" ange-ftp-process-msg kbytes)
1596           (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size)))             (let ((percent (/ (* 100 kbytes) ange-ftp-xfer-size)))
1597             ;; cut out the redisplay of identical %-age messages.               ;; cut out the redisplay of identical %-age messages.
1598             (if (not (eq percent ange-ftp-last-percent))               (unless (eq percent ange-ftp-last-percent)
1599                 (progn                 (setq ange-ftp-last-percent percent)
1600                   (setq ange-ftp-last-percent percent)                 (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent))))))
                  (ange-ftp-message "%s...%d%%" ange-ftp-process-msg percent)))))))  
1601    str)    str)
1602    
1603  ;; Call the function specified by CONT.  CONT can be either a function  ;; Call the function specified by CONT.  CONT can be either a function
# Line 1750  good, skip, fatal, or unknown." Line 1687  good, skip, fatal, or unknown."
1687    "When ftp process changes state, nuke all file-entries in cache."    "When ftp process changes state, nuke all file-entries in cache."
1688    (let ((name (process-name proc)))    (let ((name (process-name proc)))
1689      (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)      (if (string-match "\\*ftp \\([^@]+\\)@\\([^*]+\\)\\*" name)
1690          (let ((user (substring name (match-beginning 1) (match-end 1)))          (let ((user (match-string 1 name))
1691                (host (substring name (match-beginning 2) (match-end 2))))                (host (match-string 2 name)))
1692            (ange-ftp-wipe-file-entries host user))))            (ange-ftp-wipe-file-entries host user))))
1693    (setq ange-ftp-ls-cache-file nil))    (setq ange-ftp-ls-cache-file nil))
1694    
# Line 1781  good, skip, fatal, or unknown." Line 1718  good, skip, fatal, or unknown."
1718  (defun ange-ftp-make-tmp-name (host)  (defun ange-ftp-make-tmp-name (host)
1719    "This routine will return the name of a new file."    "This routine will return the name of a new file."
1720    (make-temp-file (if (ange-ftp-use-gateway-p host)    (make-temp-file (if (ange-ftp-use-gateway-p host)
1721                         ange-ftp-gateway-tmp-name-template                        ange-ftp-gateway-tmp-name-template
1722                       ange-ftp-tmp-name-template)))                      ange-ftp-tmp-name-template)))
1723    
1724  (defalias 'ange-ftp-del-tmp-name 'delete-file)  (defalias 'ange-ftp-del-tmp-name 'delete-file)
1725    
# Line 1832  good, skip, fatal, or unknown." Line 1769  good, skip, fatal, or unknown."
1769                   (start-process name name                   (start-process name name
1770                                  ange-ftp-gateway-program                                  ange-ftp-gateway-program
1771                                  ange-ftp-gateway-host)))                                  ange-ftp-gateway-host)))
1772           (ftp (mapconcat (function identity) args " ")))           (ftp (mapconcat 'identity args " ")))
1773      (process-kill-without-query proc)      (process-kill-without-query proc)
1774      (set-process-sentinel proc (function ange-ftp-gwp-sentinel))      (set-process-sentinel proc 'ange-ftp-gwp-sentinel)
1775      (set-process-filter proc (function ange-ftp-gwp-filter))      (set-process-filter proc 'ange-ftp-gwp-filter)
1776      (save-excursion      (save-excursion
1777        (set-buffer (process-buffer proc))        (set-buffer (process-buffer proc))
1778        (goto-char (point-max))        (goto-char (point-max))
# Line 1949  been queued with no result.  CONT will s Line 1886  been queued with no result.  CONT will s
1886              (accept-process-output proc))              (accept-process-output proc))
1887            (goto-char (point-min))            (goto-char (point-min))
1888            (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)            (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
1889                (setq res (buffer-substring (match-beginning 1)                (setq res (match-string 1)))
                                           (match-end 1))))  
1890            (kill-buffer (current-buffer)))            (kill-buffer (current-buffer)))
1891          res)          res)
1892      host))      host))
# Line 2001  on the gateway machine to do the ftp ins Line 1937  on the gateway machine to do the ftp ins
1937        (goto-char (point-max))        (goto-char (point-max))
1938        (set-marker (process-mark proc) (point)))        (set-marker (process-mark proc) (point)))
1939      (process-kill-without-query proc)      (process-kill-without-query proc)
1940      (set-process-sentinel proc (function ange-ftp-process-sentinel))      (set-process-sentinel proc 'ange-ftp-process-sentinel)
1941      (set-process-filter proc (function ange-ftp-process-filter))      (set-process-filter proc 'ange-ftp-process-filter)
1942      ;; On Windows, the standard ftp client buffers its output (because      ;; On Windows, the standard ftp client buffers its output (because
1943      ;; stdout is a pipe handle) so the startup message may never appear:      ;; stdout is a pipe handle) so the startup message may never appear:
1944      ;; `accept-process-output' at this point would hang indefinitely.      ;; `accept-process-output' at this point would hang indefinitely.
# Line 2151  suffix of the form #PORT to specify a no Line 2087  suffix of the form #PORT to specify a no
2087                  ange-ftp-skip-msgs skip)))                  ange-ftp-skip-msgs skip)))
2088        (or (car result)        (or (car result)
2089            (progn            (progn
2090              (ange-ftp-set-passwd host user nil) ;reset password.              (ange-ftp-set-passwd host user nil) ;reset password.
2091              (ange-ftp-set-account host user nil) ;reset account.              (ange-ftp-set-account host user nil) ;reset account.
2092              (ange-ftp-error host user              (ange-ftp-error host user
2093                              (concat "USER request failed: "                              (concat "USER request failed: "
# Line 2171  suffix of the form #PORT to specify a no Line 2107  suffix of the form #PORT to specify a no
2107                 (line (cdr status)))                 (line (cdr status)))
2108            (save-match-data            (save-match-data
2109              (if (string-match ange-ftp-hash-mark-msgs line)              (if (string-match ange-ftp-hash-mark-msgs line)
2110                  (let ((size (string-to-int                  (let ((size (string-to-int (match-string 1 line))))
                             (substring line  
                                        (match-beginning 1)  
                                        (match-end 1)))))  
2111                    (setq ange-ftp-ascii-hash-mark-size size                    (setq ange-ftp-ascii-hash-mark-size size
2112                          ange-ftp-hash-mark-unit (ash size -4))                          ange-ftp-hash-mark-unit (ash size -4))
2113    
# Line 2222  Create a new process if needed." Line 2155  Create a new process if needed."
2155    
2156          ;; Run any user-specified hooks.  Note that proc, host and user are          ;; Run any user-specified hooks.  Note that proc, host and user are
2157          ;; dynamically bound at this point.          ;; dynamically bound at this point.
2158          (run-hooks 'ange-ftp-process-startup-hook))          (let ((ange-ftp-this-user user)
2159                  (ange-ftp-this-host host))
2160              (run-hooks 'ange-ftp-process-startup-hook)))
2161        proc)))        proc)))
2162    
2163  (defun ange-ftp-passive-mode (proc on-or-off)  (defun ange-ftp-passive-mode (proc on-or-off)
# Line 2516  Works by doing a pwd and examining the d Line 2451  Works by doing a pwd and examining the d
2451                                               ange-ftp-fix-name-func-alist)))                                               ange-ftp-fix-name-func-alist)))
2452                (if fix-name-func                (if fix-name-func
2453                    (setq dir (funcall fix-name-func dir 'reverse))))                    (setq dir (funcall fix-name-func dir 'reverse))))
2454              (ange-ftp-put-hash-entry key dir              (puthash key dir ange-ftp-expand-dir-hashtable))))
                                      ange-ftp-expand-dir-hashtable))))  
2455    
2456      ;; In the special case of CMS make sure that know the      ;; In the special case of CMS make sure that know the
2457      ;; expansion of the home minidisk now, because we will      ;; expansion of the home minidisk now, because we will
# Line 2527  Works by doing a pwd and examining the d Line 2461  Works by doing a pwd and examining the d
2461                     key ange-ftp-expand-dir-hashtable)))                     key ange-ftp-expand-dir-hashtable)))
2462          (let ((dir (car (ange-ftp-get-pwd host user))))          (let ((dir (car (ange-ftp-get-pwd host user))))
2463            (if dir            (if dir
2464                (ange-ftp-put-hash-entry key (concat "/" dir)                (puthash key (concat "/" dir) ange-ftp-expand-dir-hashtable)
                                        ange-ftp-expand-dir-hashtable)  
2465              (message "Warning! Unable to get home directory")              (message "Warning! Unable to get home directory")
2466              (sit-for 1))))))              (sit-for 1))))))
2467    
# Line 2594  which can parse the output from a DIR li Line 2527  which can parse the output from a DIR li
2527  FILE is the full name of the remote file, LSARGS is any args to pass to the  FILE is the full name of the remote file, LSARGS is any args to pass to the
2528  `ls' command, and PARSE specifies that the output should be parsed and stored  `ls' command, and PARSE specifies that the output should be parsed and stored
2529  away in the internal cache."  away in the internal cache."
2530      (when (string-match "^--dired\\s-+" lsargs)
2531        (setq lsargs (replace-match "" nil t lsargs)))
2532    ;; If parse is t, we assume that file is a directory. i.e. we only parse    ;; If parse is t, we assume that file is a directory. i.e. we only parse
2533    ;; full directory listings.    ;; full directory listings.
2534    (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file))    (let* ((ange-ftp-this-file (ange-ftp-expand-file-name file))
# Line 2611  away in the internal cache." Line 2546  away in the internal cache."
2546            (if (string-equal name "")            (if (string-equal name "")
2547                (setq name                (setq name
2548                      (ange-ftp-real-file-name-as-directory                      (ange-ftp-real-file-name-as-directory
2549                            (ange-ftp-expand-dir host user "~"))))                       (ange-ftp-expand-dir host user "~"))))
2550            (if (and ange-ftp-ls-cache-file            (if (and ange-ftp-ls-cache-file
2551                     (string-equal key ange-ftp-ls-cache-file)                     (string-equal key ange-ftp-ls-cache-file)
2552                     ;; Don't care about lsargs for dumb hosts.                     ;; Don't care about lsargs for dumb hosts.
# Line 2760  The main reason for this alist is to dea Line 2695  The main reason for this alist is to dea
2695  ;; unquoting names obtained with the SysV b switch and the GNU Q  ;; unquoting names obtained with the SysV b switch and the GNU Q
2696  ;; switch. See Sebastian's dired-get-filename.  ;; switch. See Sebastian's dired-get-filename.
2697    
2698  (defmacro ange-ftp-ls-parser ()  (defun ange-ftp-ls-parser (switches)
   ;; Note that switches is dynamically bound.  
2699    ;; Meant to be called by ange-ftp-parse-dired-listing    ;; Meant to be called by ange-ftp-parse-dired-listing
2700    `(let ((tbl (ange-ftp-make-hashtable))    (let ((tbl (make-hash-table :test 'equal))
2701           (used-F (and (stringp switches)          (used-F (and (stringp switches)
2702                        (string-match "F" switches)))                       (string-match "F" switches)))
2703           file-type symlink directory file)          file-type symlink directory file)
2704       (while (setq file (ange-ftp-parse-filename))      (while (setq file (ange-ftp-parse-filename))
2705         (beginning-of-line)        (beginning-of-line)
2706         (skip-chars-forward "\t 0-9")        (skip-chars-forward "\t 0-9")
2707         (setq file-type (following-char)        (setq file-type (following-char)
2708               directory (eq file-type ?d))              directory (eq file-type ?d))
2709         (if (eq file-type ?l)        (if (eq file-type ?l)
2710             (if (string-match " -> " file)            (let ((end (string-match " -> " file)))
2711                 (setq symlink (substring file (match-end 0))              (if end
2712                       file (substring file 0 (match-beginning 0)))                  ;; Sometimes `ls' appends a @ at the end of the target.
2713               ;; Shouldn't happen                  (setq symlink (substring file (match-end 0)
2714               (setq symlink ""))                                           (string-match "@\\'" file))
2715           (setq symlink nil))                        file (substring file 0 end))
2716         ;; Only do a costly regexp search if the F switch was used.                ;; Shouldn't happen
2717         (if (and used-F                (setq symlink "")))
2718                  (not (string-equal file ""))          (setq symlink nil))
2719                  (looking-at        ;; Only do a costly regexp search if the F switch was used.
2720                   ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))        (if (and used-F
2721             (let ((socket (eq file-type ?s))                 (not (string-equal file ""))
2722                   (executable                 (looking-at
2723                    (and (not symlink) ; x bits don't mean a thing for symlinks                  ".[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)[-r][-w]\\([^ ]\\)"))
2724                         (string-match            (let ((socket (eq file-type ?s))
2725                          "[xst]"                  (executable
2726                          (concat (buffer-substring                   (and (not symlink) ; x bits don't mean a thing for symlinks
2727                                   (match-beginning 1) (match-end 1))                        (string-match
2728                                  (buffer-substring                         "[xst]"
2729                                   (match-beginning 2) (match-end 2))                         (concat (match-string 1)
2730                                  (buffer-substring                                 (match-string 2)
2731                                   (match-beginning 3) (match-end 3)))))))                                 (match-string 3))))))
2732               ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)              ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
2733               ;; and others don't. (sigh...) Beware, that some Unix's don't              ;; and others don't. (sigh...) Beware, that some Unix's don't
2734               ;; seem to believe in the F-switch              ;; seem to believe in the F-switch
2735               (if (or (and symlink (string-match "@$" file))              (if (or (and symlink (string-match "@$" file))
2736                       (and directory (string-match "/$" file))                      (and directory (string-match "/$" file))
2737                       (and executable (string-match "*$" file))                      (and executable (string-match "*$" file))
2738                       (and socket (string-match "=$" file)))                      (and socket (string-match "=$" file)))
2739                   (setq file (substring file 0 -1)))))                  (setq file (substring file 0 -1)))))
2740         (ange-ftp-put-hash-entry file (or symlink directory) tbl)        (puthash file (or symlink directory) tbl)
2741         (forward-line 1))        (forward-line 1))
2742      (ange-ftp-put-hash-entry "." t tbl)      (puthash "." t tbl)
2743      (ange-ftp-put-hash-entry ".." t tbl)      (puthash ".." t tbl)
2744      tbl))      tbl))
2745    
2746  ;;; The dl stuff for descriptive listings  ;;; The dl stuff for descriptive listings
# Line 2833  match subdirectories as well.") Line 2767  match subdirectories as well.")
2767  (defmacro ange-ftp-dl-parser ()  (defmacro ange-ftp-dl-parser ()
2768    ;; Parse the current buffer, which is assumed to be a descriptive    ;; Parse the current buffer, which is assumed to be a descriptive
2769    ;; listing, and return a hashtable.    ;; listing, and return a hashtable.
2770    `(let ((tbl (ange-ftp-make-hashtable)))    `(let ((tbl (make-hash-table :test 'equal)))
2771       (while (not (eobp))       (while (not (eobp))
2772         (ange-ftp-put-hash-entry         (puthash
2773          (buffer-substring (point)          (buffer-substring (point)
2774                            (progn                            (progn
2775                              (skip-chars-forward "^ /\n")                              (skip-chars-forward "^ /\n")
# Line 2843  match subdirectories as well.") Line 2777  match subdirectories as well.")
2777          (eq (following-char) ?/)          (eq (following-char) ?/)
2778          tbl)          tbl)
2779         (forward-line 1))         (forward-line 1))
2780      (ange-ftp-put-hash-entry "." t tbl)       (puthash "." t tbl)
2781      (ange-ftp-put-hash-entry ".." t tbl)       (puthash ".." t tbl)
2782      tbl))       tbl))
2783    
2784  ;; Parse the current buffer which is assumed to be in a dired-like listing  ;; Parse the current buffer which is assumed to be in a dired-like listing
2785  ;; format, and return a hashtable as the result. If the listing is not really  ;; format, and return a hashtable as the result. If the listing is not really
# Line 2858  match subdirectories as well.") Line 2792  match subdirectories as well.")
2792        (forward-line 1)        (forward-line 1)
2793        ;; Some systems put in a blank line here.        ;; Some systems put in a blank line here.
2794        (if (eolp) (forward-line 1))        (if (eolp) (forward-line 1))
2795        (ange-ftp-ls-parser))        (ange-ftp-ls-parser switches))
2796       ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")       ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
2797        ;; It's an ls error message.        ;; It's an ls error message.
2798        nil)        nil)
# Line 2872  match subdirectories as well.") Line 2806  match subdirectories as well.")
2806        nil)        nil)
2807       ((re-search-forward ange-ftp-date-regexp nil t)       ((re-search-forward ange-ftp-date-regexp nil t)
2808        (beginning-of-line)        (beginning-of-line)
2809        (ange-ftp-ls-parser))        (ange-ftp-ls-parser switches))
2810       ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)       ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
2811        ;; It's a dl listing (I hope).        ;; It's a dl listing (I hope).
2812        ;; file is bound by the call to ange-ftp-ls        ;; file is bound by the call to ange-ftp-ls
# Line 2883  match subdirectories as well.") Line 2817  match subdirectories as well.")
2817    
2818  (defun ange-ftp-set-files (directory files)  (defun ange-ftp-set-files (directory files)
2819    "For a given DIRECTORY, set or change the associated FILES hashtable."    "For a given DIRECTORY, set or change the associated FILES hashtable."
2820    (and files (ange-ftp-put-hash-entry (file-name-as-directory directory)    (and files (puthash (file-name-as-directory directory)
2821                                        files ange-ftp-files-hashtable)))                        files ange-ftp-files-hashtable)))
2822    
2823  (defun ange-ftp-get-files (directory &optional no-error)  (defun ange-ftp-get-files (directory &optional no-error)
2824    "Given a given DIRECTORY, return a hashtable of file entries.    "Given a given DIRECTORY, return a hashtable of file entries.
2825  This will give an error or return nil, depending on the value of  This will give an error or return nil, depending on the value of
2826  NO-ERROR, if a listing for DIRECTORY cannot be obtained."  NO-ERROR, if a listing for DIRECTORY cannot be obtained."
2827    (setq directory (file-name-as-directory directory)) ;normalize    (setq directory (file-name-as-directory directory)) ;normalize
2828    (or (ange-ftp-get-hash-entry directory ange-ftp-files-hashtable)    (or (gethash directory ange-ftp-files-hashtable)
2829        (save-match-data        (save-match-data
2830          (and (ange-ftp-ls directory          (and (ange-ftp-ls directory
2831                            ;; This is an efficiency hack. We try to                            ;; This is an efficiency hack. We try to
# Line 2922  NO-ERROR, if a listing for DIRECTORY can Line 2856  NO-ERROR, if a listing for DIRECTORY can
2856                                  dired-listing-switches                                  dired-listing-switches
2857                                "-al"))                                "-al"))
2858                            t no-error)                            t no-error)
2859               (ange-ftp-get-hash-entry               (gethash directory ange-ftp-files-hashtable)))))
               directory ange-ftp-files-hashtable)))))  
2860    
2861  ;; Given NAME, return the file part that can be used for looking up the  ;; Given NAME, return the file part that can be used for looking up the
2862  ;; file's entry in a hashtable.  ;; file's entry in a hashtable.
2863  (defmacro ange-ftp-get-file-part (name)  (defmacro ange-ftp-get-file-part (name)
2864    `(let ((file (file-name-nondirectory ,name)))    `(let ((file (file-name-nondirectory ,name)))
2865       (if (string-equal file "")       (if (string-equal file "")
2866          "."           "."
2867         file)))         file)))
2868    
2869  ;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are  ;; Return whether ange-ftp-file-entry-p and ange-ftp-get-file-entry are
# Line 2941  NO-ERROR, if a listing for DIRECTORY can Line 2874  NO-ERROR, if a listing for DIRECTORY can
2874  ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid  ;; 2. The syntax of FILE and DIR make it impossible that FILE could be a valid
2875  ;;     subdirectory. This is of course an OS dependent judgement.  ;;     subdirectory. This is of course an OS dependent judgement.
2876    
2877    (defvar dired-local-variables-file)
2878  (defmacro ange-ftp-allow-child-lookup (dir file)  (defmacro ange-ftp-allow-child-lookup (dir file)
2879    `(not    `(not
2880      (let* ((efile ,file)                ; expand once.      (let* ((efile ,file)                ; expand once.
# Line 2967  NO-ERROR, if a listing for DIRECTORY can Line 2901  NO-ERROR, if a listing for DIRECTORY can
2901    "Given NAME, return whether there is a file entry for it."    "Given NAME, return whether there is a file entry for it."
2902    (let* ((name (directory-file-name name))    (let* ((name (directory-file-name name))
2903           (dir (file-name-directory name))           (dir (file-name-directory name))
2904           (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))           (ent (gethash dir ange-ftp-files-hashtable))
2905           (file (ange-ftp-get-file-part name)))           (file (ange-ftp-get-file-part name)))
2906      (if ent      (if ent
2907          (ange-ftp-hash-entry-exists-p file ent)          (ange-ftp-hash-entry-exists-p file ent)
# Line 2981  NO-ERROR, if a listing for DIRECTORY can Line 2915  NO-ERROR, if a listing for DIRECTORY can
2915                 ;; then dumb hosts will give an ftp error. Smart unix hosts                 ;; then dumb hosts will give an ftp error. Smart unix hosts
2916                 ;; will simply send back the ls                 ;; will simply send back the ls
2917                 ;; error message.                 ;; error message.
2918                 (ange-ftp-get-hash-entry "." ent))                 (gethash "." ent))
2919            ;; Child lookup failed, so try the parent.            ;; Child lookup failed, so try the parent.
2920            (let ((table (ange-ftp-get-files dir)))            (let ((table (ange-ftp-get-files dir 'no-error)))
2921              ;; If the dir doesn't exist, don't use it as a hash table.              ;; If the dir doesn't exist, don't use it as a hash table.
2922              (and table              (and table
2923                   (ange-ftp-hash-entry-exists-p file                   (ange-ftp-hash-entry-exists-p file
# Line 2996  or a string for a symlink. If the file i Line 2930  or a string for a symlink. If the file i
2930  this also returns nil."  this also returns nil."
2931    (let* ((name (directory-file-name name))    (let* ((name (directory-file-name name))
2932           (dir (file-name-directory name))           (dir (file-name-directory name))
2933           (ent (ange-ftp-get-hash-entry dir ange-ftp-files-hashtable))           (ent (gethash dir ange-ftp-files-hashtable))
2934           (file (ange-ftp-get-file-part name)))           (file (ange-ftp-get-file-part name)))
2935      (if ent      (if ent
2936          (ange-ftp-get-hash-entry file ent)          (gethash file ent)
2937        (or (and (ange-ftp-allow-child-lookup dir file)        (or (and (ange-ftp-allow-child-lookup dir file)
2938                 (setq ent (ange-ftp-get-files name t))                 (setq ent (ange-ftp-get-files name t))
2939                 (ange-ftp-get-hash-entry "." ent))                 (gethash "." ent))
2940                 ;; i.e. it's a directory by child lookup            ;; i.e. it's a directory by child lookup
2941            (ange-ftp-get-hash-entry file            (and (setq ent (ange-ftp-get-files dir t))
2942                                     (ange-ftp-get-files dir))))))                 (gethash file ent))))))
2943    
2944  (defun ange-ftp-internal-delete-file-entry (name &optional dir-p)  (defun ange-ftp-internal-delete-file-entry (name &optional dir-p)
2945    (if dir-p    (when dir-p
2946        (progn      (setq name (file-name-as-directory name))
2947          (setq name (file-name-as-directory name))      (remhash name ange-ftp-files-hashtable)
2948          (ange-ftp-del-hash-entry name ange-ftp-files-hashtable)      (setq name (directory-file-name name)))
         (setq name (directory-file-name name))))  
2949    ;; Note that file-name-as-directory followed by directory-file-name    ;; Note that file-name-as-directory followed by directory-file-name
2950    ;; serves to canonicalize directory file names to their unix form.    ;; serves to canonicalize directory file names to their unix form.
2951    ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO    ;; i.e. in VMS, FOO.DIR -> FOO/ -> FOO
2952    (let ((files (ange-ftp-get-hash-entry (file-name-directory name)    (let ((files (gethash (file-name-directory name) ange-ftp-files-hashtable)))
                                         ange-ftp-files-hashtable)))  
2953      (if files      (if files
2954          (ange-ftp-del-hash-entry (ange-ftp-get-file-part name)          (remhash (ange-ftp-get-file-part name) files))))
                                  files))))  
2955    
2956  (defun ange-ftp-internal-add-file-entry (name &optional dir-p)  (defun ange-ftp-internal-add-file-entry (name &optional dir-p)
2957    (and dir-p    (and dir-p
2958         (setq name (directory-file-name name)))         (setq name (directory-file-name name)))
2959    (let ((files (ange-ftp-get-hash-entry (file-name-directory name)    (let ((files (gethash (file-name-directory name) ange-ftp-files-hashtable)))
                                         ange-ftp-files-hashtable)))  
2960      (if files      (if files
2961          (ange-ftp-put-hash-entry (ange-ftp-get-file-part name)          (puthash (ange-ftp-get-file-part name) dir-p files))))
                                  dir-p  
                                  files))))  
2962    
2963  (defun ange-ftp-wipe-file-entries (host user)  (defun ange-ftp-wipe-file-entries (host user)
2964    "Get rid of entry for HOST, USER pair from file entry information hashtable."    "Get rid of entry for HOST, USER pair from file entry information hashtable."
2965    (let ((new-tbl (ange-ftp-make-hashtable (length ange-ftp-files-hashtable))))    (let ((new-tbl (make-hash-table :test 'equal
2966      (ange-ftp-map-hashtable                                    :size (hash-table-size
2967                                             ange-ftp-files-hashtable))))
2968        (maphash
2969       (lambda (key val)       (lambda (key val)
2970         (let ((parsed (ange-ftp-ftp-name key)))         (let ((parsed (ange-ftp-ftp-name key)))
2971           (if parsed           (if parsed
2972               (let ((h (nth 0 parsed))               (let ((h (nth 0 parsed))
2973                     (u (nth 1 parsed)))                     (u (nth 1 parsed)))
2974                 (or (and (equal host h) (equal user u))                 (or (and (equal host h) (equal user u))
2975                     (ange-ftp-put-hash-entry key val new-tbl))))))                     (puthash key val new-tbl))))))
2976       ange-ftp-files-hashtable)       ange-ftp-files-hashtable)
2977      (setq ange-ftp-files-hashtable new-tbl)))      (setq ange-ftp-files-hashtable new-tbl)))
2978    
# Line 3088  and LINE is the relevant success or fail Line 3018  and LINE is the relevant success or fail
3018      (if (car result)      (if (car result)
3019          (save-match-data          (save-match-data
3020            (and (or (string-match "\"\\([^\"]*\\)\"" line)            (and (or (string-match "\"\\([^\"]*\\)\"" line)
3021                     (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!                     (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
3022                 (setq dir (substring line                 (setq dir (match-string 1 line)))))
                                     (match-beginning 1)  
                                     (match-end 1))))))  
3023      (cons dir line)))      (cons dir line)))
3024    
3025  ;;; ------------------------------------------------------------  ;;; ------------------------------------------------------------
# Line 3109  logged in as user USER and cd'd to direc Line 3037  logged in as user USER and cd'd to direc
3037           (fix-name-func           (fix-name-func
3038            (cdr (assq host-type ange-ftp-fix-name-func-alist)))            (cdr (assq host-type ange-ftp-fix-name-func-alist)))
3039           (key (concat host "/" user "/" dir))           (key (concat host "/" user "/" dir))
3040           (res (ange-ftp-get-hash-entry key ange-ftp-expand-dir-hashtable)))           (res (gethash key ange-ftp-expand-dir-hashtable)))
3041      (or res      (or res
3042          (progn          (progn
3043            (or            (or
# Line 3125  logged in as user USER and cd'd to direc Line 3053  logged in as user USER and cd'd to direc
3053                    (line (cdr result)))                    (line (cdr result)))
3054               (setq res               (setq res
3055                     (if (string-match ange-ftp-expand-dir-regexp line)                     (if (string-match ange-ftp-expand-dir-regexp line)
3056                         (substring line                         (match-string 1 line)))))
                                   (match-beginning 1)  
                                   (match-end 1))))))  
3057            (or res            (or res
3058                (if (string-equal dir "~")                (if (string-equal dir "~")
3059                    (setq res (car (ange-ftp-get-pwd host user)))                    (setq res (car (ange-ftp-get-pwd host user)))
# Line 3141  logged in as user USER and cd'd to direc Line 3067  logged in as user USER and cd'd to direc
3067                      (ange-ftp-this-host host))                      (ange-ftp-this-host host))
3068                  (if fix-name-func                  (if fix-name-func
3069                      (setq res (funcall fix-name-func res 'reverse)))                      (setq res (funcall fix-name-func res 'reverse)))
3070                  (ange-ftp-put-hash-entry                  (puthash key res ange-ftp-expand-dir-hashtable)))
                  key res ange-ftp-expand-dir-hashtable)))  
3071            res))))            res))))
3072    
3073  (defun ange-ftp-canonize-filename (n)  (defun ange-ftp-canonize-filename (n)
# Line 3163  logged in as user USER and cd'd to direc Line 3088  logged in as user USER and cd'd to direc
3088                  ;; Name starts with ~ or ~user.  Resolve that part of the name                  ;; Name starts with ~ or ~user.  Resolve that part of the name
3089                  ;; making it absolute then re-expand it.                  ;; making it absolute then re-expand it.
3090                  ((string-match "^~[^/]*" name)                  ((string-match "^~[^/]*" name)
3091                   (let* ((tilda (substring name                   (let* ((tilda (match-string 0 name))
                                           (match-beginning 0)  
                                           (match-end 0)))  
3092                          (rest (substring name (match-end 0)))                          (rest (substring name (match-end 0)))
3093                          (dir (ange-ftp-expand-dir host user tilda)))                          (dir (ange-ftp-expand-dir host user tilda)))
3094                     (if dir                     (if dir
# Line 3277  system TYPE.") Line 3200  system TYPE.")
3200    (let ((parsed (ange-ftp-ftp-name dir)))    (let ((parsed (ange-ftp-ftp-name dir)))
3201      (if parsed      (if parsed
3202          (ange-ftp-replace-name-component          (ange-ftp-replace-name-component
3203             dir           dir
3204             (ange-ftp-real-directory-file-name (nth 2 parsed)))           (ange-ftp-real-directory-file-name (nth 2 parsed)))
3205        (ange-ftp-real-directory-file-name dir))))        (ange-ftp-real-directory-file-name dir))))
3206    
3207    
# Line 3314  system TYPE.") Line 3237  system TYPE.")
3237                 (coding-system-used last-coding-system-used))                 (coding-system-used last-coding-system-used))
3238            (unwind-protect            (unwind-protect
3239                (progn                (progn
3240                  (let ((executing-kbd-macro t)                  (let ((filename (buffer-file-name))
                       (filename (buffer-file-name))  
3241                        (mod-p (buffer-modified-p)))                        (mod-p (buffer-modified-p)))
3242                    (unwind-protect                    (unwind-protect
3243                        (progn                        (progn
3244                          (ange-ftp-real-write-region start end temp nil visit)                          (ange-ftp-real-write-region start end temp nil
3245                                                        (or visit 'quiet))
3246                          (setq coding-system-used last-coding-system-used))                          (setq coding-system-used last-coding-system-used))
3247                      ;; cleanup forms                      ;; cleanup forms
3248                      (setq coding-system-used last-coding-system-used)                      (setq coding-system-used last-coding-system-used)
# Line 3369  system TYPE.") Line 3292  system TYPE.")
3292            (if (or (file-exists-p filename)            (if (or (file-exists-p filename)
3293                    (progn                    (progn
3294                      (setq ange-ftp-ls-cache-file nil)                      (setq ange-ftp-ls-cache-file nil)
3295                      (ange-ftp-del-hash-entry (file-name-directory filename)                      (remhash (file-name-directory filename)
3296                                               ange-ftp-files-hashtable)                               ange-ftp-files-hashtable)
3297                      (file-exists-p filename)))                      (file-exists-p filename)))
3298                (let* ((host (nth 0 parsed))                (let* ((host (nth 0 parsed))
3299                       (user (nth 1 parsed))                       (user (nth 1 parsed))
# Line 3444  system TYPE.") Line 3367  system TYPE.")
3367    (setq file (ange-ftp-expand-file-name file))    (setq file (ange-ftp-expand-file-name file))
3368    (if (ange-ftp-ftp-name file)    (if (ange-ftp-ftp-name file)
3369        (let ((file-ent        (let ((file-ent
3370               (ange-ftp-get-hash-entry               (gethash
3371                (ange-ftp-get-file-part file)                (ange-ftp-get-file-part file)
3372                (ange-ftp-get-files (file-name-directory file)))))                (ange-ftp-get-files (file-name-directory file)))))
3373          (if (stringp file-ent)          (if (stringp file-ent)
3374              (if (file-name-absolute-p file-ent)              (if (file-name-absolute-p file-ent)
3375                  (ange-ftp-replace-name-component                  (ange-ftp-replace-name-component
3376                        (file-name-directory file) file-ent)                   (file-name-directory file) file-ent)
3377                file-ent)))                file-ent)))
3378      (ange-ftp-real-file-symlink-p file)))      (ange-ftp-real-file-symlink-p file)))
3379    
# Line 3513  system TYPE.") Line 3436  system TYPE.")
3436                (let ((host (nth 0 parsed))                (let ((host (nth 0 parsed))
3437                      (user (nth 1 parsed))                      (user (nth 1 parsed))
3438                      (name (nth 2 parsed))                      (name (nth 2 parsed))
3439                      (dirp (ange-ftp-get-hash-entry part files))                      (dirp (gethash part files))
3440                      (inode (ange-ftp-get-hash-entry                      (inode (gethash file ange-ftp-inodes-hashtable)))
                             file ange-ftp-inodes-hashtable)))  
3441                  (unless inode                  (unless inode
3442                    (setq inode ange-ftp-next-inode-number                    (setq inode ange-ftp-next-inode-number
3443                          ange-ftp-next-inode-number (1+ inode))                          ange-ftp-next-inode-number (1+ inode))
3444                    (ange-ftp-put-hash-entry file inode ange-ftp-inodes-hashtable))                    (puthash file inode ange-ftp-inodes-hashtable))
3445                  (list (if (and (stringp dirp) (file-name-absolute-p dirp))                  (list (if (and (stringp dirp) (file-name-absolute-p dirp))
3446                            (ange-ftp-expand-symlink dirp                            (ange-ftp-expand-symlink dirp
3447                                                     (file-name-directory file))                                                     (file-name-directory file))
# Line 3661  Value is (0 0) if the modification time Line 3583  Value is (0 0) if the modification time
3583  ;;                           filename  ;;                           filename
3584  ;;                           newname))  ;;                           newname))
3585  ;;      res)  ;;      res)
3586  ;;     (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel))  ;;     (set-process-sentinel proc 'ange-ftp-copy-file-locally-sentinel)
3587  ;;     (process-kill-without-query proc)  ;;     (process-kill-without-query proc)
3588  ;;     (with-current-buffer (process-buffer proc)  ;;     (with-current-buffer (process-buffer proc)
3589  ;;       (set (make-local-variable 'copy-cont) cont))))  ;;       (set (make-local-variable 'copy-cont) cont))))
# Line 3749  Value is (0 0) if the modification time Line 3671  Value is (0 0) if the modification time
3671                     (if (and temp1 t-parsed)                     (if (and temp1 t-parsed)
3672                         (format "Getting %s" f-abbr)                         (format "Getting %s" f-abbr)
3673                       (format "Copying %s to %s" f-abbr t-abbr)))                       (format "Copying %s to %s" f-abbr t-abbr)))
3674                 (list (function ange-ftp-cf1)                 (list 'ange-ftp-cf1
3675                       filename newname binary msg                       filename newname binary msg
3676                       f-parsed f-host f-user f-name f-abbr                       f-parsed f-host f-user f-name f-abbr
3677                       t-parsed t-host t-user t-name t-abbr                       t-parsed t-host t-user t-name t-abbr
# Line 3827  Value is (0 0) if the modification time Line 3749  Value is (0 0) if the modification time
3749                   (if (and temp2 f-parsed)                   (if (and temp2 f-parsed)
3750                       (format "Putting %s" newname)                       (format "Putting %s" newname)
3751                     (format "Copying %s to %s" f-abbr t-abbr)))                     (format "Copying %s to %s" f-abbr t-abbr)))
3752               (list (function ange-ftp-cf2)               (list 'ange-ftp-cf2
3753                     newname t-host t-user binary temp1 temp2 cont)                     newname t-host t-user binary temp1 temp2 cont)
3754               nowait))               nowait))
3755    
# Line 3902  E.g., Line 3824  E.g.,
3824           (and verbose-p (format "%s --> %s" from-file to-file))           (and verbose-p (format "%s --> %s" from-file to-file))
3825           (list 'ange-ftp-copy-files-async verbose-p (cdr files))           (list 'ange-ftp-copy-files-async verbose-p (cdr files))
3826           t))           t))
3827        (message "%s: done" 'ange-ftp-copy-files-async)))      (message "%s: done" 'ange-ftp-copy-files-async)))
3828    
3829    
3830  ;;;; ------------------------------------------------------------  ;;;; ------------------------------------------------------------
# Line 3982  E.g., Line 3904  E.g.,
3904  ;;;; File name completion support.  ;;;; File name completion support.
3905  ;;;; ------------------------------------------------------------  ;;;; ------------------------------------------------------------
3906    
 ;; If the file entry SYM is a symlink, returns whether its file exists.  
 ;; Note that `ange-ftp-this-dir' is used as a free variable.  
 (defun ange-ftp-file-entry-active-p (sym)  
   (let ((val (get sym 'val)))  
     (or (not (stringp val))  
         (file-exists-p (ange-ftp-expand-symlink val ange-ftp-this-dir)))))  
   
3907  ;; If the file entry is not a directory (nor a symlink pointing to a directory)  ;; If the file entry is not a directory (nor a symlink pointing to a directory)
3908  ;; returns whether the file (or file pointed to by the symlink) is ignored  ;; returns whether the file (or file pointed to by the symlink) is ignored
3909  ;; by completion-ignored-extensions.  ;; by completion-ignored-extensions.
3910  ;; Note that `ange-ftp-this-dir' and `ange-ftp-completion-ignored-pattern'  ;; Note that `ange-ftp-this-dir' and `ange-ftp-completion-ignored-pattern'
3911  ;; are used as free variables.  ;; are used as free variables.
3912  (defun ange-ftp-file-entry-not-ignored-p (sym)  (defun ange-ftp-file-entry-not-ignored-p (symname val)
3913    (let ((val (get sym 'val))    (if (stringp val)
3914          (symname (symbol-name sym)))        (let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir)))
3915      (if (stringp val)          (or (file-directory-p file)
3916          (let ((file (ange-ftp-expand-symlink val ange-ftp-this-dir)))              (and (file-exists-p file)
3917            (or (file-directory-p file)                   (not (string-match ange-ftp-completion-ignored-pattern
3918                (and (file-exists-p file)                                      symname)))))
3919                     (not (string-match ange-ftp-completion-ignored-pattern      (or val                             ; is a directory name
3920                                        symname)))))          (not (string-match ange-ftp-completion-ignored-pattern symname)))))
       (or val ; is a directory name  
           (not (string-match ange-ftp-completion-ignored-pattern symname))))))  
3921    
3922  (defun ange-ftp-root-dir-p (dir)  (defun ange-ftp-root-dir-p (dir)
3923    ;; Maybe we should use something more like    ;; Maybe we should use something more like
# Line 4021  E.g., Line 3934  E.g.,
3934            (setq ange-ftp-this-dir            (setq ange-ftp-this-dir
3935                  (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))                  (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))
3936            (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))            (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3937                   (completions                   (completions (all-completions file tbl)))
                   (all-completions file tbl  
                                    (function ange-ftp-file-entry-active-p))))  
3938    
3939              ;; see whether each matching file is a directory or not...              ;; see whether each matching file is a directory or not...
3940              (mapcar              (mapcar
3941               (lambda (file)               (lambda (file)
3942                 (let ((ent (ange-ftp-get-hash-entry file tbl)))                 (let ((ent (gethash file tbl)))
3943                   (if (and ent                   (if (and ent
3944                            (or (not (stringp ent))                            (or (not (stringp ent))
3945                                (file-directory-p                                (file-directory-p
3946                                 (ange-ftp-expand-symlink ent                                 (ange-ftp-expand-symlink ent
3947                                                          ange-ftp-this-dir))))                                                          ange-ftp-this-dir))))
3948                       (concat file "/")                       (concat file "/")
3949                      file)))                     file)))
3950               completions)))               completions)))
3951    
3952        (if (ange-ftp-root-dir-p ange-ftp-this-dir)        (if (ange-ftp-root-dir-p ange-ftp-this-dir)
# Line 4063  E.g., Line 3974  E.g.,
3974                (save-match-data                (save-match-data
3975                  (or (ange-ftp-file-name-completion-1                  (or (ange-ftp-file-name-completion-1
3976                       file tbl ange-ftp-this-dir                       file tbl ange-ftp-this-dir
3977                       (function ange-ftp-file-entry-not-ignored-p))                       'ange-ftp-file-entry-not-ignored-p)
3978                      (ange-ftp-file-name-completion-1                      (ange-ftp-file-name-completion-1
3979                       file tbl ange-ftp-this-dir                       file tbl ange-ftp-this-dir))))))
                      (function ange-ftp-file-entry-active-p)))))))  
3980    
3981        (if (ange-ftp-root-dir-p ange-ftp-this-dir)        (if (ange-ftp-root-dir-p ange-ftp-this-dir)
3982            (try-completion            (try-completion
# Line 4077  E.g., Line 3987  E.g.,
3987          (ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))          (ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))
3988    
3989    
3990  (defun ange-ftp-file-name-completion-1 (file tbl dir predicate)  (defun ange-ftp-file-name-completion-1 (file tbl dir &optional predicate)
3991    (let ((bestmatch (try-completion file tbl predicate)))    (let ((bestmatch (try-completion file tbl predicate)))
3992      (if bestmatch      (if bestmatch
3993          (if (eq bestmatch t)          (if (eq bestmatch t)
# Line 4113  directory, so that Emacs will know its c Line 4023  directory, so that Emacs will know its c
4023    (if (ange-ftp-ftp-name dir)    (if (ange-ftp-ftp-name dir)
4024        (progn        (progn
4025          (setq ange-ftp-ls-cache-file nil)          (setq ange-ftp-ls-cache-file nil)
4026          (ange-ftp-del-hash-entry dir ange-ftp-files-hashtable)          (remhash dir ange-ftp-files-hashtable)
4027          (ange-ftp-get-files dir t))))          (ange-ftp-get-files dir t))))
4028    
4029  (defun ange-ftp-make-directory (dir &optional parents)  (defun ange-ftp-make-directory (dir &optional parents)
# Line 4170  directory, so that Emacs will know its c Line 4080  directory, so that Emacs will know its c
4080                                 (nth 2 parsed))                                 (nth 2 parsed))
4081                              (ange-ftp-real-file-name-as-directory                              (ange-ftp-real-file-name-as-directory
4082                               (nth 2 parsed)))))                               (nth 2 parsed)))))
4083                    (abbr (ange-ftp-abbreviate-filename dir))                     (abbr (ange-ftp-abbreviate-filename dir))
4084                    (result (ange-ftp-send-cmd host user                     (result (ange-ftp-send-cmd host user
4085                                               (list 'rmdir name)                                                (list 'rmdir name)
4086                                               (format "Removing directory %s"                                                (format "Removing directory %s"
4087                                                       abbr))))                                                        abbr))))
4088                (or (car result)                (or (car result)
4089                    (ange-ftp-error host user                    (ange-ftp-error host user
4090                                    (format "Could not remove directory %s: %s"                                    (format "Could not remove directory %s: %s"
# Line 4336  NEWNAME should be the name to give the n Line 4246  NEWNAME should be the name to give the n
4246    (let ((fn (get operation 'ange-ftp)))    (let ((fn (get operation 'ange-ftp)))
4247      (if fn (save-match-data (apply fn args))      (if fn (save-match-data (apply fn args))
4248        (ange-ftp-run-real-handler operation args))))        (ange-ftp-run-real-handler operation args))))
   
   
 ;;; This regexp takes care of real ange-ftp file names (with a slash  
 ;;; and colon).  
 ;;; Don't allow the host name to end in a period--some systems use /.:  
4249  ;;;###autoload  ;;;###autoload
4250  (or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)  ;;; These file names are remote file names.
4251      (setq file-name-handler-alist  (put 'ange-ftp-hook-function 'file-remote-p t)
           (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)  
                 file-name-handler-alist)))  
4252    
4253  ;;; This regexp recognizes absolute filenames with only one component,  ;; The following code is commented out because Tramp now deals with
4254  ;;; for the sake of hostname completion.  ;; Ange-FTP filenames, too.
4255  ;;;###autoload  
4256  (or (assoc "^/[^/:]*\\'" file-name-handler-alist)  ;;-;;; This regexp takes care of real ange-ftp file names (with a slash
4257      (setq file-name-handler-alist  ;;-;;; and colon).
4258            (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)  ;;-;;; Don't allow the host name to end in a period--some systems use /.:
4259                  file-name-handler-alist)))  ;;-;;;###autoload
4260    ;;-(or (assoc "^/[^/:]*[^/:.]:" file-name-handler-alist)
4261  ;;; This regexp recognizes absolute filenames with only one component  ;;-    (setq file-name-handler-alist
4262  ;;; on Windows, for the sake of hostname completion.  ;;-       (cons '("^/[^/:]*[^/:.]:" . ange-ftp-hook-function)
4263  ;;; NB. Do not mark this as autoload, because it is very common to  ;;-             file-name-handler-alist)))
4264  ;;; do completions in the root directory of drives on Windows.  ;;-
4265  (and (memq system-type '(ms-dos windows-nt))  ;;-;;; This regexp recognizes absolute filenames with only one component,
4266       (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)  ;;-;;; for the sake of hostname completion.
4267           (setq file-name-handler-alist  ;;-;;;###autoload
4268                 (cons '("^[a-zA-Z]:/[^/:]*\\'" .  ;;-(or (assoc "^/[^/:]*\\'" file-name-handler-alist)
4269                         ange-ftp-completion-hook-function)  ;;-    (setq file-name-handler-alist
4270                       file-name-handler-alist))))  ;;-       (cons '("^/[^/:]*\\'" . ange-ftp-completion-hook-function)
4271    ;;-             file-name-handler-alist)))
4272    ;;-
4273    ;;-;;; This regexp recognizes absolute filenames with only one component
4274    ;;-;;; on Windows, for the sake of hostname completion.
4275    ;;-;;; NB. Do not mark this as autoload, because it is very common to
4276    ;;-;;; do completions in the root directory of drives on Windows.
4277    ;;-(and (memq system-type '(ms-dos windows-nt))
4278    ;;-     (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist)
4279    ;;-      (setq file-name-handler-alist
4280    ;;-            (cons '("^[a-zA-Z]:/[^/:]*\\'" .
4281    ;;-                    ange-ftp-completion-hook-function)
4282    ;;-                  file-name-handler-alist))))
4283    
4284  ;;; The above two forms are sufficient to cause this file to be loaded  ;;; The above two forms are sufficient to cause this file to be loaded
4285  ;;; if the user ever uses a file name with a colon in it.  ;;; if the user ever uses a file name with a colon in it.
4286    
4287  ;;; This sets the mode  ;;; This sets the mode
4288  (or (memq 'ange-ftp-set-buffer-mode find-file-hooks)  (add-hook 'find-file-hook 'ange-ftp-set-buffer-mode)
     (setq find-file-hooks  
           (cons 'ange-ftp-set-buffer-mode find-file-hooks)))  
4289    
4290  ;;; Now say where to find the handlers for particular operations.  ;;; Now say where to find the handlers for particular operations.
4291    
# Line 4395  NEWNAME should be the name to give the n Line 4308  NEWNAME should be the name to give the n
4308       'ange-ftp-verify-visited-file-modtime)       'ange-ftp-verify-visited-file-modtime)
4309  (put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)  (put 'file-exists-p 'ange-ftp 'ange-ftp-file-exists-p)
4310  (put 'write-region 'ange-ftp 'ange-ftp-write-region)  (put 'write-region 'ange-ftp 'ange-ftp-write-region)
 (put 'backup-buffer 'ange-ftp 'ange-ftp-backup-buffer)  
4311  (put 'copy-file 'ange-ftp 'ange-ftp-copy-file)  (put 'copy-file 'ange-ftp 'ange-ftp-copy-file)
4312  (put 'rename-file 'ange-ftp 'ange-ftp-rename-file)  (put 'rename-file 'ange-ftp 'ange-ftp-rename-file)
4313  (put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)  (put 'file-attributes 'ange-ftp 'ange-ftp-file-attributes)
# Line 4508  NEWNAME should be the name to give the n Line 4420  NEWNAME should be the name to give the n
4420  ;; I have preserved (and modernized) those hooks.  ;; I have preserved (and modernized) those hooks.
4421  ;; So the format conversion should be all that is needed.  ;; So the format conversion should be all that is needed.
4422    
4423    ;; When called from dired, SWITCHES may start with "--dired".
4424    ;; `ange-ftp-ls' handles this.
4425    
4426  (defun ange-ftp-insert-directory (file switches &optional wildcard full)  (defun ange-ftp-insert-directory (file switches &optional wildcard full)
4427    (let ((short (ange-ftp-abbreviate-filename file))    (let ((short (ange-ftp-abbreviate-filename file))
4428          (parsed (ange-ftp-ftp-name (expand-file-name file)))          (parsed (ange-ftp-ftp-name (expand-file-name file)))
# Line 4516  NEWNAME should be the name to give the n Line 4431  NEWNAME should be the name to give the n
4431          (if (and (not wildcard)          (if (and (not wildcard)
4432                   (setq tem (file-symlink-p (directory-file-name file))))                   (setq tem (file-symlink-p (directory-file-name file))))
4433              (ange-ftp-insert-directory              (ange-ftp-insert-directory
4434               (ange-ftp-replace-name-component file tem)               (ange-ftp-expand-symlink
4435                  tem (file-name-directory (directory-file-name file)))
4436               switches wildcard full)               switches wildcard full)
4437            (insert            (insert
4438             (if wildcard             (if wildcard
# Line 4580  NEWNAME should be the name to give the n Line 4496  NEWNAME should be the name to give the n
4496                  ;; ((equal dired-chown-program program))                  ;; ((equal dired-chown-program program))
4497                  (t (error "Unknown remote command: %s" program)))                  (t (error "Unknown remote command: %s" program)))
4498          (ftp-error (insert (format "%s: %s, %s\n"          (ftp-error (insert (format "%s: %s, %s\n"
4499                                      (nth 1 oops)                                     (nth 1 oops)
4500                                      (nth 2 oops)                                     (nth 2 oops)
4501                                      (nth 3 oops)))                                     (nth 3 oops)))
4502                     ;; Caller expects nonzero value to mean failure.                     ;; Caller expects nonzero value to mean failure.
4503                     1)                     1)
4504          (error (insert (format "%s\n" (nth 1 oops)))          (error (insert (format "%s\n" (nth 1 oops)))
# Line 4733  NEWNAME should be the name to give the n Line 4649  NEWNAME should be the name to give the n
4649  ;;                             (t nil))))  ;;                             (t nil))))
4650  ;;                (condition-case err  ;;                (condition-case err
4651  ;;                    (funcall file-creator from to overwrite-confirmed  ;;                    (funcall file-creator from to overwrite-confirmed
4652  ;;                             (list (function ange-ftp-dcf-2)  ;;                             (list 'ange-ftp-dcf-2
4653  ;;                                   nil        ;err  ;;                                   nil        ;err
4654  ;;                                   file-creator operation fn-list  ;;                                   file-creator operation fn-list
4655  ;;                                   name-constructor  ;;                                   name-constructor
# Line 4957  NEWNAME should be the name to give the n Line 4873  NEWNAME should be the name to give the n
4873  ;                                          (progn  ;                                          (progn
4874  ;                                            (end-of-line 1)  ;                                            (end-of-line 1)
4875  ;                                            (point))))  ;                                            (point))))
4876  ;             (ange-ftp-put-hash-entry file type-is-dir tbl)  ;             (puthash file type-is-dir tbl)
4877  ;             (forward-line 1))))  ;             (forward-line 1))))
4878  ;      (ange-ftp-put-hash-entry "." 'vosdir tbl)  ;      (puthash "." 'vosdir tbl)
4879  ;      (ange-ftp-put-hash-entry ".." 'vosdir tbl))  ;      (puthash ".." 'vosdir tbl))
4880  ;    tbl))  ;    tbl))
4881  ;  ;
4882  ;(or (assq 'vos ange-ftp-parse-list-func-alist)  ;(or (assq 'vos ange-ftp-parse-list-func-alist)
# Line 4979  NEWNAME should be the name to give the n Line 4895  NEWNAME should be the name to give the n
4895      (if reverse      (if reverse
4896          (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)          (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
4897              (let (drive dir file)              (let (drive dir file)
4898                (if (match-beginning 1)                (setq drive (match-string 1 name))
4899                    (setq drive (substring name                (setq dir (match-string 2 name))
4900                                           (match-beginning 1)                (setq file (match-string 3 name))
                                          (match-end 1))))  
               (if (match-beginning 2)  
                   (setq dir  
                         (substring name (match-beginning 2) (match-end 2))))  
               (if (match-beginning 3)  
                   (setq file  
                         (substring name (match-beginning 3) (match-end 3))))  
4901                (and dir                (and dir
4902                     (setq dir (subst-char-in-string                     (setq dir (subst-char-in-string
4903                                ?/ ?. (substring dir 1 -1) t)))                                ?/ ?. (substring dir 1 -1) t)))
# Line 5074  Other orders of $ and _ seem to all work Line 4983  Other orders of $ and _ seem to all work
4983  ;; Extract the next filename from a VMS dired-like listing.  ;; Extract the next filename from a VMS dired-like listing.
4984  (defun ange-ftp-parse-vms-filename ()  (defun ange-ftp-parse-vms-filename ()
4985    (if (re-search-forward    (if (re-search-forward
4986           ange-ftp-vms-filename-regexp         ange-ftp-vms-filename-regexp
4987           nil t)         nil t)
4988          (buffer-substring (match-beginning 0) (match-end 0))))        (match-string 0)))
4989    
4990  ;; Parse the current buffer which is assumed to be in MultiNet FTP dir  ;; Parse the current buffer which is assumed to be in MultiNet FTP dir
4991  ;; format, and return a hashtable as the result.  ;; format, and return a hashtable as the result.
4992  (defun ange-ftp-parse-vms-listing ()  (defun ange-ftp-parse-vms-listing ()
4993    (let ((tbl (ange-ftp-make-hashtable))    (let ((tbl (make-hash-table :test 'equal))
4994          file)          file)
4995      (goto-char (point-min))      (goto-char (point-min))
4996      (save-match-data      (save-match-data
4997        (while (setq file (ange-ftp-parse-vms-filename))        (while (setq file (ange-ftp-parse-vms-filename))
4998          (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)          (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
4999              ;; deal with directories              ;; deal with directories
5000              (ange-ftp-put-hash-entry              (puthash (substring file 0 (match-beginning 0)) t tbl)
5001               (substring file 0 (match-beginning 0)) t tbl)            (puthash file nil tbl)
           (ange-ftp-put-hash-entry file nil tbl)  
5002            (if (string-match ";[0-9]+$" file) ; deal with extension            (if (string-match ";[0-9]+$" file) ; deal with extension
5003                ;; sans extension                ;; sans extension
5004                (ange-ftp-put-hash-entry                (puthash (substring file 0 (match-beginning 0)) nil tbl)))
                (substring file 0 (match-beginning 0)) nil tbl)))  
5005          (forward-line 1))          (forward-line 1))
5006        ;; Would like to look for a "Total" line, or a "Directory" line to        ;; Would like to look for a "Total" line, or a "Directory" line to
5007        ;; make sure that the listing isn't complete garbage before putting        ;; make sure that the listing isn't complete garbage before putting
5008        ;; in "." and "..", but we can't even count on all VAX's giving us        ;; in "." and "..", but we can't even count on all VAX's giving us
5009        ;; either of these.        ;; either of these.
5010             (ange-ftp-put-hash-entry "." t tbl)        (puthash "." t tbl)
5011             (ange-ftp-put-hash-entry ".." t tbl))        (puthash ".." t tbl))
5012      tbl))      tbl))
5013    
5014  (or (assq 'vms ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
5015      (setq ange-ftp-parse-list-func-alist               '(vms . ange-ftp-parse-vms-listing))
           (cons '(vms . ange-ftp-parse-vms-listing)  
                 ange-ftp-parse-list-func-alist)))  
5016    
5017  ;; This version only deletes file entries which have  ;; This version only deletes file entries which have
5018  ;; explicit version numbers, because that is all VMS allows.  ;; explicit version numbers, because that is all VMS allows.
# Line 5124  Other orders of $ and _ seem to all work Line 5029  Other orders of $ and _ seem to all work
5029              ;; In VMS you can't delete a file without an explicit              ;; In VMS you can't delete a file without an explicit
5030              ;; version number, or wild-card (e.g. FOO;*)              ;; version number, or wild-card (e.g. FOO;*)
5031              ;; For now, we give up on wildcards.              ;; For now, we give up on wildcards.
5032              (let ((files (ange-ftp-get-hash-entry              (let ((files (gethash (file-name-directory name)
5033                            (file-name-directory name)                                    ange-ftp-files-hashtable)))
                           ange-ftp-files-hashtable)))  
5034                (if files                (if files
5035                    (let* ((root (substring file 0                    (let* ((root (substring file 0
5036                                            (match-beginning 0)))                                            (match-beginning 0)))
# Line 5134  Other orders of $ and _ seem to all work Line 5038  Other orders of $ and _ seem to all work
5038                                           (regexp-quote root)                                           (regexp-quote root)
5039                                           ";[0-9]+$"))                                           ";[0-9]+$"))
5040                           versions)                           versions)
5041                      (ange-ftp-del-hash-entry file files)                      (remhash file files)
5042                      ;; Now we need to check if there are any                      ;; Now we need to check if there are any
5043                      ;; versions left. If not, then delete the                      ;; versions left. If not, then delete the
5044                      ;; root entry.                      ;; root entry.
5045                      (mapatoms                      (maphash
5046                       (lambda (sym)                       (lambda (key val)
5047                         (and (string-match regexp (get sym 'key))                         (and (string-match regexp key)
5048                              (setq versions t)))                              (setq versions t)))
5049                       files)                       files)
5050                      (or versions                      (or versions
5051                          (ange-ftp-del-hash-entry root files))))))))))                          (remhash root files))))))))))
5052    
5053  (or (assq 'vms ange-ftp-delete-file-entry-alist)  (or (assq 'vms ange-ftp-delete-file-entry-alist)
5054      (setq ange-ftp-delete-file-entry-alist      (setq ange-ftp-delete-file-entry-alist
# Line 5154  Other orders of $ and _ seem to all work Line 5058  Other orders of $ and _ seem to all work
5058  (defun ange-ftp-vms-add-file-entry (name &optional dir-p)  (defun ange-ftp-vms-add-file-entry (name &optional dir-p)
5059    (if dir-p    (if dir-p
5060        (ange-ftp-internal-add-file-entry name t)        (ange-ftp-internal-add-file-entry name t)
5061      (let ((files (ange-ftp-get-hash-entry      (let ((files (gethash (file-name-directory name)
5062                    (file-name-directory name)                            ange-ftp-files-hashtable)))
                   ange-ftp-files-hashtable)))  
5063        (if files        (if files
5064            (let ((file (ange-ftp-get-file-part name)))            (let ((file (ange-ftp-get-file-part name)))
5065              (save-match-data              (save-match-data
5066                (if (string-match ";[0-9]+$" file)                (if (string-match ";[0-9]+$" file)
5067                    (ange-ftp-put-hash-entry                    (puthash (substring file 0 (match-beginning 0)) nil files)
                    (substring file 0 (match-beginning 0))  
                    nil files)  
5068                  ;; Need to figure out what version of the file                  ;; Need to figure out what version of the file
5069                  ;; is being added.                  ;; is being added.
5070                  (let ((regexp (concat "^"                  (let ((regexp (concat "^"
5071                                        (regexp-quote file)                                        (regexp-quote file)
5072                                        ";\\([0-9]+\\)$"))                                        ";\\([0-9]+\\)$"))
5073                        (version 0))                        (version 0))
5074                    (mapatoms                    (maphash
5075                     (lambda (sym)                     (lambda (name val)
5076                       (let ((name (get sym 'key)))                       (and (string-match regexp name)
5077                         (and (string-match regexp name)                            (setq version
5078                              (setq version                                  (max version
5079                                    (max version                                       (string-to-int (match-string 1 name))))))
                                        (string-to-int  
                                         (substring name  
                                                    (match-beginning 1)  
                                                    (match-end 1))))))))  
5080                     files)                     files)
5081                    (setq version (1+ version))                    (setq version (1+ version))
5082                    (ange-ftp-put-hash-entry                    (puthash
5083                     (concat file ";" (int-to-string version))                     (concat file ";" (int-to-string version))
5084                     nil files))))                     nil files))))
5085              (ange-ftp-put-hash-entry file nil files))))))              (puthash file nil files))))))
5086    
5087  (or (assq 'vms ange-ftp-add-file-entry-alist)  (or (assq 'vms ange-ftp-add-file-entry-alist)
5088      (setq ange-ftp-add-file-entry-alist      (setq ange-ftp-add-file-entry-alist
# Line 5410  Other orders of $ and _ seem to all work Line 5307  Other orders of $ and _ seem to all work
5307  ;;    ;; If the file has numeric backup versions,  ;;    ;; If the file has numeric backup versions,
5308  ;;    ;; put on ange-ftp-file-version-alist an element of the form  ;;    ;; put on ange-ftp-file-version-alist an element of the form
5309  ;;    ;; (FILENAME . VERSION-NUMBER-LIST)  ;;    ;; (FILENAME . VERSION-NUMBER-LIST)
5310  ;;    (dired-map-dired-file-lines (function  ;;    (dired-map-dired-file-lines 'ange-ftp-dired-vms-collect-file-versions)
 ;;                               ange-ftp-dired-vms-collect-file-versions))  
5311  ;;    ;; Sort each VERSION-NUMBER-LIST,  ;;    ;; Sort each VERSION-NUMBER-LIST,
5312  ;;    ;; and remove the versions not to be deleted.  ;;    ;; and remove the versions not to be deleted.
5313  ;;    (let ((fval ange-ftp-file-version-alist))  ;;    (let ((fval ange-ftp-file-version-alist))
# Line 5428  Other orders of $ and _ seem to all work Line 5324  Other orders of $ and _ seem to all work
5324  ;;    ;; Look at each file.  If it is a numeric backup file,  ;;    ;; Look at each file.  If it is a numeric backup file,
5325  ;;    ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.  ;;    ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion.
5326  ;;    (dired-map-dired-file-lines  ;;    (dired-map-dired-file-lines
5327  ;;     (function  ;;     'ange-ftp-dired-vms-trample-file-versions mark)
 ;;      ange-ftp-dired-vms-trample-file-versions mark))  
5328  ;;    (message (concat action " numerical backups...done"))))  ;;    (message (concat action " numerical backups...done"))))
5329    
5330  ;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)  ;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)
# Line 5531  Other orders of $ and _ seem to all work Line 5426  Other orders of $ and _ seem to all work
5426      (if reverse      (if reverse
5427          (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)          (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
5428              (let (acct file)              (let (acct file)
5429                (if (match-beginning 1)                (setq acct (match-string 1 name))
5430                    (setq acct (substring name 0 (match-end 1))))                (setq file (match-string 2 name))
               (if (match-beginning 2)  
                   (setq file (substring name  
                                         (match-beginning 2) (match-end 2))))  
5431                (concat (and acct (concat "/" acct "/"))                (concat (and acct (concat "/" acct "/"))
5432                        file))                        file))
5433            (error "name %s didn't match" name))            (error "name %s didn't match" name))
5434        (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)        (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)
5435            (concat (substring name 1 (match-end 1))            (concat (match-string 1 name) (match-string 2 name))
                   (substring name (match-beginning 2) (match-end 2)))  
5436          ;; Let's hope that mts will recognize it anyway.          ;; Let's hope that mts will recognize it anyway.
5437          name))))          name))))
5438    
# Line 5582  Other orders of $ and _ seem to all work Line 5473  Other orders of $ and _ seem to all work
5473    
5474  ;; Parse the current buffer which is assumed to be in mts ftp dir format.  ;; Parse the current buffer which is assumed to be in mts ftp dir format.
5475  (defun ange-ftp-parse-mts-listing ()  (defun ange-ftp-parse-mts-listing ()
5476    (let ((tbl (ange-ftp-make-hashtable)))    (let ((tbl (make-hash-table :test 'equal)))
5477      (goto-char (point-min))      (goto-char (point-min))
5478      (save-match-data      (save-match-data
5479        (while (re-search-forward ange-ftp-date-regexp nil t)        (while (re-search-forward ange-ftp-date-regexp nil t)
# Line 5590  Other orders of $ and _ seem to all work Line 5481  Other orders of $ and _ seem to all work
5481          (skip-chars-backward " ")          (skip-chars-backward " ")
5482          (let ((end (point)))          (let ((end (point)))
5483            (skip-chars-backward "-A-Z0-9_.!")            (skip-chars-backward "-A-Z0-9_.!")
5484            (ange-ftp-put-hash-entry (buffer-substring (point) end) nil tbl))            (puthash (buffer-substring (point) end) nil tbl))
5485          (forward-line 1)))          (forward-line 1)))
5486        ;; Don't need to bother with ..      ;; Don't need to bother with ..
5487      (ange-ftp-put-hash-entry "." t tbl)      (puthash "." t tbl)
5488      tbl))      tbl))
5489    
5490  (or (assq 'mts ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
5491      (setq ange-ftp-parse-list-func-alist               '(mts . ange-ftp-parse-mts-listing))
           (cons '(mts . ange-ftp-parse-mts-listing)  
                 ange-ftp-parse-list-func-alist)))  
5492    
5493  (defun ange-ftp-add-mts-host (host)  (defun ange-ftp-add-mts-host (host)
5494    "Mark HOST as the name of a machine running MTS."    "Mark HOST as the name of a machine running MTS."
# Line 5700  Other orders of $ and _ seem to all work Line 5589  Other orders of $ and _ seem to all work
5589          (concat "/" name)          (concat "/" name)
5590        (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"        (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
5591                          name)                          name)
5592            (let ((minidisk (substring name 1 (match-end 1))))            (let ((minidisk (match-string 1 name)))
5593              (if (match-beginning 2)              (if (match-beginning 2)
5594                  (let ((file (substring name (match-beginning 2)                  (let ((file (match-string 2 name))
                                        (match-end 2)))  
5595                        (cmd (concat "cd " minidisk))                        (cmd (concat "cd " minidisk))
5596    
5597                        ;; Note that host and user are bound in the call                        ;; Note that host and user are bound in the call
# Line 5745  Other orders of $ and _ seem to all work Line 5633  Other orders of $ and _ seem to all work
5633     ((string-equal "/" dir-name)     ((string-equal "/" dir-name)
5634      (error "Cannot get listing for fictitious \"/\" directory"))      (error "Cannot get listing for fictitious \"/\" directory"))
5635     ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)     ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)
5636      (let* ((minidisk (substring dir-name (match-beginning 1) (match-end 1)))      (let* ((minidisk (match-string 1 dir-name))
5637             ;; host and user are bound in the call to ange-ftp-send-cmd             ;; host and user are bound in the call to ange-ftp-send-cmd
5638             (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))             (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user))
5639             (cmd (concat "cd " minidisk))             (cmd (concat "cd " minidisk))
5640             (file (if (match-beginning 2)             (file (if (match-beginning 2)
5641                       ;; it's a single file                       ;; it's a single file
5642                       (substring dir-name (match-beginning 2)                       (match-string 2 dir-name)
                                 (match-end 2))  
5643                     ;; use the wild-card                     ;; use the wild-card
5644                     "*")))                     "*")))
5645        (if (car (ange-ftp-raw-send-cmd proc cmd))        (if (car (ange-ftp-raw-send-cmd proc cmd))
# Line 5809  Other orders of $ and _ seem to all work Line 5696  Other orders of $ and _ seem to all work
5696  ;        (minidisk (ange-ftp-get-file-part dir-file))  ;        (minidisk (ange-ftp-get-file-part dir-file))
5697  ;        (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable)))  ;        (root-tbl (ange-ftp-get-hash-entry root ange-ftp-files-hashtable)))
5698  ;    (if root-tbl  ;    (if root-tbl
5699  ;       (ange-ftp-put-hash-entry minidisk t root-tbl)  ;       (puthash minidisk t root-tbl)
5700  ;      (setq root-tbl (ange-ftp-make-hashtable))  ;      (setq root-tbl (ange-ftp-make-hashtable))
5701  ;      (ange-ftp-put-hash-entry minidisk t root-tbl)  ;      (puthash minidisk t root-tbl)
5702  ;      (ange-ftp-put-hash-entry "." t root-tbl)  ;      (puthash "." t root-tbl)
5703  ;      (ange-ftp-set-files root root-tbl)))  ;      (ange-ftp-set-files root root-tbl)))
5704    ;; Now do the usual parsing    ;; Now do the usual parsing
5705    (let ((tbl (ange-ftp-make-hashtable)))    (let ((tbl (make-hash-table :test 'equal)))
5706      (goto-char (point-min))      (goto-char (point-min))
5707      (save-match-data      (save-match-data
5708        (while        (while
5709            (re-search-forward            (re-search-forward
5710             "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)             "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
5711          (ange-ftp-put-hash-entry          (puthash (concat (match-string 1) "." (match-string 2)) nil tbl)
          (concat (buffer-substring (match-beginning 1)  
                                    (match-end 1))  
                  "."  
                  (buffer-substring (match-beginning 2)  
                                    (match-end 2)))  
          nil tbl)  
5712          (forward-line 1))          (forward-line 1))
5713        (ange-ftp-put-hash-entry "." t tbl))        (puthash "." t tbl))
5714      tbl))      tbl))
5715    
5716  (or (assq 'cms ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
5717      (setq ange-ftp-parse-list-func-alist               '(cms . ange-ftp-parse-cms-listing))
           (cons '(cms . ange-ftp-parse-cms-listing)  
                 ange-ftp-parse-list-func-alist)))  
5718    
5719  ;;;;; Tree dired support:  ;;;;; Tree dired support:
5720    
# Line 5949  Other orders of $ and _ seem to all work Line 5828  Other orders of $ and _ seem to all work
5828     "^\\(" ange-ftp-bs2000-filename-pubset-regexp "\\)?"     "^\\(" ange-ftp-bs2000-filename-pubset-regexp "\\)?"
5829     "\\(" ange-ftp-bs2000-filename-username-regexp "\\)?"     "\\(" ange-ftp-bs2000-filename-username-regexp "\\)?"
5830     "\\(" ange-ftp-bs2000-short-filename-regexp "\\)?")     "\\(" ange-ftp-bs2000-short-filename-regexp "\\)?")
5831  "Regular expression used in ange-ftp-fix-name-for-bs2000.")    "Regular expression used in ange-ftp-fix-name-for-bs2000.")
5832    
5833  (defconst ange-ftp-bs2000-fix-name-regexp  (defconst ange-ftp-bs2000-fix-name-regexp
5834    (concat    (concat
5835     "/?\\(" ange-ftp-bs2000-filename-pubset-regexp "/\\)?"     "/?\\(" ange-ftp-bs2000-filename-pubset-regexp "/\\)?"
5836     "\\(\\$[A-Z0-9]*/\\)?"     "\\(\\$[A-Z0-9]*/\\)?"
5837     "\\(" ange-ftp-bs2000-short-filename-regexp "\\)?")     "\\(" ange-ftp-bs2000-short-filename-regexp "\\)?")
5838  "Regular expression used in ange-ftp-fix-name-for-bs2000.")    "Regular expression used in ange-ftp-fix-name-for-bs2000.")
5839    
5840  (defcustom ange-ftp-bs2000-special-prefix  (defcustom ange-ftp-bs2000-special-prefix
5841    "X"    "X"
# Line 6016  Other orders of $ and _ seem to all work Line 5895  Other orders of $ and _ seem to all work
5895                (and userid (concat userid "."))                (and userid (concat userid "."))
5896                ;; change every '/' in filename to a '.', normally not neccessary                ;; change every '/' in filename to a '.', normally not neccessary
5897                (and filename                (and filename
5898                     (apply (function concat)                     (subst-char-in-string ?/ ?. filename)))))
                           (mapcar (function (lambda (char)  
                                               (if (= char ?/)  
                                                   (vector ?.)  
                                                 (vector char))))  
                                   filename))))))  
5899          ;; Let's hope that BS2000 recognize this anyway:          ;; Let's hope that BS2000 recognize this anyway:
5900          name))))          name))))
5901    
# Line 6073  Other orders of $ and _ seem to all work Line 5947  Other orders of $ and _ seem to all work
5947                      ange-ftp-bs2000-host-regexp)                      ange-ftp-bs2000-host-regexp)
5948              ange-ftp-host-cache nil)))              ange-ftp-host-cache nil)))
5949    
 (defvar ange-ftp-bs2000-posix-hook-installed nil)  
   
5950  (defun ange-ftp-add-bs2000-posix-host (host)  (defun ange-ftp-add-bs2000-posix-host (host)
5951    "Mark HOST as the name of a machine running BS2000 with POSIX subsystem."    "Mark HOST as the name of a machine running BS2000 with POSIX subsystem."
5952    (interactive    (interactive
# Line 6088  Other orders of $ and _ seem to all work Line 5960  Other orders of $ and _ seem to all work
5960                      ange-ftp-bs2000-posix-host-regexp)                      ange-ftp-bs2000-posix-host-regexp)
5961              ange-ftp-host-cache nil))              ange-ftp-host-cache nil))
5962    ;; Install CD hook to cd to posix on connecting:    ;; Install CD hook to cd to posix on connecting:
5963    (and (not ange-ftp-bs2000-posix-hook-installed)    (add-hook 'ange-ftp-process-startup-hook 'ange-ftp-bs2000-cd-to-posix)
        (add-hook 'ange-ftp-process-startup-hook 'ange-ftp-bs2000-cd-to-posix)  
        (setq ange-ftp-bs2000-posix-hook-installed t))  
5964    host)    host)
5965    
5966  (defconst ange-ftp-bs2000-filename-regexp  (defconst ange-ftp-bs2000-filename-regexp
# Line 6112  Other orders of $ and _ seem to all work Line 5982  Other orders of $ and _ seem to all work
5982  ;; Extract the next filename from a BS2000 dired-like listing.  ;; Extract the next filename from a BS2000 dired-like listing.
5983  (defun ange-ftp-parse-bs2000-filename ()  (defun ange-ftp-parse-bs2000-filename ()
5984    (if (re-search-forward ange-ftp-bs2000-filename-regexp nil t)    (if (re-search-forward ange-ftp-bs2000-filename-regexp nil t)
5985          (buffer-substring (match-beginning 2) (match-end 2))))        (match-string 2)))
5986    
5987  ;; Parse the current buffer which is assumed to be in (some) BS2000 FTP dir  ;; Parse the current buffer which is assumed to be in (some) BS2000 FTP dir
5988  ;; format, and return a hashtable as the result.  ;; format, and return a hashtable as the result.
5989  (defun ange-ftp-parse-bs2000-listing ()  (defun ange-ftp-parse-bs2000-listing ()
5990    (let ((tbl (ange-ftp-make-hashtable))    (let ((tbl (make-hash-table :test 'equal))
5991          pubset          pubset
5992          file)          file)
5993      ;; get current pubset      ;; get current pubset
5994      (goto-char (point-min))      (goto-char (point-min))
5995      (if (re-search-forward ange-ftp-bs2000-filename-pubset-regexp nil t)      (if (re-search-forward ange-ftp-bs2000-filename-pubset-regexp nil t)
5996          (setq pubset (buffer-substring (match-beginning 0) (match-end 0))))          (setq pubset (match-string 0)))
5997      ;; add files to hashtable      ;; add files to hashtable
5998      (goto-char (point-min))      (goto-char (point-min))
5999      (save-match-data      (save-match-data
6000        (while (setq file (ange-ftp-parse-bs2000-filename))        (while (setq file (ange-ftp-parse-bs2000-filename))
6001          (ange-ftp-put-hash-entry file nil tbl)))          (puthash file nil tbl)))
6002      ;; add . and ..      ;; add . and ..
6003      (ange-ftp-put-hash-entry "." t tbl)      (puthash "." t tbl)
6004      (ange-ftp-put-hash-entry ".." t tbl)      (puthash ".." t tbl)
6005      ;; add all additional pubsets, if not listing one of them      ;; add all additional pubsets, if not listing one of them
6006      (if (not (member pubset ange-ftp-bs2000-additional-pubsets))      (if (not (member pubset ange-ftp-bs2000-additional-pubsets))
6007          (mapcar (function (lambda (pubset)          (mapcar (lambda (pubset) (puthash pubset t tbl))
                             (ange-ftp-put-hash-entry pubset t tbl)))  
6008                  ange-ftp-bs2000-additional-pubsets))                  ange-ftp-bs2000-additional-pubsets))
6009      tbl))      tbl))
6010    
6011  (or (assq 'bs2000 ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
6012      (setq ange-ftp-parse-list-func-alist               '(bs2000 . ange-ftp-parse-bs2000-listing))
           (cons '(bs2000 . ange-ftp-parse-bs2000-listing)  
                 ange-ftp-parse-list-func-alist)))  
6013    
6014  (defun ange-ftp-bs2000-cd-to-posix ()  (defun ange-ftp-bs2000-cd-to-posix ()
6015    "cd to POSIX subsystem if the current host matches    "cd to POSIX subsystem if the current host matches
6016  ange-ftp-bs2000-posix-host-regexp.  All BS2000 hosts with POSIX subsystem  `ange-ftp-bs2000-posix-host-regexp'.  All BS2000 hosts with POSIX subsystem
6017  MUST BE EXPLICITLY SET with ange-ftp-add-bs2000-posix-host for they cannot  MUST BE EXPLICITLY SET with `ange-ftp-add-bs2000-posix-host' for they cannot
6018  be recognized automatically (they are all valid BS2000 hosts too)."  be recognized automatically (they are all valid BS2000 hosts too)."
6019    (if (and host (ange-ftp-bs2000-posix-host host))    (if (and ange-ftp-this-host (ange-ftp-bs2000-posix-host ange-ftp-this-host))
6020        (progn        (progn
6021          ;; change to POSIX:          ;; change to POSIX:
6022  ;       (ange-ftp-raw-send-cmd proc "cd %POSIX")  ;       (ange-ftp-raw-send-cmd proc "cd %POSIX")
6023          (ange-ftp-cd host user "%POSIX")          (ange-ftp-cd ange-ftp-this-host ange-ftp-this-user "%POSIX")
6024          ;; put new home directory in the expand-dir hashtable.          ;; put new home directory in the expand-dir hashtable.
6025          ;; `host' and `user' are bound in ange-ftp-get-process.          ;; `ange-ftp-this-host' and `ange-ftp-this-user' are bound in
6026          (ange-ftp-put-hash-entry (concat host "/" user "/~")          ;; ange-ftp-get-process.
6027                                   (car (ange-ftp-get-pwd host user))          (puthash (concat ange-ftp-this-host "/" ange-ftp-this-user "/~")
6028                                   ange-ftp-expand-dir-hashtable))))                   (car (ange-ftp-get-pwd ange-ftp-this-host ange-ftp-this-user))
6029                     ange-ftp-expand-dir-hashtable))))
6030    
6031  ;; Not available yet:  ;; Not available yet:
6032  ;; ange-ftp-bs2000-delete-file-entry  ;; ange-ftp-bs2000-delete-file-entry

Legend:
Removed from v.1.35  
changed lines
  Added in v.1.35.2.1

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26