Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
5f0e6860
Commit
5f0e6860
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Finally got around to rewritting print-directory.
parent
367fcfdf
No related branches found
Branches containing commit
No related tags found
Tags containing commit
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/filesys.lisp
+101
-98
101 additions, 98 deletions
code/filesys.lisp
with
101 additions
and
98 deletions
code/filesys.lisp
+
101
−
98
View file @
5f0e6860
...
@@ -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.
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment