# HG changeset patch # User michaels # Date 1060161100 0 # Node ID 5d5a604cb3ed0fc263e8303ba956f8d2bf3d0f55 # Parent 244f35b6ec2d85c93d8aa7bf98ce070ba2b7e0ec [xemacs-hg @ 2003-08-06 09:11:39 by michaels] 2003-08-03 Mike Sperber * files.el (insert-directory): Massage somewhat to be slightly closer to FSF version. Support "--dired" as argument for GNU ls, and, if given, create extents with 'dired-file-name property set to t, similar to what the FSF version does. diff -r 244f35b6ec2d -r 5d5a604cb3ed lisp/ChangeLog --- a/lisp/ChangeLog Tue Aug 05 21:52:32 2003 +0000 +++ b/lisp/ChangeLog Wed Aug 06 09:11:40 2003 +0000 @@ -1,3 +1,10 @@ +2003-08-03 Mike Sperber + + * files.el (insert-directory): Massage somewhat to be slightly + closer to FSF version. Support "--dired" as argument for GNU ls, + and, if given, create extents with 'dired-file-name property set + to t, similar to what the FSF version does. + 2003-07-31 Mike Sperber * isearch-mode.el (isearch-mode-help): diff -r 244f35b6ec2d -r 5d5a604cb3ed lisp/files.el --- a/lisp/files.el Tue Aug 05 21:52:32 2003 +0000 +++ b/lisp/files.el Wed Aug 06 09:11:40 2003 +0000 @@ -4072,6 +4072,9 @@ ;; dired-insert-headerline ;; dired-after-subdir-garbage (defines what a "total" line is) ;; - variable dired-subdir-regexp +;; - may be passed "--dired" as argument in SWITCHES. +;; Filename handlers might have to remove this switch if their +;; "ls" command does not support it. ;; END SYNC WITH FSF 21.2. @@ -4089,70 +4092,109 @@ ;; We need the directory in order to find the right handler. (let ((handler (find-file-name-handler (expand-file-name file) 'insert-directory))) - (if handler - (funcall handler 'insert-directory file switches - wildcard full-directory-p) - (cond - ;; [mswindows-insert-directory should be called - ;; nt-insert-directory - kkm]. not true any more according to - ;; my new naming scheme. --ben - ((and (fboundp 'mswindows-insert-directory) - (eq system-type 'windows-nt)) - (declare-fboundp (mswindows-insert-directory - file switches wildcard full-directory-p))) - (t - (if wildcard - ;; Run ls in the directory of the file pattern we asked for. - (let ((default-directory - (if (file-name-absolute-p file) - (file-name-directory file) - (file-name-directory (expand-file-name file)))) - (pattern (file-name-nondirectory file)) - (start 0)) - ;; Quote some characters that have special meanings in shells; - ;; but don't quote the wildcards--we want them to be special. - ;; We also currently don't quote the quoting characters - ;; in case people want to use them explicitly to quote - ;; wildcard characters. - ;;#### Unix-specific - (while (string-match "[ \t\n;<>&|()#$]" pattern start) - (setq pattern - (concat (substring pattern 0 (match-beginning 0)) - "\\" - (substring pattern (match-beginning 0))) - start (1+ (match-end 0)))) - (call-process shell-file-name nil t nil - "-c" (concat "\\" ;; Disregard shell aliases! - insert-directory-program - " -d " - (if (stringp switches) - switches - (mapconcat 'identity switches " ")) - " " - pattern))) - ;; SunOS 4.1.3, SVr4 and others need the "." to list the - ;; directory if FILE is a symbolic link. - (apply 'call-process - insert-directory-program nil t nil - (let (list) - (if (listp switches) - (setq list switches) - (if (not (equal switches "")) - (progn - ;; Split the switches at any spaces - ;; so we can pass separate options as separate args. - (while (string-match " " switches) - (setq list (cons (substring switches 0 (match-beginning 0)) - list) - switches (substring switches (match-end 0)))) - (setq list (cons switches list))))) - (append list - (list - (if full-directory-p - (concat (file-name-as-directory file) - ;;#### Unix-specific - ".") - file))))))))))) + (cond + (handler + (funcall handler 'insert-directory file switches + wildcard full-directory-p)) + ;; [mswindows-insert-directory should be called + ;; nt-insert-directory - kkm]. not true any more according to + ;; my new naming scheme. --ben + ((and (fboundp 'mswindows-insert-directory) + (eq system-type 'windows-nt)) + (declare-fboundp (mswindows-insert-directory + file switches wildcard full-directory-p))) + (t + (let* ((beg (point)) + (result + (if wildcard + ;; Run ls in the directory of the file pattern we asked for. + (let ((default-directory + (if (file-name-absolute-p file) + (file-name-directory file) + (file-name-directory (expand-file-name file)))) + (pattern (file-name-nondirectory file)) + (start 0)) + ;; Quote some characters that have special meanings in shells; + ;; but don't quote the wildcards--we want them to be special. + ;; We also currently don't quote the quoting characters + ;; in case people want to use them explicitly to quote + ;; wildcard characters. + ;;#### Unix-specific + (while (string-match "[ \t\n;<>&|()#$]" pattern start) + (setq pattern + (concat (substring pattern 0 (match-beginning 0)) + "\\" + (substring pattern (match-beginning 0))) + start (1+ (match-end 0)))) + (call-process shell-file-name nil t nil + "-c" (concat "\\" ;; Disregard shell aliases! + insert-directory-program + " -d " + (if (stringp switches) + switches + (mapconcat 'identity switches " ")) + " " + pattern))) + ;; SunOS 4.1.3, SVr4 and others need the "." to list the + ;; directory if FILE is a symbolic link. + (apply 'call-process + insert-directory-program nil t nil + (let (list) + (if (listp switches) + (setq list switches) + (if (not (equal switches "")) + (let ((switches switches)) + ;; Split the switches at any spaces + ;; so we can pass separate options as separate args. + (while (string-match " " switches) + (setq list (cons (substring switches 0 (match-beginning 0)) + list) + switches (substring switches (match-end 0)))) + (setq list (cons switches list))))) + (append list + (list + (if full-directory-p + (concat (file-name-as-directory file) + ;;#### Unix-specific + ".") + file)))))))) + ;; If `insert-directory-program' failed, signal an error. + (if (/= result 0) + ;; On non-Posix systems, we cannot open a directory, so + ;; don't even try, because that will always result in + ;; the ubiquitous "Access denied". Instead, show the + ;; command line so the user can try to guess what went wrong. + (error "Listing directory failed.")) + + (when (or (and (listp switches) + (member "--dired" switches)) + (string-match "--dired\\>" switches)) + (forward-line -2) + (when (looking-at "//SUBDIRED//") + (delete-region (point) (progn (forward-line 1) (point))) + (forward-line -1)) + (let ((end (line-end-position))) + (forward-word 1) + (forward-char 3) + (while (< (point) end) + (let ((start (+ beg (read (current-buffer)))) + (end (+ beg (read (current-buffer))))) + (if (= (char-after end) ?\n) + (let ((filename-extent (make-extent start end))) + (set-extent-property filename-extent 'dired-file-name t) + (set-extent-property filename-extent 'start-open t) + (set-extent-property filename-extent 'end-open t)) + ;; It seems that we can't trust ls's output as to + ;; byte positions of filenames. + (map-extents + #'(lambda (extent maparg) + (delete-extent extent) + nil) + nil beg (point) nil nil 'dired-file-name) + (end-of-line)))) + (goto-char end) + (beginning-of-line) + (delete-region (point) (progn (forward-line 2) (point)))))))))) ;; BEGIN SYNC WITH FSF 21.2.