From 5f0e6860f5f34fdcdfac6ce6dd2a14fcc0b77052 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Fri, 23 Nov 1990 08:36:30 +0000
Subject: [PATCH] Finally got around to rewritting print-directory.

---
 code/filesys.lisp | 199 +++++++++++++++++++++++-----------------------
 1 file changed, 101 insertions(+), 98 deletions(-)

diff --git a/code/filesys.lisp b/code/filesys.lisp
index 8ac4dcf4c..668e45135 100644
--- a/code/filesys.lisp
+++ b/code/filesys.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.6 1990/11/17 05:40:13 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.7 1990/11/23 08:36:30 wlott Exp $
 ;;;
 ;;; Ugly pathname functions for Spice Lisp.
 ;;;    these functions are part of the standard Spice Lisp environment.
@@ -737,8 +737,6 @@
 
 ;;;; Printing directories.
 
-#|
-
 ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
 ;;; 
 (defun print-directory (pathname &optional stream &key all verbose return-list)
@@ -754,61 +752,65 @@
 	(print-directory-formatted pathname all return-list))))
 
 (defun print-directory-verbose (pathname all return-list)
-  (multiple-value-bind (dir pattern) (find-directory pathname)
-    (declare (ignore dir))
-    (format t "Directory of ~A :~%" pattern)
-    (let ((dir-name (directory-namestring pattern))
-	  (result ()))
-      (do-directory (name etype pattern all (nreverse result))
-	(let ((slash-name (if (eq etype :entry_file)
-			      name
-			      (concatenate 'simple-string name "/"))))
-	  (declare (simple-string slash-name))
+  (let ((contents (directory pathname :all all :check-for-subdirs nil))
+	(result nil))
+    (format t "Directory of ~A :~%" (namestring pathname))
+    (dolist (file contents)
+      (let* ((namestring (unix-namestring file))
+	     (tail (subseq namestring
+			   (1+ (or (position #\/ namestring
+					     :from-end t
+					     :test #'char=)
+				   -1)))))
+	(multiple-value-bind 
+	    (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
+	    (mach:unix-stat namestring)
+	  (declare (ignore ino gid rdev atime)
+		   (fixnum uid mode))
+	  (cond (reslt
+		 ;;
+		 ;; Print characters for file modes.
+		 (macrolet ((frob (bit name &optional sbit sname negate)
+			      `(if ,(if negate
+					`(not (logbitp ,bit mode))
+					`(logbitp ,bit mode))
+				   ,(if sbit
+					`(if (logbitp ,sbit mode)
+					     (write-char ,sname)
+					     (write-char ,name))
+					`(write-char ,name))
+				   (write-char #\-))))
+		   (frob 15 #\d nil nil t)
+		   (frob 8 #\r)
+		   (frob 7 #\w)
+		   (frob 6 #\x 11 #\s)
+		   (frob 5 #\r)
+		   (frob 4 #\w)
+		   (frob 3 #\x 10 #\s)
+		   (frob 2 #\r)
+		   (frob 1 #\w)
+		   (frob 0 #\x))
+		 ;;
+		 ;; Print the rest.
+		 (multiple-value-bind (sec min hour date month year)
+				      (get-decoded-time)
+		   (declare (ignore sec min hour date month))
+		   (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"
+			   nlink
+			   (or (lookup-login-name uid) uid)
+			   size
+			   (decode-universal-time-for-files mtime year)
+			   tail
+			   (= (logand mode mach::s_ifmt) mach::s_ifdir))))
+		(t (format t "Couldn't stat ~A -- ~A.~%"
+			   tail
+			   (mach:get-unix-error-msg dev-or-err))))
 	  (when return-list
-	    (push (pathname (concatenate 'simple-string dir-name slash-name))
-		  result))
-	  (multiple-value-bind 
-	      (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
-	      (mach:unix-stat (concatenate 'simple-string dir-name name))
-	    (declare (ignore ino gid rdev atime)
-		     (fixnum uid mode))
-	    (cond (reslt
-		   ;;
-		   ;; Print characters for file modes.
-		   (macrolet ((frob (bit name &optional sbit sname negate)
-				`(if ,(if negate
-					  `(not (logbitp ,bit mode))
-					  `(logbitp ,bit mode))
-				     ,(if sbit
-					  `(if (logbitp ,sbit mode)
-					       (write-char ,sname)
-					       (write-char ,name))
-					  `(write-char ,name))
-				     (write-char #\-))))
-		     (frob 15 #\d nil nil t)
-		     (frob 8 #\r)
-		     (frob 7 #\w)
-		     (frob 6 #\x 11 #\s)
-		     (frob 5 #\r)
-		     (frob 4 #\w)
-		     (frob 3 #\x 10 #\s)
-		     (frob 2 #\r)
-		     (frob 1 #\w)
-		     (frob 0 #\x))
-		   ;;
-		   ;; Print the rest.
-		   (multiple-value-bind (sec min hour date month year)
-					(get-decoded-time)
-		     (declare (ignore sec min hour date month))
-		     (format t "~2D ~8A ~8D ~12A ~A~%"
-			     nlink
-			     (or (lookup-login-name uid) uid)
-			     size
-			     (decode-universal-time-for-files mtime year)
-			     slash-name)))
-		  (t (format t "Couldn't stat ~A -- ~A.~%"
-			     slash-name
-			     (mach:get-unix-error-msg dev-or-err))))))))))
+	    (push (if (= (logand mode mach::s_ifmt) mach::s_ifdir)
+		      (pathname (concatenate 'string namestring "/"))
+		      file)
+		  result)))))
+    (nreverse result)))
 
 (defun decode-universal-time-for-files (time current-year)
   (multiple-value-bind (sec min hour day month year)
@@ -825,50 +827,51 @@
 	(names ())
 	(cnt 0)
 	(max-len 0)
-	(result ()))
+	(result (directory pathname :all all)))
     (declare (list names) (fixnum max-len cnt))
     ;;
     ;; Get the data.
-    (multiple-value-bind (dir pattern) (find-directory pathname)
-      (declare (ignore dir))
-      (do-directory (name etype pattern all)
-	(let* ((slash-name (if (eql etype :entry_file)
-			       name
-			       (concatenate 'simple-string name "/")))
-	       (len (length slash-name)))
-	  (declare (simple-string slash-name)
-		   (fixnum len))
-	  (when return-list
-	    (push (pathname (concatenate 'simple-string
-					 (directory-namestring pattern)
-					 slash-name))
-		  result))
-	  
-	  (if (> len max-len) (setq max-len len))
-	  (incf cnt)
-	  (push slash-name names)))
-      (setq names (nreverse names))
-      ;;
-      ;; Do the output.
-      (let* ((col-width (1+ max-len))
-	     (cols (max (truncate width col-width) 1))
-	     (lines (ceiling cnt cols)))
-	(declare (fixnum cols lines))
-	(format t "Directory of ~A :~%" pattern)
-	(dotimes (i lines)
-	  (declare (fixnum i))
-	  (dotimes (j cols)
-	    (declare (fixnum j))
-	    (let ((name (nth (+ i (the fixnum (* j lines))) names)))
-	      (when name
-		(write-string name)
-		(unless (eql j (1- cols))
-		  (tab-over 
-		   (- col-width (length (the simple-string name))))))))
-	  (terpri))))
-    (when return-list (nreverse result))))
-
-|#
+    (dolist (file result)
+      (let* ((name (unix-namestring file))
+	     (length (length name))
+	     (end (if (and (plusp length)
+			   (char= (schar name (1- length)) #\/))
+		      (1- length)
+		      length))
+	     (slash-name (subseq name
+				 (1+ (or (position #\/ name
+						   :from-end t
+						   :end end
+						   :test #'char=)
+					 -1))))
+	     (len (length slash-name)))
+	(declare (simple-string slash-name)
+		 (fixnum len))
+	(if (> len max-len) (setq max-len len))
+	(incf cnt)
+	(push slash-name names)))
+    (setq names (nreverse names))
+    ;;
+    ;; Do the output.
+    (let* ((col-width (1+ max-len))
+	   (cols (max (truncate width col-width) 1))
+	   (lines (ceiling cnt cols)))
+      (declare (fixnum cols lines))
+      (format t "Directory of ~A :~%" (namestring pathname))
+      (dotimes (i lines)
+	(declare (fixnum i))
+	(dotimes (j cols)
+	  (declare (fixnum j))
+	  (let ((name (nth (+ i (the fixnum (* j lines))) names)))
+	    (when name
+	      (write-string name)
+	      (unless (eql j (1- cols))
+		(tab-over 
+		 (- col-width (length (the simple-string name))))))))
+	(terpri)))
+    (when return-list
+      result)))
+
 
 
 ;;;; Translating uid's and gid's.
-- 
GitLab