/[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.44 by rms, Tue Aug 27 21:21:17 2002 UTC revision 1.45 by monnier, Thu Aug 29 21:48:50 2002 UTC
# Line 1416  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 1504  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 1538  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 1691  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 1773  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 1890  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 1942  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 2092  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 2112  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 2163  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 2699  The main reason for this alist is to dea Line 2693  The main reason for this alist is to dea
2693  ;; unquoting names obtained with the SysV b switch and the GNU Q  ;; unquoting names obtained with the SysV b switch and the GNU Q
2694  ;; switch. See Sebastian's dired-get-filename.  ;; switch. See Sebastian's dired-get-filename.
2695    
2696  (defun ange-ftp-ls-parser ()  (defun ange-ftp-ls-parser (switches)
   ;; Note that switches is dynamically bound.  
2697    ;; Meant to be called by ange-ftp-parse-dired-listing    ;; Meant to be called by ange-ftp-parse-dired-listing
2698    (let ((tbl (make-hash-table :test 'equal))    (let ((tbl (make-hash-table :test 'equal))
2699          (used-F (and (stringp switches)          (used-F (and (stringp switches)
# Line 2731  The main reason for this alist is to dea Line 2724  The main reason for this alist is to dea
2724                   (and (not symlink) ; x bits don't mean a thing for symlinks                   (and (not symlink) ; x bits don't mean a thing for symlinks
2725                        (string-match                        (string-match
2726                         "[xst]"                         "[xst]"
2727                         (concat (buffer-substring                         (concat (match-string 1)
2728                                  (match-beginning 1) (match-end 1))                                 (match-string 2)
2729                                 (buffer-substring                                 (match-string 3))))))
                                 (match-beginning 2) (match-end 2))  
                                (buffer-substring  
                                 (match-beginning 3) (match-end 3)))))))  
2730              ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)              ;; Some ls's with the F switch mark symlinks with an @ (ULTRIX)
2731              ;; and others don't. (sigh...) Beware, that some Unix's don't              ;; and others don't. (sigh...) Beware, that some Unix's don't
2732              ;; seem to believe in the F-switch              ;; seem to believe in the F-switch
# Line 2800  match subdirectories as well.") Line 2790  match subdirectories as well.")
2790        (forward-line 1)        (forward-line 1)
2791        ;; Some systems put in a blank line here.        ;; Some systems put in a blank line here.
2792        (if (eolp) (forward-line 1))        (if (eolp) (forward-line 1))
2793        (ange-ftp-ls-parser))        (ange-ftp-ls-parser switches))
2794       ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")       ((looking-at "[^\n]+\\( not found\\|: Not a directory\\)\n\\'")
2795        ;; It's an ls error message.        ;; It's an ls error message.
2796        nil)        nil)
# Line 2814  match subdirectories as well.") Line 2804  match subdirectories as well.")
2804        nil)        nil)
2805       ((re-search-forward ange-ftp-date-regexp nil t)       ((re-search-forward ange-ftp-date-regexp nil t)
2806        (beginning-of-line)        (beginning-of-line)
2807        (ange-ftp-ls-parser))        (ange-ftp-ls-parser switches))
2808       ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)       ((re-search-forward "^[^ \n\t]+ +\\([0-9]+\\|-\\|=\\) " nil t)
2809        ;; It's a dl listing (I hope).        ;; It's a dl listing (I hope).
2810        ;; file is bound by the call to ange-ftp-ls        ;; file is bound by the call to ange-ftp-ls
# Line 2871  NO-ERROR, if a listing for DIRECTORY can Line 2861  NO-ERROR, if a listing for DIRECTORY can
2861  (defmacro ange-ftp-get-file-part (name)  (defmacro ange-ftp-get-file-part (name)
2862    `(let ((file (file-name-nondirectory ,name)))    `(let ((file (file-name-nondirectory ,name)))
2863       (if (string-equal file "")       (if (string-equal file "")
2864          "."           "."
2865         file)))         file)))
2866    
2867  ;; 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 2882  NO-ERROR, if a listing for DIRECTORY can Line 2872  NO-ERROR, if a listing for DIRECTORY can
2872  ;; 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
2873  ;;     subdirectory. This is of course an OS dependent judgement.  ;;     subdirectory. This is of course an OS dependent judgement.
2874    
2875    (defvar dired-local-variables-file)
2876  (defmacro ange-ftp-allow-child-lookup (dir file)  (defmacro ange-ftp-allow-child-lookup (dir file)
2877    `(not    `(not
2878      (let* ((efile ,file)                ; expand once.      (let* ((efile ,file)                ; expand once.
# Line 3024  and LINE is the relevant success or fail Line 3015  and LINE is the relevant success or fail
3015      (if (car result)      (if (car result)
3016          (save-match-data          (save-match-data
3017            (and (or (string-match "\"\\([^\"]*\\)\"" line)            (and (or (string-match "\"\\([^\"]*\\)\"" line)
3018                     (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!                     (string-match " \\([^ ]+\\) " line)) ; stone-age VMS servers!
3019                 (setq dir (substring line                 (setq dir (match-string 1 line)))))
                                     (match-beginning 1)  
                                     (match-end 1))))))  
3020      (cons dir line)))      (cons dir line)))
3021    
3022  ;;; ------------------------------------------------------------  ;;; ------------------------------------------------------------
# Line 3061  logged in as user USER and cd'd to direc Line 3050  logged in as user USER and cd'd to direc
3050                    (line (cdr result)))                    (line (cdr result)))
3051               (setq res               (setq res
3052                     (if (string-match ange-ftp-expand-dir-regexp line)                     (if (string-match ange-ftp-expand-dir-regexp line)
3053                         (substring line                         (match-string 1 line)))))
                                   (match-beginning 1)  
                                   (match-end 1))))))  
3054            (or res            (or res
3055                (if (string-equal dir "~")                (if (string-equal dir "~")
3056                    (setq res (car (ange-ftp-get-pwd host user)))                    (setq res (car (ange-ftp-get-pwd host user)))
# Line 3098  logged in as user USER and cd'd to direc Line 3085  logged in as user USER and cd'd to direc
3085                  ;; Name starts with ~ or ~user.  Resolve that part of the name                  ;; Name starts with ~ or ~user.  Resolve that part of the name
3086                  ;; making it absolute then re-expand it.                  ;; making it absolute then re-expand it.
3087                  ((string-match "^~[^/]*" name)                  ((string-match "^~[^/]*" name)
3088                   (let* ((tilda (substring name                   (let* ((tilda (match-string 0 name))
                                           (match-beginning 0)  
                                           (match-end 0)))  
3089                          (rest (substring name (match-end 0)))                          (rest (substring name (match-end 0)))
3090                          (dir (ange-ftp-expand-dir host user tilda)))                          (dir (ange-ftp-expand-dir host user tilda)))
3091                     (if dir                     (if dir
# Line 3212  system TYPE.") Line 3197  system TYPE.")
3197    (let ((parsed (ange-ftp-ftp-name dir)))    (let ((parsed (ange-ftp-ftp-name dir)))
3198      (if parsed      (if parsed
3199          (ange-ftp-replace-name-component          (ange-ftp-replace-name-component
3200             dir           dir
3201             (ange-ftp-real-directory-file-name (nth 2 parsed)))           (ange-ftp-real-directory-file-name (nth 2 parsed)))
3202        (ange-ftp-real-directory-file-name dir))))        (ange-ftp-real-directory-file-name dir))))
3203    
3204    
# Line 3595  Value is (0 0) if the modification time Line 3580  Value is (0 0) if the modification time
3580  ;;                           filename  ;;                           filename
3581  ;;                           newname))  ;;                           newname))
3582  ;;      res)  ;;      res)
3583  ;;     (set-process-sentinel proc (function ange-ftp-copy-file-locally-sentinel))  ;;     (set-process-sentinel proc 'ange-ftp-copy-file-locally-sentinel)
3584  ;;     (process-kill-without-query proc)  ;;     (process-kill-without-query proc)
3585  ;;     (with-current-buffer (process-buffer proc)  ;;     (with-current-buffer (process-buffer proc)
3586  ;;       (set (make-local-variable 'copy-cont) cont))))  ;;       (set (make-local-variable 'copy-cont) cont))))
# Line 3683  Value is (0 0) if the modification time Line 3668  Value is (0 0) if the modification time
3668                     (if (and temp1 t-parsed)                     (if (and temp1 t-parsed)
3669                         (format "Getting %s" f-abbr)                         (format "Getting %s" f-abbr)
3670                       (format "Copying %s to %s" f-abbr t-abbr)))                       (format "Copying %s to %s" f-abbr t-abbr)))
3671                 (list (function ange-ftp-cf1)                 (list 'ange-ftp-cf1
3672                       filename newname binary msg                       filename newname binary msg
3673                       f-parsed f-host f-user f-name f-abbr                       f-parsed f-host f-user f-name f-abbr
3674                       t-parsed t-host t-user t-name t-abbr                       t-parsed t-host t-user t-name t-abbr
# Line 3761  Value is (0 0) if the modification time Line 3746  Value is (0 0) if the modification time
3746                   (if (and temp2 f-parsed)                   (if (and temp2 f-parsed)
3747                       (format "Putting %s" newname)                       (format "Putting %s" newname)
3748                     (format "Copying %s to %s" f-abbr t-abbr)))                     (format "Copying %s to %s" f-abbr t-abbr)))
3749               (list (function ange-ftp-cf2)               (list 'ange-ftp-cf2
3750                     newname t-host t-user binary temp1 temp2 cont)                     newname t-host t-user binary temp1 temp2 cont)
3751               nowait))               nowait))
3752    
# Line 3916  E.g., Line 3901  E.g.,
3901  ;;;; File name completion support.  ;;;; File name completion support.
3902  ;;;; ------------------------------------------------------------  ;;;; ------------------------------------------------------------
3903    
 ;; 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 (key val)  
   (or (not (stringp val))  
       (file-exists-p (ange-ftp-expand-symlink val ange-ftp-this-dir))))  
   
3904  ;; 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)
3905  ;; 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
3906  ;; by completion-ignored-extensions.  ;; by completion-ignored-extensions.
# Line 3952  E.g., Line 3931  E.g.,
3931            (setq ange-ftp-this-dir            (setq ange-ftp-this-dir
3932                  (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))                  (ange-ftp-real-file-name-as-directory ange-ftp-this-dir))
3933            (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))            (let* ((tbl (ange-ftp-get-files ange-ftp-this-dir))
3934                   (completions                   (completions (all-completions file tbl)))
                   (all-completions file tbl  
                                    (function ange-ftp-file-entry-active-p))))  
3935    
3936              ;; see whether each matching file is a directory or not...              ;; see whether each matching file is a directory or not...
3937              (mapcar              (mapcar
# Line 3994  E.g., Line 3971  E.g.,
3971                (save-match-data                (save-match-data
3972                  (or (ange-ftp-file-name-completion-1                  (or (ange-ftp-file-name-completion-1
3973                       file tbl ange-ftp-this-dir                       file tbl ange-ftp-this-dir
3974                       (function ange-ftp-file-entry-not-ignored-p))                       'ange-ftp-file-entry-not-ignored-p)
3975                      (ange-ftp-file-name-completion-1                      (ange-ftp-file-name-completion-1
3976                       file tbl ange-ftp-this-dir                       file tbl ange-ftp-this-dir))))))
                      (function ange-ftp-file-entry-active-p)))))))  
3977    
3978        (if (ange-ftp-root-dir-p ange-ftp-this-dir)        (if (ange-ftp-root-dir-p ange-ftp-this-dir)
3979            (try-completion            (try-completion
# Line 4008  E.g., Line 3984  E.g.,
3984          (ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))          (ange-ftp-real-file-name-completion file ange-ftp-this-dir)))))
3985    
3986    
3987  (defun ange-ftp-file-name-completion-1 (file tbl dir predicate)  (defun ange-ftp-file-name-completion-1 (file tbl dir &optional predicate)
3988    (let ((bestmatch (try-completion file tbl predicate)))    (let ((bestmatch (try-completion file tbl predicate)))
3989      (if bestmatch      (if bestmatch
3990          (if (eq bestmatch t)          (if (eq bestmatch t)
# Line 4101  directory, so that Emacs will know its c Line 4077  directory, so that Emacs will know its c
4077                                 (nth 2 parsed))                                 (nth 2 parsed))
4078                              (ange-ftp-real-file-name-as-directory                              (ange-ftp-real-file-name-as-directory
4079                               (nth 2 parsed)))))                               (nth 2 parsed)))))
4080                    (abbr (ange-ftp-abbreviate-filename dir))                     (abbr (ange-ftp-abbreviate-filename dir))
4081                    (result (ange-ftp-send-cmd host user                     (result (ange-ftp-send-cmd host user
4082                                               (list 'rmdir name)                                                (list 'rmdir name)
4083                                               (format "Removing directory %s"                                                (format "Removing directory %s"
4084                                                       abbr))))                                                        abbr))))
4085                (or (car result)                (or (car result)
4086                    (ange-ftp-error host user                    (ange-ftp-error host user
4087                                    (format "Could not remove directory %s: %s"                                    (format "Could not remove directory %s: %s"
# Line 4514  NEWNAME should be the name to give the n Line 4490  NEWNAME should be the name to give the n
4490                  ;; ((equal dired-chown-program program))                  ;; ((equal dired-chown-program program))
4491                  (t (error "Unknown remote command: %s" program)))                  (t (error "Unknown remote command: %s" program)))
4492          (ftp-error (insert (format "%s: %s, %s\n"          (ftp-error (insert (format "%s: %s, %s\n"
4493                                      (nth 1 oops)                                     (nth 1 oops)
4494                                      (nth 2 oops)                                     (nth 2 oops)
4495                                      (nth 3 oops)))                                     (nth 3 oops)))
4496                     ;; Caller expects nonzero value to mean failure.                     ;; Caller expects nonzero value to mean failure.
4497                     1)                     1)
4498          (error (insert (format "%s\n" (nth 1 oops)))          (error (insert (format "%s\n" (nth 1 oops)))
# Line 4667  NEWNAME should be the name to give the n Line 4643  NEWNAME should be the name to give the n
4643  ;;                             (t nil))))  ;;                             (t nil))))
4644  ;;                (condition-case err  ;;                (condition-case err
4645  ;;                    (funcall file-creator from to overwrite-confirmed  ;;                    (funcall file-creator from to overwrite-confirmed
4646  ;;                             (list (function ange-ftp-dcf-2)  ;;                             (list 'ange-ftp-dcf-2
4647  ;;                                   nil        ;err  ;;                                   nil        ;err
4648  ;;                                   file-creator operation fn-list  ;;                                   file-creator operation fn-list
4649  ;;                                   name-constructor  ;;                                   name-constructor
# Line 4913  NEWNAME should be the name to give the n Line 4889  NEWNAME should be the name to give the n
4889      (if reverse      (if reverse
4890          (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)          (if (string-match "^\\([^:]+:\\)?\\(\\[.*\\]\\)?\\([^][]*\\)$" name)
4891              (let (drive dir file)              (let (drive dir file)
4892                (if (match-beginning 1)                (setq drive (match-string 1 name))
4893                    (setq drive (substring name                (setq dir (match-string 2 name))
4894                                           (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))))  
4895                (and dir                (and dir
4896                     (setq dir (subst-char-in-string                     (setq dir (subst-char-in-string
4897                                ?/ ?. (substring dir 1 -1) t)))                                ?/ ?. (substring dir 1 -1) t)))
# Line 5008  Other orders of $ and _ seem to all work Line 4977  Other orders of $ and _ seem to all work
4977  ;; Extract the next filename from a VMS dired-like listing.  ;; Extract the next filename from a VMS dired-like listing.
4978  (defun ange-ftp-parse-vms-filename ()  (defun ange-ftp-parse-vms-filename ()
4979    (if (re-search-forward    (if (re-search-forward
4980           ange-ftp-vms-filename-regexp         ange-ftp-vms-filename-regexp
4981           nil t)         nil t)
4982          (buffer-substring (match-beginning 0) (match-end 0))))        (match-string 0)))
4983    
4984  ;; 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
4985  ;; format, and return a hashtable as the result.  ;; format, and return a hashtable as the result.
# Line 5036  Other orders of $ and _ seem to all work Line 5005  Other orders of $ and _ seem to all work
5005        (puthash ".." t tbl))        (puthash ".." t tbl))
5006      tbl))      tbl))
5007    
5008  (or (assq 'vms ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
5009      (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)))  
5010    
5011  ;; This version only deletes file entries which have  ;; This version only deletes file entries which have
5012  ;; explicit version numbers, because that is all VMS allows.  ;; explicit version numbers, because that is all VMS allows.
# Line 5103  Other orders of $ and _ seem to all work Line 5070  Other orders of $ and _ seem to all work
5070                       (and (string-match regexp name)                       (and (string-match regexp name)
5071                            (setq version                            (setq version
5072                                  (max version                                  (max version
5073                                       (string-to-int                                       (string-to-int (match-string 1 name))))))
                                       (substring name  
                                                  (match-beginning 1)  
                                                  (match-end 1)))))))  
5074                     files)                     files)
5075                    (setq version (1+ version))                    (setq version (1+ version))
5076                    (puthash                    (puthash
# Line 5337  Other orders of $ and _ seem to all work Line 5301  Other orders of $ and _ seem to all work
5301  ;;    ;; If the file has numeric backup versions,  ;;    ;; If the file has numeric backup versions,
5302  ;;    ;; put on ange-ftp-file-version-alist an element of the form  ;;    ;; put on ange-ftp-file-version-alist an element of the form
5303  ;;    ;; (FILENAME . VERSION-NUMBER-LIST)  ;;    ;; (FILENAME . VERSION-NUMBER-LIST)
5304  ;;    (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))  
5305  ;;    ;; Sort each VERSION-NUMBER-LIST,  ;;    ;; Sort each VERSION-NUMBER-LIST,
5306  ;;    ;; and remove the versions not to be deleted.  ;;    ;; and remove the versions not to be deleted.
5307  ;;    (let ((fval ange-ftp-file-version-alist))  ;;    (let ((fval ange-ftp-file-version-alist))
# Line 5355  Other orders of $ and _ seem to all work Line 5318  Other orders of $ and _ seem to all work
5318  ;;    ;; Look at each file.  If it is a numeric backup file,  ;;    ;; Look at each file.  If it is a numeric backup file,
5319  ;;    ;; 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.
5320  ;;    (dired-map-dired-file-lines  ;;    (dired-map-dired-file-lines
5321  ;;     (function  ;;     'ange-ftp-dired-vms-trample-file-versions mark)
 ;;      ange-ftp-dired-vms-trample-file-versions mark))  
5322  ;;    (message (concat action " numerical backups...done"))))  ;;    (message (concat action " numerical backups...done"))))
5323    
5324  ;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)  ;;(or (assq 'vms ange-ftp-dired-clean-directory-alist)
# Line 5458  Other orders of $ and _ seem to all work Line 5420  Other orders of $ and _ seem to all work
5420      (if reverse      (if reverse
5421          (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)          (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" name)
5422              (let (acct file)              (let (acct file)
5423                (if (match-beginning 1)                (setq acct (match-string 1 name))
5424                    (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))))  
5425                (concat (and acct (concat "/" acct "/"))                (concat (and acct (concat "/" acct "/"))
5426                        file))                        file))
5427            (error "name %s didn't match" name))            (error "name %s didn't match" name))
5428        (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)        (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" name)
5429            (concat (substring name 1 (match-end 1))            (concat (match-string 1 name) (match-string 2 name))
                   (substring name (match-beginning 2) (match-end 2)))  
5430          ;; Let's hope that mts will recognize it anyway.          ;; Let's hope that mts will recognize it anyway.
5431          name))))          name))))
5432    
# Line 5523  Other orders of $ and _ seem to all work Line 5481  Other orders of $ and _ seem to all work
5481      (puthash "." t tbl)      (puthash "." t tbl)
5482      tbl))      tbl))
5483    
5484  (or (assq 'mts ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
5485      (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)))  
5486    
5487  (defun ange-ftp-add-mts-host (host)  (defun ange-ftp-add-mts-host (host)
5488    "Mark HOST as the name of a machine running MTS."    "Mark HOST as the name of a machine running MTS."
# Line 5627  Other orders of $ and _ seem to all work Line 5583  Other orders of $ and _ seem to all work
5583          (concat "/" name)          (concat "/" name)
5584        (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"        (if (string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$"
5585                          name)                          name)
5586            (let ((minidisk (substring name 1 (match-end 1))))            (let ((minidisk (match-string 1 name)))
5587              (if (match-beginning 2)              (if (match-beginning 2)
5588                  (let ((file (substring name (match-beginning 2)                  (let ((file (match-string 2 name))
                                        (match-end 2)))  
5589                        (cmd (concat "cd " minidisk))                        (cmd (concat "cd " minidisk))
5590    
5591                        ;; Note that host and user are bound in the call                        ;; Note that host and user are bound in the call
# Line 5672  Other orders of $ and _ seem to all work Line 5627  Other orders of $ and _ seem to all work
5627     ((string-equal "/" dir-name)     ((string-equal "/" dir-name)
5628      (error "Cannot get listing for fictitious \"/\" directory"))      (error "Cannot get listing for fictitious \"/\" directory"))
5629     ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)     ((string-match "^/\\([-A-Z0-9$*._]+\\)/\\([-A-Z0-9$._]+\\)?$" dir-name)
5630      (let* ((minidisk (substring dir-name (match-beginning 1) (match-end 1)))      (let* ((minidisk (match-string 1 dir-name))
5631             ;; 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
5632             (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))
5633             (cmd (concat "cd " minidisk))             (cmd (concat "cd " minidisk))
5634             (file (if (match-beginning 2)             (file (if (match-beginning 2)
5635                       ;; it's a single file                       ;; it's a single file
5636                       (substring dir-name (match-beginning 2)                       (match-string 2 dir-name)
                                 (match-end 2))  
5637                     ;; use the wild-card                     ;; use the wild-card
5638                     "*")))                     "*")))
5639        (if (car (ange-ftp-raw-send-cmd proc cmd))        (if (car (ange-ftp-raw-send-cmd proc cmd))
# Line 5748  Other orders of $ and _ seem to all work Line 5702  Other orders of $ and _ seem to all work
5702        (while        (while
5703            (re-search-forward            (re-search-forward
5704             "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)             "^\\([-A-Z0-9$_]+\\) +\\([-A-Z0-9$_]+\\) +[VF] +[0-9]+ " nil t)
5705          (puthash          (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)  
5706          (forward-line 1))          (forward-line 1))
5707        (puthash "." t tbl))        (puthash "." t tbl))
5708      tbl))      tbl))
5709    
5710  (or (assq 'cms ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
5711      (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)))  
5712    
5713  ;;;;; Tree dired support:  ;;;;; Tree dired support:
5714    
# Line 5943  Other orders of $ and _ seem to all work Line 5889  Other orders of $ and _ seem to all work
5889                (and userid (concat userid "."))                (and userid (concat userid "."))
5890                ;; change every '/' in filename to a '.', normally not neccessary                ;; change every '/' in filename to a '.', normally not neccessary
5891                (and filename                (and filename
5892                     (apply (function concat)                     (subst-char-in-string ?/ ?. filename)))))
                           (mapcar (function (lambda (char)  
                                               (if (= char ?/)  
                                                   (vector ?.)  
                                                 (vector char))))  
                                   filename))))))  
5893          ;; Let's hope that BS2000 recognize this anyway:          ;; Let's hope that BS2000 recognize this anyway:
5894          name))))          name))))
5895    
# Line 6000  Other orders of $ and _ seem to all work Line 5941  Other orders of $ and _ seem to all work
5941                      ange-ftp-bs2000-host-regexp)                      ange-ftp-bs2000-host-regexp)
5942              ange-ftp-host-cache nil)))              ange-ftp-host-cache nil)))
5943    
 (defvar ange-ftp-bs2000-posix-hook-installed nil)  
   
5944  (defun ange-ftp-add-bs2000-posix-host (host)  (defun ange-ftp-add-bs2000-posix-host (host)
5945    "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."
5946    (interactive    (interactive
# Line 6015  Other orders of $ and _ seem to all work Line 5954  Other orders of $ and _ seem to all work
5954                      ange-ftp-bs2000-posix-host-regexp)                      ange-ftp-bs2000-posix-host-regexp)
5955              ange-ftp-host-cache nil))              ange-ftp-host-cache nil))
5956    ;; Install CD hook to cd to posix on connecting:    ;; Install CD hook to cd to posix on connecting:
5957    (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))  
5958    host)    host)
5959    
5960  (defconst ange-ftp-bs2000-filename-regexp  (defconst ange-ftp-bs2000-filename-regexp
# Line 6039  Other orders of $ and _ seem to all work Line 5976  Other orders of $ and _ seem to all work
5976  ;; Extract the next filename from a BS2000 dired-like listing.  ;; Extract the next filename from a BS2000 dired-like listing.
5977  (defun ange-ftp-parse-bs2000-filename ()  (defun ange-ftp-parse-bs2000-filename ()
5978    (if (re-search-forward ange-ftp-bs2000-filename-regexp nil t)    (if (re-search-forward ange-ftp-bs2000-filename-regexp nil t)
5979          (buffer-substring (match-beginning 2) (match-end 2))))        (match-string 2)))
5980    
5981  ;; 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
5982  ;; format, and return a hashtable as the result.  ;; format, and return a hashtable as the result.
# Line 6050  Other orders of $ and _ seem to all work Line 5987  Other orders of $ and _ seem to all work
5987      ;; get current pubset      ;; get current pubset
5988      (goto-char (point-min))      (goto-char (point-min))
5989      (if (re-search-forward ange-ftp-bs2000-filename-pubset-regexp nil t)      (if (re-search-forward ange-ftp-bs2000-filename-pubset-regexp nil t)
5990          (setq pubset (buffer-substring (match-beginning 0) (match-end 0))))          (setq pubset (match-string 0)))
5991      ;; add files to hashtable      ;; add files to hashtable
5992      (goto-char (point-min))      (goto-char (point-min))
5993      (save-match-data      (save-match-data
# Line 6065  Other orders of $ and _ seem to all work Line 6002  Other orders of $ and _ seem to all work
6002                  ange-ftp-bs2000-additional-pubsets))                  ange-ftp-bs2000-additional-pubsets))
6003      tbl))      tbl))
6004    
6005  (or (assq 'bs2000 ange-ftp-parse-list-func-alist)  (add-to-list 'ange-ftp-parse-list-func-alist
6006      (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)))  
6007    
6008  (defun ange-ftp-bs2000-cd-to-posix ()  (defun ange-ftp-bs2000-cd-to-posix ()
6009    "cd to POSIX subsystem if the current host matches    "cd to POSIX subsystem if the current host matches
6010  ange-ftp-bs2000-posix-host-regexp.  All BS2000 hosts with POSIX subsystem  `ange-ftp-bs2000-posix-host-regexp'.  All BS2000 hosts with POSIX subsystem
6011  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
6012  be recognized automatically (they are all valid BS2000 hosts too)."  be recognized automatically (they are all valid BS2000 hosts too)."
6013    (if (and host (ange-ftp-bs2000-posix-host host))    (if (and ange-ftp-this-host (ange-ftp-bs2000-posix-host ange-ftp-this-host))
6014        (progn        (progn
6015          ;; change to POSIX:          ;; change to POSIX:
6016  ;       (ange-ftp-raw-send-cmd proc "cd %POSIX")  ;       (ange-ftp-raw-send-cmd proc "cd %POSIX")
6017          (ange-ftp-cd host user "%POSIX")          (ange-ftp-cd ange-ftp-this-host ange-ftp-this-user "%POSIX")
6018          ;; put new home directory in the expand-dir hashtable.          ;; put new home directory in the expand-dir hashtable.
6019          ;; `host' and `user' are bound in ange-ftp-get-process.          ;; `ange-ftp-this-host' and `ange-ftp-this-user' are bound in
6020          (puthash (concat host "/" user "/~")          ;; ange-ftp-get-process.
6021                   (car (ange-ftp-get-pwd host user))          (puthash (concat ange-ftp-this-host "/" ange-ftp-this-user "/~")
6022                     (car (ange-ftp-get-pwd ange-ftp-this-host ange-ftp-this-user))
6023                   ange-ftp-expand-dir-hashtable))))                   ange-ftp-expand-dir-hashtable))))
6024    
6025  ;; Not available yet:  ;; Not available yet:

Legend:
Removed from v.1.44  
changed lines
  Added in v.1.45

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