Mercurial > hg > xemacs-beta

comparison lisp/dired/ange-ftp.el @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents ac2d302a0011
children
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
1457 (list "Opening directory" 1457 (list "Opening directory"
1458 (if (file-exists-p directory) 1458 (if (file-exists-p directory)
1459 "not a directory" 1459 "not a directory"
1460 "no such file or directory") 1460 "no such file or directory")
1461 directory)))) 1461 directory))))
1462
1463 ;;;; ------------------------------------------------------------
1464 ;;;; Remote file name syntax support.
1465 ;;;; ------------------------------------------------------------
1466 (defvar ange-ftp-name-format
1467 '("^/\\(\\([^@/:]*\\)@\\)?\\([^@/:]*[^@/:.]\\):\\(.*\\)" . (3 2 4))
1468 "*Format of a fully expanded remote file name.
1469 This is a list of the form \(REGEXP HOST USER NAME\),
1470 where REGEXP is a regular expression matching
1471 the full remote name, and HOST, USER, and NAME are the numbers of
1472 parenthesized expressions in REGEXP for the components (in that order).")
1473
1474 (defun ange-ftp-real-load (&rest args)
1475 (ange-ftp-run-real-handler 'load args))
1476
1477 (defmacro ange-ftp-ftp-name-component (n ns name)
1478 "Extract the Nth ftp file name component from NS."
1479 (` (let ((elt (nth (, n) (, ns))))
1480 (if (match-beginning elt)
1481 (substring (, name) (match-beginning elt) (match-end elt))))))
1482
1483 (defvar ange-ftp-ftp-name-arg "")
1484 (defvar ange-ftp-ftp-name-res nil)
1485
1486 ;; Parse NAME according to `ange-ftp-name-format' (which see).
1487 ;; Returns a list (HOST USER NAME), or nil if NAME does not match the format.
1488 (defun ange-ftp-ftp-name (name)
1489 (if (string-equal name ange-ftp-ftp-name-arg)
1490 ange-ftp-ftp-name-res
1491 (setq ange-ftp-ftp-name-arg name
1492 ange-ftp-ftp-name-res
1493 (save-match-data
1494 (if (posix-string-match (car ange-ftp-name-format) name)
1495 (let* ((ns (cdr ange-ftp-name-format))
1496 (host (ange-ftp-ftp-name-component 0 ns name))
1497 (user (ange-ftp-ftp-name-component 1 ns name))
1498 (name (ange-ftp-ftp-name-component 2 ns name)))
1499 (if (zerop (length user))
1500 (setq user (ange-ftp-get-user host)))
1501 (list host user name))
1502 nil)))))
1503
1504 ;; Take a FULLNAME that matches according to ange-ftp-name-format and
1505 ;; replace the name component with NAME.
1506 (defun ange-ftp-replace-name-component (fullname name)
1507 (save-match-data
1508 (if (posix-string-match (car ange-ftp-name-format) fullname)
1509 (let* ((ns (cdr ange-ftp-name-format))
1510 (elt (nth 2 ns)))
1511 (concat (substring fullname 0 (match-beginning elt))
1512 name
1513 (substring fullname (match-end elt)))))))
1514
1515 (defun ange-ftp-file-local-copy (file)
1516 (let* ((fn1 (expand-file-name file))
1517 (pa1 (ange-ftp-ftp-name fn1)))
1518 (if pa1
1519 (let ((tmp1 (ange-ftp-make-tmp-name (car pa1))))
1520 (ange-ftp-copy-file-internal fn1 tmp1 t nil
1521 (format "Getting %s" fn1))
1522 tmp1))))
1523
1524 (defun ange-ftp-load (file &optional noerror nomessage nosuffix)
1525 (if (ange-ftp-ftp-name file)
1526 (let ((tryfiles (if nosuffix
1527 (list file)
1528 (list (concat file ".elc") (concat file ".el") file)))
1529 copy)
1530 (while (and tryfiles (not copy))
1531 (condition-case error
1532 (setq copy (ange-ftp-file-local-copy (car tryfiles)))
1533 (ftp-error nil))
1534 (setq tryfiles (cdr tryfiles)))
1535 (if copy
1536 (unwind-protect
1537 (funcall 'load copy noerror nomessage nosuffix)
1538 (delete-file copy))
1539 (or noerror
1540 (signal 'file-error (list "Cannot open load file" file)))))
1541 (ange-ftp-real-load file noerror nomessage nosuffix)))
1542 (put 'load 'ange-ftp 'ange-ftp-load)
1462 1543
1463 ;;;; ------------------------------------------------------------ 1544 ;;;; ------------------------------------------------------------
1464 ;;;; FTP process filter support. 1545 ;;;; FTP process filter support.
1465 ;;;; ------------------------------------------------------------ 1546 ;;;; ------------------------------------------------------------
1466 1547
4956 (ange-ftp-overwrite-fn 'file-name-as-directory) 5037 (ange-ftp-overwrite-fn 'file-name-as-directory)
4957 (ange-ftp-overwrite-fn 'directory-file-name) 5038 (ange-ftp-overwrite-fn 'directory-file-name)
4958 (ange-ftp-overwrite-fn 'expand-file-name) 5039 (ange-ftp-overwrite-fn 'expand-file-name)
4959 (ange-ftp-overwrite-fn 'file-name-all-completions) 5040 (ange-ftp-overwrite-fn 'file-name-all-completions)
4960 (ange-ftp-overwrite-fn 'file-name-completion) 5041 (ange-ftp-overwrite-fn 'file-name-completion)
5042 (ange-ftp-overwrite-fn 'load)
4961 5043
4962 (or (memq 'ange-ftp-set-buffer-mode find-file-hooks) 5044 (or (memq 'ange-ftp-set-buffer-mode find-file-hooks)
4963 (setq find-file-hooks 5045 (setq find-file-hooks
4964 (cons 'ange-ftp-set-buffer-mode find-file-hooks))) 5046 (cons 'ange-ftp-set-buffer-mode find-file-hooks)))
4965 5047