Mercurial > emacs
comparison lisp/net/ange-ftp.el @ 64906:63dd464bce2d
Use \\` and \\' instead of ^ and $ in regexps.
(ange-ftp-send-cmd): Revert last change, and expand
the comment explaining the problem.
author | Stefan Monnier <monnier@iro.umontreal.ca> |
---|---|
date | Thu, 11 Aug 2005 10:24:48 +0000 |
parents | 15e2ef5c7c16 |
children | 5fd07f61ee51 2d92f5c9d6ae |
comparison
equal
deleted
inserted
replaced
64905:b929318406af | 64906:63dd464bce2d |
---|---|
684 made as simple and transparent as possible." | 684 made as simple and transparent as possible." |
685 :group 'files | 685 :group 'files |
686 :prefix "ange-ftp-") | 686 :prefix "ange-ftp-") |
687 | 687 |
688 (defcustom ange-ftp-name-format | 688 (defcustom ange-ftp-name-format |
689 '("^/\\(\\([^/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4)) | 689 '("\\`/\\(\\([^/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4)) |
690 "*Format of a fully expanded remote file name. | 690 "*Format of a fully expanded remote file name. |
691 | 691 |
692 This is a list of the form \(REGEXP HOST USER NAME\), | 692 This is a list of the form \(REGEXP HOST USER NAME\), |
693 where REGEXP is a regular expression matching | 693 where REGEXP is a regular expression matching |
694 the full remote name, and HOST, USER, and NAME are the numbers of | 694 the full remote name, and HOST, USER, and NAME are the numbers of |
861 :group 'ange-ftp | 861 :group 'ange-ftp |
862 :type '(choice (const :tag "Default" nil) | 862 :type '(choice (const :tag "Default" nil) |
863 string)) | 863 string)) |
864 | 864 |
865 (defcustom ange-ftp-binary-file-name-regexp | 865 (defcustom ange-ftp-binary-file-name-regexp |
866 (concat "\\.[zZ]$\\|\\.lzh$\\|\\.arc$\\|\\.zip$\\|\\.zoo$\\|\\.tar$\\|" | 866 (concat "TAGS\\'\\|\\.\\(?:" |
867 "\\.dvi$\\|\\.ps$\\|\\.elc$\\|TAGS$\\|\\.gif$\\|" | 867 (eval-when-compile |
868 "\\.EXE\\(;[0-9]+\\)?$\\|\\.[zZ]-part-..$\\|\\.gz$\\|" | 868 (regexp-opt '("z" "Z" "lzh" "arc" "zip" "zoo" "tar" "dvi" |
869 "\\.taz$\\|\\.tgz$") | 869 "ps" "elc" "gif" "gz" "taz" "tgz"))) |
870 "\\|EXE\\(;[0-9]+\\)?\\|[zZ]-part-..\\)\\'") | |
870 "*If a file matches this regexp then it is transferred in binary mode." | 871 "*If a file matches this regexp then it is transferred in binary mode." |
871 :group 'ange-ftp | 872 :group 'ange-ftp |
872 :type 'regexp) | 873 :type 'regexp) |
873 | 874 |
874 (defcustom ange-ftp-gateway-host nil | 875 (defcustom ange-ftp-gateway-host nil |
1128 "Abbreviate the file name FILE relative to the `default-directory'. | 1129 "Abbreviate the file name FILE relative to the `default-directory'. |
1129 If the optional parameter NEW is given and the non-directory parts match, | 1130 If the optional parameter NEW is given and the non-directory parts match, |
1130 only return the directory part of FILE." | 1131 only return the directory part of FILE." |
1131 (save-match-data | 1132 (save-match-data |
1132 (if (and default-directory | 1133 (if (and default-directory |
1133 (string-match (concat "^" | 1134 (string-match (concat "\\`" |
1134 (regexp-quote default-directory) | 1135 (regexp-quote default-directory) |
1135 ".") file)) | 1136 ".") file)) |
1136 (setq file (substring file (1- (match-end 0))))) | 1137 (setq file (substring file (1- (match-end 0))))) |
1137 (if (and new | 1138 (if (and new |
1138 (string-equal (file-name-nondirectory file) | 1139 (string-equal (file-name-nondirectory file) |
1198 (if (ange-ftp-lookup-passwd host user) (throw 'found-one host))) | 1199 (if (ange-ftp-lookup-passwd host user) (throw 'found-one host))) |
1199 ange-ftp-user-hashtable) | 1200 ange-ftp-user-hashtable) |
1200 (save-match-data | 1201 (save-match-data |
1201 (maphash | 1202 (maphash |
1202 (lambda (key value) | 1203 (lambda (key value) |
1203 (if (string-match "^[^/]*\\(/\\).*$" key) | 1204 (if (string-match "\\`[^/]*\\(/\\).*\\'" key) |
1204 (let ((host (substring key 0 (match-beginning 1)))) | 1205 (let ((host (substring key 0 (match-beginning 1)))) |
1205 (if (and (string-equal user (substring key (match-end 1))) | 1206 (if (and (string-equal user (substring key (match-end 1))) |
1206 value) | 1207 value) |
1207 (throw 'found-one host))))) | 1208 (throw 'found-one host))))) |
1208 ange-ftp-passwd-hashtable)) | 1209 ange-ftp-passwd-hashtable)) |
1413 (ange-ftp-parse-netrc) | 1414 (ange-ftp-parse-netrc) |
1414 (save-match-data | 1415 (save-match-data |
1415 (let (res) | 1416 (let (res) |
1416 (maphash | 1417 (maphash |
1417 (lambda (key value) | 1418 (lambda (key value) |
1418 (if (string-match "^[^/]*\\(/\\).*$" key) | 1419 (if (string-match "\\`[^/]*\\(/\\).*\\'" key) |
1419 (let ((host (substring key 0 (match-beginning 1))) | 1420 (let ((host (substring key 0 (match-beginning 1))) |
1420 (user (substring key (match-end 1)))) | 1421 (user (substring key (match-end 1)))) |
1421 (push (concat user "@" host ":") res)))) | 1422 (push (concat user "@" host ":") res)))) |
1422 ange-ftp-passwd-hashtable) | 1423 ange-ftp-passwd-hashtable) |
1423 (maphash | 1424 (maphash |
1653 (progn | 1654 (progn |
1654 (set-buffer (process-buffer proc)) | 1655 (set-buffer (process-buffer proc)) |
1655 | 1656 |
1656 ;; handle hash mark printing | 1657 ;; handle hash mark printing |
1657 (and ange-ftp-process-busy | 1658 (and ange-ftp-process-busy |
1658 (string-match "^#+$" str) | 1659 (string-match "\\`#+\\'" str) |
1659 (setq str (ange-ftp-process-handle-hash str))) | 1660 (setq str (ange-ftp-process-handle-hash str))) |
1660 (comint-output-filter proc str) | 1661 (comint-output-filter proc str) |
1661 ;; Replace STR by the result of the comint processing. | 1662 ;; Replace STR by the result of the comint processing. |
1662 (setq str (buffer-substring comint-last-output-start | 1663 (setq str (buffer-substring comint-last-output-start |
1663 (process-mark proc))) | 1664 (process-mark proc))) |
1676 0 | 1677 0 |
1677 (match-beginning 0))) | 1678 (match-beginning 0))) |
1678 (seen-prompt nil)) | 1679 (seen-prompt nil)) |
1679 (setq ange-ftp-process-string (substring ange-ftp-process-string | 1680 (setq ange-ftp-process-string (substring ange-ftp-process-string |
1680 (match-end 0))) | 1681 (match-end 0))) |
1681 (while (string-match "^ftp> *" line) | 1682 (while (string-match "\\`ftp> *" line) |
1682 (setq seen-prompt t) | 1683 (setq seen-prompt t) |
1683 (setq line (substring line (match-end 0)))) | 1684 (setq line (substring line (match-end 0)))) |
1684 (if (not (and seen-prompt ange-ftp-pending-error-line)) | 1685 (if (not (and seen-prompt ange-ftp-pending-error-line)) |
1685 (ange-ftp-process-handle-line line proc) | 1686 (ange-ftp-process-handle-line line proc) |
1686 ;; If we've seen a potential error message and it | 1687 ;; If we've seen a potential error message and it |
1861 (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg)) | 1862 (and msg ange-ftp-process-verbose (ange-ftp-message "%s..." msg)) |
1862 (goto-char (point-max)) | 1863 (goto-char (point-max)) |
1863 (move-marker comint-last-input-start (point)) | 1864 (move-marker comint-last-input-start (point)) |
1864 ;; don't insert the password into the buffer on the USER command. | 1865 ;; don't insert the password into the buffer on the USER command. |
1865 (save-match-data | 1866 (save-match-data |
1866 (if (string-match "^user \"[^\"]*\"" cmd) | 1867 (if (string-match "\\`user \"[^\"]*\"" cmd) |
1867 (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n") | 1868 (insert (substring cmd 0 (match-end 0)) " Turtle Power!\n") |
1868 (insert cmd))) | 1869 (insert cmd))) |
1869 (move-marker comint-last-input-end (point)) | 1870 (move-marker comint-last-input-end (point)) |
1870 (process-send-string proc cmd) | 1871 (process-send-string proc cmd) |
1871 (set-marker (process-mark proc) (point)) | 1872 (set-marker (process-mark proc) (point)) |
2067 (defun ange-ftp-normal-login (host user pass account proc) | 2068 (defun ange-ftp-normal-login (host user pass account proc) |
2068 "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. | 2069 "Connect to the FTP-server on HOST as USER using PASSWORD and ACCOUNT. |
2069 PROC is the process to the FTP-client. HOST may have an optional | 2070 PROC is the process to the FTP-client. HOST may have an optional |
2070 suffix of the form #PORT to specify a non-default port" | 2071 suffix of the form #PORT to specify a non-default port" |
2071 (save-match-data | 2072 (save-match-data |
2072 (string-match "^\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host) | 2073 (string-match "\\`\\([^#]+\\)\\(#\\([0-9]+\\)\\)?\\'" host) |
2073 (let* ((nshost (ange-ftp-nslookup-host (match-string 1 host))) | 2074 (let* ((nshost (ange-ftp-nslookup-host (match-string 1 host))) |
2074 (port (match-string 3 host)) | 2075 (port (match-string 3 host)) |
2075 (result (ange-ftp-raw-send-cmd | 2076 (result (ange-ftp-raw-send-cmd |
2076 proc | 2077 proc |
2077 (if port | 2078 (if port |
2146 | 2147 |
2147 ;; if a default value for this is set, use that value. | 2148 ;; if a default value for this is set, use that value. |
2148 (or ange-ftp-binary-hash-mark-size | 2149 (or ange-ftp-binary-hash-mark-size |
2149 (setq ange-ftp-binary-hash-mark-size size))))))))) | 2150 (setq ange-ftp-binary-hash-mark-size size))))))))) |
2150 | 2151 |
2152 (defvar ange-ftp-process-startup-hook nil) | |
2153 | |
2151 (defun ange-ftp-get-process (host user) | 2154 (defun ange-ftp-get-process (host user) |
2152 "Return an FTP subprocess connected to HOST and logged in as USER. | 2155 "Return an FTP subprocess connected to HOST and logged in as USER. |
2153 Create a new process if needed." | 2156 Create a new process if needed." |
2154 (let* ((name (ange-ftp-ftp-process-buffer host user)) | 2157 (let* ((name (ange-ftp-ftp-process-buffer host user)) |
2155 (proc (get-process name))) | 2158 (proc (get-process name))) |
2307 cmd3 (nth 3 cmd)) | 2310 cmd3 (nth 3 cmd)) |
2308 ;; Need to deal with the HP-UX ftp bug. This should also allow us to | 2311 ;; Need to deal with the HP-UX ftp bug. This should also allow us to |
2309 ;; resolve symlinks to directories on SysV machines. (Sebastian will | 2312 ;; resolve symlinks to directories on SysV machines. (Sebastian will |
2310 ;; be happy.) | 2313 ;; be happy.) |
2311 (and (eq host-type 'unix) | 2314 (and (eq host-type 'unix) |
2312 (string-match "/$" cmd1) | 2315 (string-match "/\\'" cmd1) |
2313 (not (string-match "R" cmd3)) | 2316 (not (string-match "R" cmd3)) |
2314 (setq cmd1 (concat cmd1 "."))) | 2317 (setq cmd1 (concat cmd1 "."))) |
2315 | 2318 |
2316 ;; If the dir name contains a space, some ftp servers will | 2319 ;; If the dir name contains a space, some ftp servers will |
2317 ;; refuse to list it. We instead change directory to the | 2320 ;; refuse to list it. We instead change directory to the |
2324 | 2327 |
2325 ;; If the remote ls can take switches, put them in | 2328 ;; If the remote ls can take switches, put them in |
2326 (unless (memq host-type ange-ftp-dumb-host-types) | 2329 (unless (memq host-type ange-ftp-dumb-host-types) |
2327 (setq cmd0 'ls) | 2330 (setq cmd0 'ls) |
2328 ;; We cd and then use `ls' with no directory argument. | 2331 ;; We cd and then use `ls' with no directory argument. |
2329 ;; This works around a misfeature of some versions of netbsd ftpd. | 2332 ;; This works around a misfeature of some versions of netbsd ftpd |
2333 ;; where `ls' can only take one argument: either one set of flags | |
2334 ;; or a file/directory name. | |
2335 ;; FIXME: if we're trying to `ls' a single file, this fails since we | |
2336 ;; can't cd to a file. We can't fix this problem here, tho, because | |
2337 ;; at this point we don't know whether the argument is a file or | |
2338 ;; a directory. Such an `ls' is only every used (apparently) from | |
2339 ;; `insert-directory' when the `full-directory-p' argument is nil | |
2340 ;; (which seems to only be used by dired when updating its display | |
2341 ;; after operating on a set of files). We should change | |
2342 ;; ange-ftp-insert-directory so that this case is handled by getting | |
2343 ;; a full listing of the directory and extracting the line | |
2344 ;; corresponding to the requested file. | |
2330 (unless (equal cmd1 ".") | 2345 (unless (equal cmd1 ".") |
2331 (setq result (ange-ftp-cd host user | 2346 (setq result (ange-ftp-cd host user (nth 1 cmd) 'noerror))) |
2332 ;; Make sure the target to which | 2347 (setq cmd1 cmd3))) |
2333 ;; `cd' is performed is a directory. | |
2334 (file-name-directory (nth 1 cmd)) | |
2335 'noerror))) | |
2336 ;; Concatenate the switches and the target to be used with `ls'. | |
2337 (setq cmd1 (concat "\"" cmd3 " " cmd1 "\"")))) | |
2338 | 2348 |
2339 ;; First argument is the remote name | 2349 ;; First argument is the remote name |
2340 ((progn | 2350 ((progn |
2341 (setq fix-name-func (or (cdr (assq host-type | 2351 (setq fix-name-func (or (cdr (assq host-type |
2342 ange-ftp-fix-name-func-alist)) | 2352 ange-ftp-fix-name-func-alist)) |
2768 (match-string 2) | 2778 (match-string 2) |
2769 (match-string 3)))))) | 2779 (match-string 3)))))) |
2770 ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX) | 2780 ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX) |
2771 ;; and others don't. (sigh...) Beware, that some Unix's don't | 2781 ;; and others don't. (sigh...) Beware, that some Unix's don't |
2772 ;; seem to believe in the F-switch | 2782 ;; seem to believe in the F-switch |
2773 (if (or (and symlink (string-match "@$" file)) | 2783 (if (or (and symlink (string-match "@\\'" file)) |
2774 (and directory (string-match "/$" file)) | 2784 (and directory (string-match "/\\'" file)) |
2775 (and executable (string-match "*$" file)) | 2785 (and executable (string-match "*\\'" file)) |
2776 (and socket (string-match "=$" file))) | 2786 (and socket (string-match "=\\'" file))) |
2777 (setq file (substring file 0 -1))))) | 2787 (setq file (substring file 0 -1))))) |
2778 (puthash file (or symlink directory) tbl) | 2788 (puthash file (or symlink directory) tbl) |
2779 (forward-line 1)) | 2789 (forward-line 1)) |
2780 (puthash "." t tbl) | 2790 (puthash "." t tbl) |
2781 (puthash ".." t tbl) | 2791 (puthash ".." t tbl) |
3115 (user (nth 1 parsed)) | 3125 (user (nth 1 parsed)) |
3116 (name (nth 2 parsed))) | 3126 (name (nth 2 parsed))) |
3117 | 3127 |
3118 ;; See if remote name is absolute. If so then just expand it and | 3128 ;; See if remote name is absolute. If so then just expand it and |
3119 ;; replace the name component of the overall name. | 3129 ;; replace the name component of the overall name. |
3120 (cond ((string-match "^/" name) | 3130 (cond ((string-match "\\`/" name) |
3121 name) | 3131 name) |
3122 | 3132 |
3123 ;; Name starts with ~ or ~user. Resolve that part of the name | 3133 ;; Name starts with ~ or ~user. Resolve that part of the name |
3124 ;; making it absolute then re-expand it. | 3134 ;; making it absolute then re-expand it. |
3125 ((string-match "^~[^/]*" name) | 3135 ((string-match "\\`~[^/]*" name) |
3126 (let* ((tilda (match-string 0 name)) | 3136 (let* ((tilda (match-string 0 name)) |
3127 (rest (substring name (match-end 0))) | 3137 (rest (substring name (match-end 0))) |
3128 (dir (ange-ftp-expand-dir host user tilda))) | 3138 (dir (ange-ftp-expand-dir host user tilda))) |
3129 (if dir | 3139 (if dir |
3130 (setq name (cond ((string-equal rest "") | 3140 ;; C-x d /ftp:anonymous@ftp.gnu.org:~/ RET |
3131 dir) | 3141 ;; seems to cause `rest' to sometimes be empty. |
3132 ((string-equal dir "/") | 3142 ;; Maybe it's an error for `rest' to be empty here, |
3133 rest) | 3143 ;; but until we figure this out, this quick fix |
3134 (t | 3144 ;; seems to do the trick. |
3135 (concat dir rest)))) | 3145 (setq name (cond ((string-equal rest "") dir) |
3146 ((string-equal dir "/") rest) | |
3147 (t (concat dir rest)))) | |
3136 (error "User \"%s\" is not known" | 3148 (error "User \"%s\" is not known" |
3137 (substring tilda 1))))) | 3149 (substring tilda 1))))) |
3138 | 3150 |
3139 ;; relative name. Tack on homedir and re-expand. | 3151 ;; relative name. Tack on homedir and re-expand. |
3140 (t | 3152 (t |
3144 (ange-ftp-real-file-name-as-directory dir) | 3156 (ange-ftp-real-file-name-as-directory dir) |
3145 name)) | 3157 name)) |
3146 (error "Unable to obtain CWD"))))) | 3158 (error "Unable to obtain CWD"))))) |
3147 | 3159 |
3148 ;; If name starts with //, preserve that, for apollo system. | 3160 ;; If name starts with //, preserve that, for apollo system. |
3149 (if (not (string-match "^//" name)) | 3161 (unless (string-match "\\`//" name) |
3150 (progn | 3162 (if (not (eq system-type 'windows-nt)) |
3151 (if (not (eq system-type 'windows-nt)) | 3163 (setq name (ange-ftp-real-expand-file-name name)) |
3152 (setq name (ange-ftp-real-expand-file-name name)) | 3164 ;; Windows UNC default dirs do not make sense for ftp. |
3153 ;; Windows UNC default dirs do not make sense for ftp. | 3165 (setq name (if (string-match "\\`//" default-directory) |
3154 (if (string-match "^//" default-directory) | 3166 (ange-ftp-real-expand-file-name name "c:/") |
3155 (setq name (ange-ftp-real-expand-file-name name "c:/")) | 3167 (ange-ftp-real-expand-file-name name))) |
3156 (setq name (ange-ftp-real-expand-file-name name))) | 3168 ;; Strip off possible drive specifier. |
3157 ;; Strip off possible drive specifier. | 3169 (if (string-match "\\`[a-zA-Z]:" name) |
3158 (if (string-match "^[a-zA-Z]:" name) | 3170 (setq name (substring name 2)))) |
3159 (setq name (substring name 2)))) | 3171 (if (string-match "\\`//" name) |
3160 (if (string-match "^//" name) | 3172 (setq name (substring name 1)))) |
3161 (setq name (substring name 1))))) | |
3162 | 3173 |
3163 ;; Now substitute the expanded name back into the overall filename. | 3174 ;; Now substitute the expanded name back into the overall filename. |
3164 (ange-ftp-replace-name-component n name)) | 3175 (ange-ftp-replace-name-component n name)) |
3165 | 3176 |
3166 ;; non-ange-ftp name. Just expand normally. | 3177 ;; non-ange-ftp name. Just expand normally. |
3180 (ange-ftp-canonize-filename name)) | 3191 (ange-ftp-canonize-filename name)) |
3181 ((and (eq system-type 'windows-nt) | 3192 ((and (eq system-type 'windows-nt) |
3182 (eq (string-to-char name) ?\\)) | 3193 (eq (string-to-char name) ?\\)) |
3183 (ange-ftp-canonize-filename name)) | 3194 (ange-ftp-canonize-filename name)) |
3184 ((and (eq system-type 'windows-nt) | 3195 ((and (eq system-type 'windows-nt) |
3185 (or (string-match "^[a-zA-Z]:" name) | 3196 (or (string-match "\\`[a-zA-Z]:" name) |
3186 (string-match "^[a-zA-Z]:" default))) | 3197 (string-match "\\`[a-zA-Z]:" default))) |
3187 (ange-ftp-real-expand-file-name name default)) | 3198 (ange-ftp-real-expand-file-name name default)) |
3188 ((zerop (length name)) | 3199 ((zerop (length name)) |
3189 (ange-ftp-canonize-filename default)) | 3200 (ange-ftp-canonize-filename default)) |
3190 ((ange-ftp-canonize-filename | 3201 ((ange-ftp-canonize-filename |
3191 (concat (file-name-as-directory default) name)))))) | 3202 (concat (file-name-as-directory default) name)))))) |
3214 "Documented as original." | 3225 "Documented as original." |
3215 (let ((parsed (ange-ftp-ftp-name name))) | 3226 (let ((parsed (ange-ftp-ftp-name name))) |
3216 (if parsed | 3227 (if parsed |
3217 (let ((filename (nth 2 parsed))) | 3228 (let ((filename (nth 2 parsed))) |
3218 (if (save-match-data | 3229 (if (save-match-data |
3219 (string-match "^~[^/]*$" filename)) | 3230 (string-match "\\`~[^/]*\\'" filename)) |
3220 name | 3231 name |
3221 (ange-ftp-replace-name-component | 3232 (ange-ftp-replace-name-component |
3222 name | 3233 name |
3223 (ange-ftp-real-file-name-directory filename)))) | 3234 (ange-ftp-real-file-name-directory filename)))) |
3224 (ange-ftp-real-file-name-directory name)))) | 3235 (ange-ftp-real-file-name-directory name)))) |
3227 "Documented as original." | 3238 "Documented as original." |
3228 (let ((parsed (ange-ftp-ftp-name name))) | 3239 (let ((parsed (ange-ftp-ftp-name name))) |
3229 (if parsed | 3240 (if parsed |
3230 (let ((filename (nth 2 parsed))) | 3241 (let ((filename (nth 2 parsed))) |
3231 (if (save-match-data | 3242 (if (save-match-data |
3232 (string-match "^~[^/]*$" filename)) | 3243 (string-match "\\`~[^/]*\\'" filename)) |
3233 "" | 3244 "" |
3234 (ange-ftp-real-file-name-nondirectory filename))) | 3245 (ange-ftp-real-file-name-nondirectory filename))) |
3235 (ange-ftp-real-file-name-nondirectory name)))) | 3246 (ange-ftp-real-file-name-nondirectory name)))) |
3236 | 3247 |
3237 (defun ange-ftp-directory-file-name (dir) | 3248 (defun ange-ftp-directory-file-name (dir) |
3969 | 3980 |
3970 (defun ange-ftp-root-dir-p (dir) | 3981 (defun ange-ftp-root-dir-p (dir) |
3971 ;; Maybe we should use something more like | 3982 ;; Maybe we should use something more like |
3972 ;; (equal dir (file-name-directory (directory-file-name dir))) -stef | 3983 ;; (equal dir (file-name-directory (directory-file-name dir))) -stef |
3973 (or (and (eq system-type 'windows-nt) | 3984 (or (and (eq system-type 'windows-nt) |
3974 (string-match "^[a-zA-Z]:[/\\]$" dir)) | 3985 (string-match "\\`[a-zA-Z]:[/\\]\\'" dir)) |
3975 (string-equal "/" dir))) | 3986 (string-equal "/" dir))) |
3976 | 3987 |
3977 (defun ange-ftp-file-name-all-completions (file dir) | 3988 (defun ange-ftp-file-name-all-completions (file dir) |
3978 (let ((ange-ftp-this-dir (expand-file-name dir))) | 3989 (let ((ange-ftp-this-dir (expand-file-name dir))) |
3979 (if (ange-ftp-ftp-name ange-ftp-this-dir) | 3990 (if (ange-ftp-ftp-name ange-ftp-this-dir) |
4013 (setq ange-ftp-this-dir | 4024 (setq ange-ftp-this-dir |
4014 (ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) ;real? | 4025 (ange-ftp-real-file-name-as-directory ange-ftp-this-dir)) ;real? |
4015 (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir)) | 4026 (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir)) |
4016 (ange-ftp-completion-ignored-pattern | 4027 (ange-ftp-completion-ignored-pattern |
4017 (mapconcat (lambda (s) (if (stringp s) | 4028 (mapconcat (lambda (s) (if (stringp s) |
4018 (concat (regexp-quote s) "$") | 4029 (concat (regexp-quote s) "$") |
4019 "/")) ; / never in filename | 4030 "/")) ; / never in filename |
4020 completion-ignored-extensions | 4031 completion-ignored-extensions |
4021 "\\|"))) | 4032 "\\|"))) |
4022 (save-match-data | 4033 (save-match-data |
4023 (or (ange-ftp-file-name-completion-1 | 4034 (or (ange-ftp-file-name-completion-1 |
4024 file tbl ange-ftp-this-dir | 4035 file tbl ange-ftp-this-dir |
4937 ;; Convert NAME from UNIX-ish to VMS. If REVERSE given then convert from VMS | 4948 ;; Convert NAME from UNIX-ish to VMS. If REVERSE given then convert from VMS |
4938 ;; to UNIX-ish. | 4949 ;; to UNIX-ish. |
4939 (defun ange-ftp-fix-name-for-vms (name &optional reverse) | 4950 (defun ange-ftp-fix-name-for-vms (name &optional reverse) |
4940 (save-match-data | 4951 (save-match-data |
4941 (if reverse | 4952 (if reverse |
4942 (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name) | 4953 (if (string-match "\\`\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)\\'" name) |
4943 (let (drive dir file) | 4954 (let (drive dir file) |
4944 (setq drive (match-string 1 name)) | 4955 (setq drive (match-string 1 name)) |
4945 (setq dir (match-string 2 name)) | 4956 (setq dir (match-string 2 name)) |
4946 (setq file (match-string 3 name)) | 4957 (setq file (match-string 3 name)) |
4947 (and dir | 4958 (and dir |
4951 (concat "/" drive "/")) | 4962 (concat "/" drive "/")) |
4952 dir (and dir "/") | 4963 dir (and dir "/") |
4953 file)) | 4964 file)) |
4954 (error "name %s didn't match" name)) | 4965 (error "name %s didn't match" name)) |
4955 (let (drive dir file tmp) | 4966 (let (drive dir file tmp) |
4956 (if (string-match "^/[^:]+:/" name) | 4967 (if (string-match "\\`/[^:]+:/" name) |
4957 (setq drive (substring name 1 | 4968 (setq drive (substring name 1 |
4958 (1- (match-end 0))) | 4969 (1- (match-end 0))) |
4959 name (substring name (match-end 0)))) | 4970 name (substring name (match-end 0)))) |
4960 (setq tmp (file-name-directory name)) | 4971 (setq tmp (file-name-directory name)) |
4961 (if tmp | 4972 (if tmp |
4989 ;; Should there be entries for .. -> [-] and . -> [] below. Don't | 5000 ;; Should there be entries for .. -> [-] and . -> [] below. Don't |
4990 ;; think so, because expand-filename should have already short-circuited | 5001 ;; think so, because expand-filename should have already short-circuited |
4991 ;; them. | 5002 ;; them. |
4992 (cond ((string-equal dir-name "/") | 5003 (cond ((string-equal dir-name "/") |
4993 (error "Cannot get listing for fictitious \"/\" directory")) | 5004 (error "Cannot get listing for fictitious \"/\" directory")) |
4994 ((string-match "^/[-A-Z0-9_$]+:/$" dir-name) | 5005 ((string-match "\\`/[-A-Z0-9_$]+:/\\'" dir-name) |
4995 (error "Cannot get listing for device")) | 5006 (error "Cannot get listing for device")) |
4996 ((ange-ftp-fix-name-for-vms dir-name)))) | 5007 ((ange-ftp-fix-name-for-vms dir-name)))) |
4997 | 5008 |
4998 (or (assq 'vms ange-ftp-fix-dir-name-func-alist) | 5009 (or (assq 'vms ange-ftp-fix-dir-name-func-alist) |
4999 (setq ange-ftp-fix-dir-name-func-alist | 5010 (setq ange-ftp-fix-dir-name-func-alist |
5043 (while (setq file (ange-ftp-parse-vms-filename)) | 5054 (while (setq file (ange-ftp-parse-vms-filename)) |
5044 (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) | 5055 (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file) |
5045 ;; deal with directories | 5056 ;; deal with directories |
5046 (puthash (substring file 0 (match-beginning 0)) t tbl) | 5057 (puthash (substring file 0 (match-beginning 0)) t tbl) |
5047 (puthash file nil tbl) | 5058 (puthash file nil tbl) |
5048 (if (string-match ";[0-9]+$" file) ; deal with extension | 5059 (if (string-match ";[0-9]+\\'" file) ; deal with extension |
5049 ;; sans extension | 5060 ;; sans extension |
5050 (puthash (substring file 0 (match-beginning 0)) nil tbl))) | 5061 (puthash (substring file 0 (match-beginning 0)) nil tbl))) |
5051 (forward-line 1)) | 5062 (forward-line 1)) |
5052 ;; Would like to look for a "Total" line, or a "Directory" line to | 5063 ;; Would like to look for a "Total" line, or a "Directory" line to |
5053 ;; make sure that the listing isn't complete garbage before putting | 5064 ;; make sure that the listing isn't complete garbage before putting |
5069 (defun ange-ftp-vms-delete-file-entry (name &optional dir-p) | 5080 (defun ange-ftp-vms-delete-file-entry (name &optional dir-p) |
5070 (if dir-p | 5081 (if dir-p |
5071 (ange-ftp-internal-delete-file-entry name t) | 5082 (ange-ftp-internal-delete-file-entry name t) |
5072 (save-match-data | 5083 (save-match-data |
5073 (let ((file (ange-ftp-get-file-part name))) | 5084 (let ((file (ange-ftp-get-file-part name))) |
5074 (if (string-match ";[0-9]+$" file) | 5085 (if (string-match ";[0-9]+\\'" file) |
5075 ;; In VMS you can't delete a file without an explicit | 5086 ;; In VMS you can't delete a file without an explicit |
5076 ;; version number, or wild-card (e.g. FOO;*) | 5087 ;; version number, or wild-card (e.g. FOO;*) |
5077 ;; For now, we give up on wildcards. | 5088 ;; For now, we give up on wildcards. |
5078 (let ((files (gethash (file-name-directory name) | 5089 (let ((files (gethash (file-name-directory name) |
5079 ange-ftp-files-hashtable))) | 5090 ange-ftp-files-hashtable))) |
5107 (let ((files (gethash (file-name-directory name) | 5118 (let ((files (gethash (file-name-directory name) |
5108 ange-ftp-files-hashtable))) | 5119 ange-ftp-files-hashtable))) |
5109 (if files | 5120 (if files |
5110 (let ((file (ange-ftp-get-file-part name))) | 5121 (let ((file (ange-ftp-get-file-part name))) |
5111 (save-match-data | 5122 (save-match-data |
5112 (if (string-match ";[0-9]+$" file) | 5123 (if (string-match ";[0-9]+\\'" file) |
5113 (puthash (substring file 0 (match-beginning 0)) nil files) | 5124 (puthash (substring file 0 (match-beginning 0)) nil files) |
5114 ;; Need to figure out what version of the file | 5125 ;; Need to figure out what version of the file |
5115 ;; is being added. | 5126 ;; is being added. |
5116 (let ((regexp (concat "^" | 5127 (let ((regexp (concat "^" |
5117 (regexp-quote file) | 5128 (regexp-quote file) |
5150 ange-ftp-host-cache nil))) | 5161 ange-ftp-host-cache nil))) |
5151 | 5162 |
5152 | 5163 |
5153 (defun ange-ftp-vms-file-name-as-directory (name) | 5164 (defun ange-ftp-vms-file-name-as-directory (name) |
5154 (save-match-data | 5165 (save-match-data |
5155 (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name) | 5166 (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?\\'" name) |
5156 (setq name (substring name 0 (match-beginning 0)))) | 5167 (setq name (substring name 0 (match-beginning 0)))) |
5157 (ange-ftp-real-file-name-as-directory name))) | 5168 (ange-ftp-real-file-name-as-directory name))) |
5158 | 5169 |
5159 (or (assq 'vms ange-ftp-file-name-as-directory-alist) | 5170 (or (assq 'vms ange-ftp-file-name-as-directory-alist) |
5160 (setq ange-ftp-file-name-as-directory-alist | 5171 (setq ange-ftp-file-name-as-directory-alist |
5271 ;; compressed files. Instead, we turn "FILE.TYPE" into | 5282 ;; compressed files. Instead, we turn "FILE.TYPE" into |
5272 ;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do. | 5283 ;; "FILE.TYPE-Z". Hope that this is a reasonable thing to do. |
5273 | 5284 |
5274 (defun ange-ftp-vms-make-compressed-filename (name &optional reverse) | 5285 (defun ange-ftp-vms-make-compressed-filename (name &optional reverse) |
5275 (cond | 5286 (cond |
5276 ((string-match "-Z;[0-9]+$" name) | 5287 ((string-match "-Z;[0-9]+\\'" name) |
5277 (list nil (substring name 0 (match-beginning 0)))) | 5288 (list nil (substring name 0 (match-beginning 0)))) |
5278 ((string-match ";[0-9]+$" name) | 5289 ((string-match ";[0-9]+\\'" name) |
5279 (list nil (substring name 0 (match-beginning 0)))) | 5290 (list nil (substring name 0 (match-beginning 0)))) |
5280 ((string-match "-Z$" name) | 5291 ((string-match "-Z\\'" name) |
5281 (list nil (substring name 0 -2))) | 5292 (list nil (substring name 0 -2))) |
5282 (t | 5293 (t |
5283 (list t | 5294 (list t |
5284 (if (string-match ";[0-9]+$" name) | 5295 (if (string-match ";[0-9]+\\'" name) |
5285 (concat (substring name 0 (match-beginning 0)) | 5296 (concat (substring name 0 (match-beginning 0)) |
5286 "-Z") | 5297 "-Z") |
5287 (concat name "-Z")))))) | 5298 (concat name "-Z")))))) |
5288 | 5299 |
5289 (or (assq 'vms ange-ftp-make-compressed-filename-alist) | 5300 (or (assq 'vms ange-ftp-make-compressed-filename-alist) |
5312 ;; (cons '(vms . ange-ftp-dired-vms-ls-trim) | 5323 ;; (cons '(vms . ange-ftp-dired-vms-ls-trim) |
5313 ;; ange-ftp-dired-ls-trim-alist))) | 5324 ;; ange-ftp-dired-ls-trim-alist))) |
5314 | 5325 |
5315 (defun ange-ftp-vms-sans-version (name &rest args) | 5326 (defun ange-ftp-vms-sans-version (name &rest args) |
5316 (save-match-data | 5327 (save-match-data |
5317 (if (string-match ";[0-9]+$" name) | 5328 (if (string-match ";[0-9]+\\'" name) |
5318 (substring name 0 (match-beginning 0)) | 5329 (substring name 0 (match-beginning 0)) |
5319 name))) | 5330 name))) |
5320 | 5331 |
5321 (or (assq 'vms ange-ftp-sans-version-alist) | 5332 (or (assq 'vms ange-ftp-sans-version-alist) |
5322 (setq ange-ftp-sans-version-alist | 5333 (setq ange-ftp-sans-version-alist |
5468 ;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from | 5479 ;; Convert NAME from UNIX-ish to MTS. If REVERSE given then convert from |
5469 ;; MTS to UNIX-ish. | 5480 ;; MTS to UNIX-ish. |
5470 (defun ange-ftp-fix-name-for-mts (name &optional reverse) | 5481 (defun ange-ftp-fix-name-for-mts (name &optional reverse) |
5471 (save-match-data | 5482 (save-match-data |
5472 (if reverse | 5483 (if reverse |
5473 (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name) | 5484 (if (string-match "\\`\\([^:]+:\\)?\\(.*\\)\\'" name) |
5474 (let (acct file) | 5485 (let (acct file) |
5475 (setq acct (match-string 1 name)) | 5486 (setq acct (match-string 1 name)) |
5476 (setq file (match-string 2 name)) | 5487 (setq file (match-string 2 name)) |
5477 (concat (and acct (concat "/" acct "/")) | 5488 (concat (and acct (concat "/" acct "/")) |
5478 file)) | 5489 file)) |
5479 (error "name %s didn't match" name)) | 5490 (error "name %s didn't match" name)) |
5480 (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name) | 5491 (if (string-match "\\`/\\([^:]+:\\)/\\(.*\\)\\'" name) |
5481 (concat (match-string 1 name) (match-string 2 name)) | 5492 (concat (match-string 1 name) (match-string 2 name)) |
5482 ;; Let's hope that mts will recognize it anyway. | 5493 ;; Let's hope that mts will recognize it anyway. |
5483 name)))) | 5494 name)))) |
5484 | 5495 |
5485 (or (assq 'mts ange-ftp-fix-name-func-alist) | 5496 (or (assq 'mts ange-ftp-fix-name-func-alist) |
5494 (error "Cannot get listing for fictitious \"/\" directory") | 5505 (error "Cannot get listing for fictitious \"/\" directory") |
5495 (let ((dir-name (ange-ftp-fix-name-for-mts dir-name))) | 5506 (let ((dir-name (ange-ftp-fix-name-for-mts dir-name))) |
5496 (cond | 5507 (cond |
5497 ((string-equal dir-name "") | 5508 ((string-equal dir-name "") |
5498 "?") | 5509 "?") |
5499 ((string-match ":$" dir-name) | 5510 ((string-match ":\\'" dir-name) |
5500 (concat dir-name "?")) | 5511 (concat dir-name "?")) |
5501 (dir-name))))) ; It's just a single file. | 5512 (dir-name))))) ; It's just a single file. |
5502 | 5513 |
5503 (or (assq 'mts ange-ftp-fix-dir-name-func-alist) | 5514 (or (assq 'mts ange-ftp-fix-dir-name-func-alist) |
5504 (setq ange-ftp-fix-dir-name-func-alist | 5515 (setq ange-ftp-fix-dir-name-func-alist |
5631 ;; we'll assume that it's a minidisk, and make it into a | 5642 ;; we'll assume that it's a minidisk, and make it into a |
5632 ;; directory file name. Note that the expand-dir-hashtable | 5643 ;; directory file name. Note that the expand-dir-hashtable |
5633 ;; stores directories without the trailing /. Is this | 5644 ;; stores directories without the trailing /. Is this |
5634 ;; consistent? | 5645 ;; consistent? |
5635 (concat "/" name) | 5646 (concat "/" name) |
5636 (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" | 5647 (if (string-match "\\`/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?\\'" |
5637 name) | 5648 name) |
5638 (let ((minidisk (match-string 1 name))) | 5649 (let ((minidisk (match-string 1 name))) |
5639 (if (match-beginning 2) | 5650 (if (match-beginning 2) |
5640 (let ((file (match-string 2 name)) | 5651 (let ((file (match-string 2 name)) |
5641 (cmd (concat "cd " minidisk)) | 5652 (cmd (concat "cd " minidisk)) |
5676 ;; Convert name from UNIX-ish to CMS ready for a DIRectory listing. | 5687 ;; Convert name from UNIX-ish to CMS ready for a DIRectory listing. |
5677 (defun ange-ftp-fix-dir-name-for-cms (dir-name) | 5688 (defun ange-ftp-fix-dir-name-for-cms (dir-name) |
5678 (cond | 5689 (cond |
5679 ((string-equal "/" dir-name) | 5690 ((string-equal "/" dir-name) |
5680 (error "Cannot get listing for fictitious \"/\" directory")) | 5691 (error "Cannot get listing for fictitious \"/\" directory")) |
5681 ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name) | 5692 ((string-match "\\`/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?\\'" dir-name) |
5682 (let* ((minidisk (match-string 1 dir-name)) | 5693 (let* ((minidisk (match-string 1 dir-name)) |
5683 ;; host and user are bound in the call to ange-ftp-send-cmd | 5694 ;; host and user are bound in the call to ange-ftp-send-cmd |
5684 (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user)) | 5695 (proc (ange-ftp-get-process ange-ftp-this-host ange-ftp-this-user)) |
5685 (cmd (concat "cd " minidisk)) | 5696 (cmd (concat "cd " minidisk)) |
5686 (file (if (match-beginning 2) | 5697 (file (if (match-beginning 2) |
5834 ;; (setq ange-ftp-dired-move-to-end-of-filename-alist | 5845 ;; (setq ange-ftp-dired-move-to-end-of-filename-alist |
5835 ;; (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename) | 5846 ;; (cons '(cms . ange-ftp-dired-cms-move-to-end-of-filename) |
5836 ;; ange-ftp-dired-move-to-end-of-filename-alist))) | 5847 ;; ange-ftp-dired-move-to-end-of-filename-alist))) |
5837 | 5848 |
5838 (defun ange-ftp-cms-make-compressed-filename (name &optional reverse) | 5849 (defun ange-ftp-cms-make-compressed-filename (name &optional reverse) |
5839 (if (string-match "-Z$" name) | 5850 (if (string-match "-Z\\'" name) |
5840 (list nil (substring name 0 -2)) | 5851 (list nil (substring name 0 -2)) |
5841 (list t (concat name "-Z")))) | 5852 (list t (concat name "-Z")))) |
5842 | 5853 |
5843 (or (assq 'cms ange-ftp-make-compressed-filename-alist) | 5854 (or (assq 'cms ange-ftp-make-compressed-filename-alist) |
5844 (setq ange-ftp-make-compressed-filename-alist | 5855 (setq ange-ftp-make-compressed-filename-alist |
6085 ;;;; Finally provide package. | 6096 ;;;; Finally provide package. |
6086 ;;;; ------------------------------------------------------------ | 6097 ;;;; ------------------------------------------------------------ |
6087 | 6098 |
6088 (provide 'ange-ftp) | 6099 (provide 'ange-ftp) |
6089 | 6100 |
6090 ;;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316 | 6101 ;; arch-tag: 2987ef88-cb56-4ec1-87a9-79132572e316 |
6091 ;;; ange-ftp.el ends here | 6102 ;;; ange-ftp.el ends here |