Skip to content
Snippets Groups Projects
Commit 5f0e6860 authored by wlott's avatar wlott
Browse files

Finally got around to rewritting print-directory.

parent 367fcfdf
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC). ;;; 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. ;;; Ugly pathname functions for Spice Lisp.
;;; these functions are part of the standard Spice Lisp environment. ;;; these functions are part of the standard Spice Lisp environment.
...@@ -737,8 +737,6 @@ ...@@ -737,8 +737,6 @@
;;;; Printing directories. ;;;; Printing directories.
#|
;;; PRINT-DIRECTORY is exported from the EXTENSIONS package. ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
;;; ;;;
(defun print-directory (pathname &optional stream &key all verbose return-list) (defun print-directory (pathname &optional stream &key all verbose return-list)
...@@ -754,61 +752,65 @@ ...@@ -754,61 +752,65 @@
(print-directory-formatted pathname all return-list)))) (print-directory-formatted pathname all return-list))))
(defun print-directory-verbose (pathname all return-list) (defun print-directory-verbose (pathname all return-list)
(multiple-value-bind (dir pattern) (find-directory pathname) (let ((contents (directory pathname :all all :check-for-subdirs nil))
(declare (ignore dir)) (result nil))
(format t "Directory of ~A :~%" pattern) (format t "Directory of ~A :~%" (namestring pathname))
(let ((dir-name (directory-namestring pattern)) (dolist (file contents)
(result ())) (let* ((namestring (unix-namestring file))
(do-directory (name etype pattern all (nreverse result)) (tail (subseq namestring
(let ((slash-name (if (eq etype :entry_file) (1+ (or (position #\/ namestring
name :from-end t
(concatenate 'simple-string name "/")))) :test #'char=)
(declare (simple-string slash-name)) -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 (when return-list
(push (pathname (concatenate 'simple-string dir-name slash-name)) (push (if (= (logand mode mach::s_ifmt) mach::s_ifdir)
result)) (pathname (concatenate 'string namestring "/"))
(multiple-value-bind file)
(reslt dev-or-err ino mode nlink uid gid rdev size atime mtime) result)))))
(mach:unix-stat (concatenate 'simple-string dir-name name)) (nreverse result)))
(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))))))))))
(defun decode-universal-time-for-files (time current-year) (defun decode-universal-time-for-files (time current-year)
(multiple-value-bind (sec min hour day month year) (multiple-value-bind (sec min hour day month year)
...@@ -825,50 +827,51 @@ ...@@ -825,50 +827,51 @@
(names ()) (names ())
(cnt 0) (cnt 0)
(max-len 0) (max-len 0)
(result ())) (result (directory pathname :all all)))
(declare (list names) (fixnum max-len cnt)) (declare (list names) (fixnum max-len cnt))
;; ;;
;; Get the data. ;; Get the data.
(multiple-value-bind (dir pattern) (find-directory pathname) (dolist (file result)
(declare (ignore dir)) (let* ((name (unix-namestring file))
(do-directory (name etype pattern all) (length (length name))
(let* ((slash-name (if (eql etype :entry_file) (end (if (and (plusp length)
name (char= (schar name (1- length)) #\/))
(concatenate 'simple-string name "/"))) (1- length)
(len (length slash-name))) length))
(declare (simple-string slash-name) (slash-name (subseq name
(fixnum len)) (1+ (or (position #\/ name
(when return-list :from-end t
(push (pathname (concatenate 'simple-string :end end
(directory-namestring pattern) :test #'char=)
slash-name)) -1))))
result)) (len (length slash-name)))
(declare (simple-string slash-name)
(if (> len max-len) (setq max-len len)) (fixnum len))
(incf cnt) (if (> len max-len) (setq max-len len))
(push slash-name names))) (incf cnt)
(setq names (nreverse names)) (push slash-name names)))
;; (setq names (nreverse names))
;; Do the output. ;;
(let* ((col-width (1+ max-len)) ;; Do the output.
(cols (max (truncate width col-width) 1)) (let* ((col-width (1+ max-len))
(lines (ceiling cnt cols))) (cols (max (truncate width col-width) 1))
(declare (fixnum cols lines)) (lines (ceiling cnt cols)))
(format t "Directory of ~A :~%" pattern) (declare (fixnum cols lines))
(dotimes (i lines) (format t "Directory of ~A :~%" (namestring pathname))
(declare (fixnum i)) (dotimes (i lines)
(dotimes (j cols) (declare (fixnum i))
(declare (fixnum j)) (dotimes (j cols)
(let ((name (nth (+ i (the fixnum (* j lines))) names))) (declare (fixnum j))
(when name (let ((name (nth (+ i (the fixnum (* j lines))) names)))
(write-string name) (when name
(unless (eql j (1- cols)) (write-string name)
(tab-over (unless (eql j (1- cols))
(- col-width (length (the simple-string name)))))))) (tab-over
(terpri)))) (- col-width (length (the simple-string name))))))))
(when return-list (nreverse result)))) (terpri)))
(when return-list
|# result)))
;;;; Translating uid's and gid's. ;;;; Translating uid's and gid's.
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment