xemacs-beta: lisp/files.el comparison

comparison lisp/files.el @ 1606:5d5a604cb3ed

[xemacs-hg @ 2003-08-06 09:11:39 by michaels] 2003-08-03 Mike Sperber <mike@xemacs.org> * 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.

author	michaels
date	Wed, 06 Aug 2003 09:11:40 +0000
parents	01c57eb70ae9
children	eeb607577f17

comparison

equal deleted inserted replaced

-:244f35b6ec2d
+:5d5a604cb3ed
 ;;   		 dired-move-to-end-of-filename,
 ;;		 dired-between-files, (shortcut for (not (dired-move-to-filename)))
 ;;   		 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.
 (defun insert-directory (file switches &optional wildcard full-directory-p)
 "Insert directory listing for FILE, formatted according to SWITCHES.
 whose name is in the variable `insert-directory-program'.
 If WILDCARD, it also runs the shell specified by `shell-file-name'."
 ;; 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
+(cond
-	(funcall handler 'insert-directory file switches
+(handler
-		 wildcard full-directory-p)
+(funcall handler 'insert-directory file switches
-(cond
+	       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))
+	   (eq system-type 'windows-nt))
-	(declare-fboundp (mswindows-insert-directory
+(declare-fboundp (mswindows-insert-directory
-			  file switches wildcard full-directory-p)))
+			file switches wildcard full-directory-p)))
 (t
-	(if wildcard
+(let* ((beg (point))
-	    ;; Run ls in the directory of the file pattern we asked for.
+	     (result
-	    (let ((default-directory
+	      (if wildcard
-(if (file-name-absolute-p file)
+		  ;; Run ls in the directory of the file pattern we asked for.
-(file-name-directory file)
+		  (let ((default-directory
-(file-name-directory (expand-file-name file))))
+			  (if (file-name-absolute-p file)
-		  (pattern (file-name-nondirectory file))
+			      (file-name-directory file)
-		  (start 0))
+			    (file-name-directory (expand-file-name file))))
-	      ;; Quote some characters that have special meanings in shells;
+			(pattern (file-name-nondirectory file))
-	      ;; but don't quote the wildcards--we want them to be special.
+			(start 0))
-	      ;; We also currently don't quote the quoting characters
+		    ;; Quote some characters that have special meanings in shells;
-	      ;; in case people want to use them explicitly to quote
+		    ;; but don't quote the wildcards--we want them to be special.
-	      ;; wildcard characters.
+		    ;; We also currently don't quote the quoting characters
-;;#### Unix-specific
+		    ;; in case people want to use them explicitly to quote
-	      (while (string-match "[ \t\n;<>&|()#$]" pattern start)
+		    ;; wildcard characters.
-		(setq pattern
+		    ;;#### Unix-specific
-		      (concat (substring pattern 0 (match-beginning 0))
+		    (while (string-match "[ \t\n;<>&|()#$]" pattern start)
-			      "\\"
+		      (setq pattern
-			      (substring pattern (match-beginning 0)))
+			    (concat (substring pattern 0 (match-beginning 0))
-		      start (1+ (match-end 0))))
+				    "\\"
-	      (call-process shell-file-name nil t nil
+				    (substring pattern (match-beginning 0)))
-			    "-c" (concat "\\"  ;; Disregard shell aliases!
+			    start (1+ (match-end 0))))
-					 insert-directory-program
+		    (call-process shell-file-name nil t nil
-					 " -d "
+				  "-c" (concat "\\" ;; Disregard shell aliases!
-					 (if (stringp switches)
+					       insert-directory-program
-					     switches
+					       " -d "
-					   (mapconcat 'identity switches " "))
+					       (if (stringp switches)
-					 " "
+						   switches
-					 pattern)))
+						 (mapconcat 'identity switches " "))
-	  ;; SunOS 4.1.3, SVr4 and others need the "." to list the
+					       " "
-	  ;; directory if FILE is a symbolic link.
+					       pattern)))
-	  (apply 'call-process
+		;; SunOS 4.1.3, SVr4 and others need the "." to list the
-		 insert-directory-program nil t nil
+		;; directory if FILE is a symbolic link.
-		 (let (list)
+		(apply 'call-process
-		   (if (listp switches)
+		       insert-directory-program nil t nil
-		       (setq list switches)
+		       (let (list)
-		     (if (not (equal switches ""))
+			 (if (listp switches)
-			 (progn
+			     (setq list switches)
-			   ;; Split the switches at any spaces
+			   (if (not (equal switches ""))
-			   ;; so we can pass separate options as separate args.
+			       (let ((switches switches))
-			   (while (string-match " " switches)
+				 ;; Split the switches at any spaces
-			     (setq list (cons (substring switches 0 (match-beginning 0))
+				 ;; so we can pass separate options as separate args.
-					      list)
+				 (while (string-match " " switches)
-				   switches (substring switches (match-end 0))))
+				   (setq list (cons (substring switches 0 (match-beginning 0))
-			   (setq list (cons switches list)))))
+						    list)
-		   (append list
+					 switches (substring switches (match-end 0))))
-			   (list
+				 (setq list (cons switches list)))))
-			    (if full-directory-p
+			 (append list
-				(concat (file-name-as-directory file)
+				 (list
-					;;#### Unix-specific
+				  (if full-directory-p
-					".")
+				      (concat (file-name-as-directory file)
-			      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.
 (defun insert-directory-safely (file switches
 				     &optional wildcard full-directory-p)

Mercurial > hg > xemacs-beta

comparison lisp/files.el @ 1606:5d5a604cb3ed