/[cmucl]/src/code/filesys.lisp
ViewVC logotype

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.104 - (hide annotations)
Mon Sep 10 16:25:00 2007 UTC (6 years, 7 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2008-05, snapshot-2008-06, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, release-19e, snapshot-2008-04, release-19e-pre1, release-19e-pre2, release-19e-base, unicode-utf16-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11
Branch point for: unicode-utf16-branch, release-19e-branch
Changes since 1.103: +23 -12 lines
Apply patch from Walter C. Pelissero, cmucl-imp, 2007-09-05, fixing
bug that #p"..." didn't have a namestring.

Some further changes were also applied to fix the problem that #p"..a"
had directory = (:relative), name = nil, and type "a".  This is now
directory = nil, name = ".", type ="a".
1 ram 1.1 ;;; -*- Log: code.log; Package: Lisp -*-
2     ;;; **********************************************************************
3 ram 1.8 ;;; This code was written as part of the CMU Common Lisp project at
4     ;;; Carnegie Mellon University, and has been placed in the public domain.
5     ;;; If you want to use this code or any part of CMU Common Lisp, please contact
6     ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
7     ;;;
8     (ext:file-comment
9 rtoy 1.104 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/filesys.lisp,v 1.104 2007/09/10 16:25:00 rtoy Exp $")
10 ram 1.8 ;;;
11 ram 1.1 ;;; **********************************************************************
12     ;;;
13 wlott 1.16 ;;; File system interface functions. This file is pretty UNIX specific.
14 ram 1.1 ;;;
15 wlott 1.16 ;;; Written by William Lott
16 ram 1.1 ;;;
17     ;;; **********************************************************************
18 ram 1.2
19     (in-package "LISP")
20    
21 wlott 1.16 (export '(truename probe-file user-homedir-pathname directory
22     rename-file delete-file file-write-date file-author))
23 ram 1.1
24     (use-package "EXTENSIONS")
25    
26     (in-package "EXTENSIONS")
27     (export '(print-directory complete-file ambiguous-files default-directory
28 toy 1.75 purge-backup-files file-writable unix-namestring))
29 ram 1.2 (in-package "LISP")
30 ram 1.1
31 wlott 1.5
32 wlott 1.16 ;;;; Unix pathname host support.
33 ram 1.1
34 wlott 1.16 ;;; Unix namestrings have the following format:
35     ;;;
36     ;;; namestring := [ directory ] [ file [ type [ version ]]]
37     ;;; directory := [ "/" | search-list ] { file "/" }*
38     ;;; search-list := [^:/]*:
39     ;;; file := [^/]*
40     ;;; type := "." [^/.]*
41 rtoy 1.101 ;;; version := ".*" | ".~" ([1-9]+[0-9]* | "*") "~"
42 wlott 1.16 ;;;
43 toy 1.73 ;;; Note: this grammar is ambiguous. The string foo.bar.~5~ can be parsed
44 wlott 1.16 ;;; as either just the file specified or as specifying the file, type, and
45     ;;; version. Therefore, we use the following rules when confronted with
46     ;;; an ambiguous file.type.version string:
47     ;;;
48     ;;; - If the first character is a dot, it's part of the file. It is not
49     ;;; considered a dot in the following rules.
50     ;;;
51 toy 1.73 ;;; - If there is only one dot, it separates the file and the type.
52 wlott 1.16 ;;;
53     ;;; - If there are multiple dots and the stuff following the last dot
54     ;;; is a valid version, then that is the version and the stuff between
55     ;;; the second to last dot and the last dot is the type.
56     ;;;
57     ;;; Wildcard characters:
58     ;;;
59     ;;; If the directory, file, type components contain any of the following
60     ;;; characters, it is considered part of a wildcard pattern and has the
61     ;;; following meaning.
62     ;;;
63     ;;; ? - matches any character
64     ;;; * - matches any zero or more characters.
65     ;;; [abc] - matches any of a, b, or c.
66     ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
67     ;;;
68 toy 1.73 ;;; Any of these special characters can be preceded by a backslash to
69 wlott 1.16 ;;; cause it to be treated as a regular character.
70     ;;;
71 ram 1.1
72 wlott 1.16 (defun remove-backslashes (namestr start end)
73 toy 1.73 "Remove any occurrences of \\ from the string because we've already
74     checked for whatever may have been backslashed."
75 wlott 1.16 (declare (type simple-base-string namestr)
76     (type index start end))
77     (let* ((result (make-string (- end start)))
78     (dst 0)
79     (quoted nil))
80     (do ((src start (1+ src)))
81     ((= src end))
82     (cond (quoted
83     (setf (schar result dst) (schar namestr src))
84     (setf quoted nil)
85     (incf dst))
86     (t
87     (let ((char (schar namestr src)))
88     (cond ((char= char #\\)
89     (setq quoted t))
90     (t
91     (setf (schar result dst) char)
92     (incf dst)))))))
93     (when quoted
94     (error 'namestring-parse-error
95     :complaint "Backslash in bad place."
96     :namestring namestr
97     :offset (1- end)))
98     (shrink-vector result dst)))
99 ram 1.1
100 rtoy 1.100 (defvar *ignore-wildcards* nil
101     "If non-NIL, Unix shell-style wildcards are ignored when parsing
102     pathname namestrings. They are also ignored when computing
103     namestrings for pathname objects. Thus, *, ?, etc. are not
104     wildcards when parsing a namestring, and are not escaped when
105     printing pathnames.")
106 ram 1.1
107 wlott 1.16 (defun maybe-make-pattern (namestr start end)
108     (declare (type simple-base-string namestr)
109     (type index start end))
110     (if *ignore-wildcards*
111     (subseq namestr start end)
112     (collect ((pattern))
113     (let ((quoted nil)
114     (any-quotes nil)
115     (last-regular-char nil)
116     (index start))
117     (flet ((flush-pending-regulars ()
118     (when last-regular-char
119     (pattern (if any-quotes
120     (remove-backslashes namestr
121     last-regular-char
122     index)
123     (subseq namestr last-regular-char index)))
124     (setf any-quotes nil)
125     (setf last-regular-char nil))))
126     (loop
127     (when (>= index end)
128     (return))
129     (let ((char (schar namestr index)))
130     (cond (quoted
131     (incf index)
132     (setf quoted nil))
133     ((char= char #\\)
134     (setf quoted t)
135     (setf any-quotes t)
136     (unless last-regular-char
137     (setf last-regular-char index))
138     (incf index))
139     ((char= char #\?)
140     (flush-pending-regulars)
141     (pattern :single-char-wild)
142     (incf index))
143     ((char= char #\*)
144     (flush-pending-regulars)
145     (pattern :multi-char-wild)
146     (incf index))
147     ((char= char #\[)
148     (flush-pending-regulars)
149     (let ((close-bracket
150     (position #\] namestr :start index :end end)))
151     (unless close-bracket
152     (error 'namestring-parse-error
153     :complaint "``['' with no corresponding ``]''"
154     :namestring namestr
155     :offset index))
156     (pattern (list :character-set
157     (subseq namestr
158     (1+ index)
159     close-bracket)))
160     (setf index (1+ close-bracket))))
161     (t
162     (unless last-regular-char
163     (setf last-regular-char index))
164     (incf index)))))
165     (flush-pending-regulars)))
166     (cond ((null (pattern))
167     "")
168 ram 1.31 ((null (cdr (pattern)))
169     (let ((piece (first (pattern))))
170     (typecase piece
171     ((member :multi-char-wild) :wild)
172     (simple-string piece)
173     (t
174     (make-pattern (pattern))))))
175 wlott 1.16 (t
176     (make-pattern (pattern)))))))
177 ram 1.1
178 dtc 1.59 ;;; extract-name-type-and-version -- Internal.
179     ;;;
180 wlott 1.16 (defun extract-name-type-and-version (namestr start end)
181     (declare (type simple-base-string namestr)
182     (type index start end))
183 pw 1.62 (labels
184     ((explicit-version (namestr start end)
185 rtoy 1.82 ;; Look for something like "~*~" at the end of the
186     ;; namestring, where * can be #\* or some digits. This
187     ;; denotes a version.
188 rtoy 1.92 ;;(format t "explicit-version ~S ~A ~A~%" namestr start end)
189 rtoy 1.82 (cond ((or (< (- end start) 4)
190 rtoy 1.84 (and (char/= (schar namestr (1- end)) #\~)
191     (char/= (schar namestr (1- end)) #\*)))
192 toy 1.74 ;; No explicit version given, so return NIL to
193     ;; indicate we don't want file versions, unless
194     ;; requested in other ways.
195 rtoy 1.92 ;;(format t "case 1: ~A ~A~%" nil end)
196 toy 1.74 (values nil end))
197 rtoy 1.84 ((and (not *ignore-wildcards*)
198     (char= (schar namestr (- end 2)) #\*)
199 pw 1.62 (char= (schar namestr (- end 3)) #\~)
200     (char= (schar namestr (- end 4)) #\.))
201 rtoy 1.82 ;; Found "~*~", so it's a wild version
202 rtoy 1.92 ;;(format t "case 2: ~A ~A~%" :wild (- end 4))
203 pw 1.62 (values :wild (- end 4)))
204     (t
205 rtoy 1.82 ;; Look for a version number. Start at the end, just
206     ;; before the ~ and keep looking for digits. If the
207 rtoy 1.101 ;; first non-digit is ~, and the leading character is
208     ;; a non-zero digit, we have a version number, so get
209     ;; it. If not, we didn't find a version number, so we
210     ;; call it :newest
211 pw 1.62 (do ((i (- end 2) (1- i)))
212 rtoy 1.92 ((< i (+ start 1))
213     ;;(format t "case 3: ~A ~A~%" :newest end)
214     (values :newest end))
215 pw 1.62 (let ((char (schar namestr i)))
216     (when (eql char #\~)
217     (return (if (char= (schar namestr (1- i)) #\.)
218 rtoy 1.101 (if (char= (schar namestr (1+ i)) #\0)
219     (values nil end)
220     (values (parse-integer namestr :start (1+ i)
221     :end (1- end))
222     (1- i)))
223 pw 1.62 (values :newest end))))
224     (unless (char<= #\0 char #\9)
225 rtoy 1.92 ;; It's not a digit. Give up, and say the
226     ;; version is NIL.
227     ;;(format t "case 3 return: ~A ~A~%" nil end)
228     (return (values nil end))))))))
229 pw 1.62 (any-version (namestr start end)
230     ;; process end of string looking for a version candidate.
231     (multiple-value-bind (version where)
232 toy 1.73 (explicit-version namestr start end)
233 pw 1.62 (cond ((not (eq version :newest))
234     (values version where))
235 rtoy 1.84 ((and (not *ignore-wildcards*)
236     (>= (- end 2) start)
237 pmai 1.65 (char= (schar namestr (- end 1)) #\*)
238 pw 1.62 (char= (schar namestr (- end 2)) #\.)
239 pw 1.63 (find #\. namestr
240     :start (min (1+ start) (- end 2))
241     :end (- end 2)))
242 pw 1.62 (values :wild (- end 2)))
243     (t (values version where)))))
244     (any-type (namestr start end)
245 pw 1.63 ;; Process end of string looking for a type. A leading "."
246     ;; is part of the name.
247     (let ((where (position #\. namestr
248     :start (min (1+ start) end)
249     :end end :from-end t)))
250 pw 1.62 (when where
251     (values where end))))
252     (any-name (namestr start end)
253     (declare (ignore namestr))
254     (values start end)))
255 toy 1.73 (multiple-value-bind (version vstart)
256     (any-version namestr start end)
257     (multiple-value-bind (tstart tend)
258     (any-type namestr start vstart)
259     (multiple-value-bind (nstart nend)
260     (any-name namestr start (or tstart vstart))
261 pw 1.62 (values
262     (maybe-make-pattern namestr nstart nend)
263     (and tstart (maybe-make-pattern namestr (1+ tstart) tend))
264     version))))))
265 ram 1.1
266 ram 1.31 ;;; Take a string and return a list of cons cells that mark the char
267     ;;; separated subseq. The first value t if absolute directories location.
268     ;;;
269     (defun split-at-slashes (namestr start end)
270     (declare (type simple-base-string namestr)
271 wlott 1.16 (type index start end))
272     (let ((absolute (and (/= start end)
273 ram 1.31 (char= (schar namestr start) #\/))))
274 wlott 1.16 (when absolute
275     (incf start))
276 toy 1.73 ;; Next, split the remainder into slash separated chunks.
277 wlott 1.16 (collect ((pieces))
278     (loop
279 ram 1.31 (let ((slash (position #\/ namestr :start start :end end)))
280     (pieces (cons start (or slash end)))
281     (unless slash
282 wlott 1.16 (return))
283 ram 1.31 (setf start (1+ slash))))
284 wlott 1.16 (values absolute (pieces)))))
285 ram 1.1
286 wlott 1.16 (defun maybe-extract-search-list (namestr start end)
287     (declare (type simple-base-string namestr)
288     (type index start end))
289     (let ((quoted nil))
290     (do ((index start (1+ index)))
291     ((= index end)
292     (values nil start))
293     (if quoted
294     (setf quoted nil)
295     (case (schar namestr index)
296     (#\\
297     (setf quoted t))
298     (#\:
299     (return (values (remove-backslashes namestr start index)
300     (1+ index)))))))))
301 ram 1.1
302 wlott 1.16 (defun parse-unix-namestring (namestr start end)
303     (declare (type simple-base-string namestr)
304     (type index start end))
305     (multiple-value-bind
306     (absolute pieces)
307     (split-at-slashes namestr start end)
308     (let ((search-list
309     (if absolute
310     nil
311     (let ((first (car pieces)))
312     (multiple-value-bind
313 toy 1.73 (search-list new-start)
314 wlott 1.16 (maybe-extract-search-list namestr
315     (car first) (cdr first))
316     (when search-list
317 rtoy 1.93 ;; Lose if this search-list is already defined as
318     ;; a logical host. Since the syntax for
319     ;; search-lists and logical pathnames are the
320     ;; same, we can't allow the creation of one when
321     ;; the other is defined.
322     (when (find-logical-host search-list nil)
323     (error "~A already names a logical host" search-list))
324 wlott 1.16 (setf absolute t)
325     (setf (car first) new-start))
326     search-list)))))
327 rtoy 1.90 (multiple-value-bind (name type version)
328 wlott 1.16 (let* ((tail (car (last pieces)))
329     (tail-start (car tail))
330     (tail-end (cdr tail)))
331     (unless (= tail-start tail-end)
332     (setf pieces (butlast pieces))
333 rtoy 1.90 (cond ((string= namestr ".." :start1 tail-start :end1 tail-end)
334     ;; ".." is a directory. Add this piece to the
335     ;; list of pieces, and make the name/type/version
336     ;; nil.
337     (setf pieces (append pieces (list (cons tail-start tail-end))))
338     (values nil nil nil))
339 rtoy 1.104 ((string= namestr "." :start1 tail-start :end1 tail-end)
340     ;; "." is a directory as well.
341     (setf pieces (append pieces (list (cons tail-start tail-end))))
342     (values nil nil nil))
343 rtoy 1.90 ((not (find-if-not #'(lambda (c)
344     (char= c #\.))
345     namestr :start tail-start :end tail-end))
346 rtoy 1.104 ;; Got a bunch of dots. Make it a file of the
347     ;; same name, and type the empty string.
348     (values (subseq namestr tail-start (1- tail-end)) "" nil))
349 rtoy 1.90 (t
350     (extract-name-type-and-version namestr tail-start tail-end)))))
351 dtc 1.54 ;; PVE: Make sure there are no illegal characters in the name
352     ;; such as #\Null and #\/.
353     (when (and (stringp name)
354     (find-if #'(lambda (x)
355     (or (char= x #\Null) (char= x #\/)))
356     name))
357     (error 'parse-error))
358 wlott 1.16 ;; Now we have everything we want. So return it.
359     (values nil ; no host for unix namestrings.
360     nil ; no devices for unix namestrings.
361     (collect ((dirs))
362     (when search-list
363     (dirs (intern-search-list search-list)))
364     (dolist (piece pieces)
365     (let ((piece-start (car piece))
366     (piece-end (cdr piece)))
367     (unless (= piece-start piece-end)
368 ram 1.31 (cond ((string= namestr ".." :start1 piece-start
369 rtoy 1.104 :end1 piece-end)
370 ram 1.31 (dirs :up))
371     ((string= namestr "**" :start1 piece-start
372     :end1 piece-end)
373     (dirs :wild-inferiors))
374     (t
375     (dirs (maybe-make-pattern namestr
376     piece-start
377     piece-end)))))))
378 wlott 1.25 (cond (absolute
379     (cons :absolute (dirs)))
380     ((dirs)
381 rtoy 1.89 ;; "." in a :relative directory is the same
382     ;; as if it weren't there, so remove them.
383     (cons :relative (delete "." (dirs) :test #'equal)))
384 wlott 1.25 (t
385 rtoy 1.89 ;; If there is no directory and the name is
386 rtoy 1.104 ;; "." and the type is NIL, we really got
387     ;; directory ".", so make it so.
388     (if (and (equal name ".")
389     (null type))
390 rtoy 1.89 (list :relative)
391     nil))))
392 rtoy 1.104 ;; A file with name "." and type NIL can't be the name
393     ;; of file on Unix because it's a directory. This was
394     ;; handled above, so we can just set the name to nil.
395     (if (and (equal name ".")
396     (null type))
397 rtoy 1.89 nil
398     name)
399 wlott 1.16 type
400     version)))))
401 ram 1.1
402 wlott 1.16 (defun unparse-unix-host (pathname)
403     (declare (type pathname pathname)
404     (ignore pathname))
405 toy 1.69 ;; this host designator needs to be recognized as a physical host in
406     ;; PARSE-NAMESTRING. Until sbcl-0.7.3.x, we had "Unix" here, but
407     ;; that's a valid Logical Hostname, so that's a bad choice. -- CSR,
408     "")
409 ram 1.1
410 wlott 1.16 (defun unparse-unix-piece (thing)
411     (etypecase thing
412 ram 1.31 ((member :wild) "*")
413 rtoy 1.86 ((member :unspecific)
414     ;; CLHS 19.2.2.2.3.1 says "That is, both nil and :unspecific
415     ;; cause the component not to appear in the namestring."
416     "")
417 wlott 1.16 (simple-string
418 rtoy 1.100 (if *ignore-wildcards*
419     thing
420     (let* ((srclen (length thing))
421     (dstlen srclen))
422     (dotimes (i srclen)
423     (case (schar thing i)
424 wlott 1.16 ((#\* #\? #\[)
425 rtoy 1.100 (incf dstlen))))
426     (let ((result (make-string dstlen))
427     (dst 0))
428     (dotimes (src srclen)
429     (let ((char (schar thing src)))
430     (case char
431     ((#\* #\? #\[)
432     (setf (schar result dst) #\\)
433     (incf dst)))
434     (setf (schar result dst) char)
435     (incf dst)))
436     result))))
437 wlott 1.16 (pattern
438     (collect ((strings))
439     (dolist (piece (pattern-pieces thing))
440     (etypecase piece
441     (simple-string
442     (strings piece))
443     (symbol
444 ram 1.31 (ecase piece
445 wlott 1.16 (:multi-char-wild
446     (strings "*"))
447     (:single-char-wild
448 ram 1.31 (strings "?"))))
449 wlott 1.16 (cons
450     (case (car piece)
451     (:character-set
452     (strings "[")
453 rtoy 1.81 (strings (second piece))
454 wlott 1.16 (strings "]"))
455     (t
456     (error "Invalid pattern piece: ~S" piece))))))
457     (apply #'concatenate
458     'simple-string
459     (strings))))))
460 ram 1.1
461 wlott 1.16 (defun unparse-unix-directory-list (directory)
462     (declare (type list directory))
463     (collect ((pieces))
464     (when directory
465     (ecase (pop directory)
466     (:absolute
467     (cond ((search-list-p (car directory))
468     (pieces (search-list-name (pop directory)))
469     (pieces ":"))
470     (t
471     (pieces "/"))))
472     (:relative
473 rtoy 1.89 ;; Nothing special, except if we were given '(:relative).
474     (unless directory
475     (pieces "./"))
476 wlott 1.16 ))
477     (dolist (dir directory)
478     (typecase dir
479     ((member :up)
480     (pieces "../"))
481     ((member :back)
482     (error ":BACK cannot be represented in namestrings."))
483 ram 1.31 ((member :wild-inferiors)
484     (pieces "**/"))
485 rtoy 1.85 ((or simple-string pattern (eql :wild))
486 wlott 1.16 (pieces (unparse-unix-piece dir))
487     (pieces "/"))
488     (t
489     (error "Invalid directory component: ~S" dir)))))
490     (apply #'concatenate 'simple-string (pieces))))
491 ram 1.1
492 wlott 1.16 (defun unparse-unix-directory (pathname)
493     (declare (type pathname pathname))
494     (unparse-unix-directory-list (%pathname-directory pathname)))
495 toy 1.64
496 wlott 1.16 (defun unparse-unix-file (pathname)
497     (declare (type pathname pathname))
498     (collect ((strings))
499     (let* ((name (%pathname-name pathname))
500     (type (%pathname-type pathname))
501     (type-supplied (not (or (null type) (eq type :unspecific))))
502 toy 1.64 (logical-p (logical-pathname-p pathname))
503 wlott 1.16 (version (%pathname-version pathname))
504 rtoy 1.93 ;; Preserve version :newest for logical pathnames.
505 toy 1.73 (version-supplied (not (or (null version)
506 rtoy 1.93 (member version (if logical-p
507     '(:unspecific)
508     '(:newest
509     :unspecific)))))))
510 wlott 1.16 (when name
511 rtoy 1.97 (when (stringp name)
512     (when (find #\/ name)
513     (error "Cannot specify a directory separator in a pathname name: ~S" name))
514 rtoy 1.98 (when (and (not type-supplied)
515 rtoy 1.99 (find #\. name :start 1))
516     ;; A single leading dot is ok.
517 rtoy 1.98 (error "Cannot specify a dot in a pathname name without a pathname type: ~S" name))
518 rtoy 1.104 (when (or (and (string= ".." name)
519     (not type-supplied))
520     (and (string= "." name)
521     (not type-supplied)))
522     ;; Can't have a name of ".." or "." without a type.
523 rtoy 1.97 (error "Invalid value for a pathname name: ~S" name)))
524 wlott 1.16 (strings (unparse-unix-piece name)))
525     (when type-supplied
526     (unless name
527     (error "Cannot specify the type without a file: ~S" pathname))
528 rtoy 1.97 (when (stringp type)
529     (when (find #\/ type)
530     (error "Cannot specify a directory separator in a pathname type: ~S" type))
531     (when (find #\. type)
532     (error "Cannot specify a dot in a pathname type: ~S" type)))
533 wlott 1.16 (strings ".")
534     (strings (unparse-unix-piece type)))
535 rtoy 1.96 (when (and (not (member version '(nil :newest :unspecific)))
536     (not name))
537 rtoy 1.82 ;; We don't want version without a name, because when we try
538     ;; to read #p".~*~" back, the name is "", not NIL.
539     (error "Cannot specify a version without a file: ~S" pathname))
540 wlott 1.16 (when version-supplied
541     (strings (if (eq version :wild)
542 toy 1.64 (if logical-p ".*" ".~*~")
543 rtoy 1.93 (format nil (if logical-p ".~A" ".~~~D~~")
544 toy 1.64 version)))))
545 pw 1.55 (and (strings) (apply #'concatenate 'simple-string (strings)))))
546 ram 1.1
547 wlott 1.16 (defun unparse-unix-namestring (pathname)
548     (declare (type pathname pathname))
549     (concatenate 'simple-string
550     (unparse-unix-directory pathname)
551     (unparse-unix-file pathname)))
552 ram 1.1
553 wlott 1.16 (defun unparse-unix-enough (pathname defaults)
554     (declare (type pathname pathname defaults))
555     (flet ((lose ()
556     (error "~S cannot be represented relative to ~S"
557     pathname defaults)))
558 rtoy 1.91 ;; Only the first path in a search-list is considered.
559     (enumerate-search-list (pathname pathname)
560     (enumerate-search-list (defaults defaults)
561     (collect ((strings))
562     (let* ((pathname-directory (%pathname-directory pathname))
563     (defaults-directory (%pathname-directory defaults))
564     (prefix-len (length defaults-directory))
565     (result-dir
566     (cond ((null pathname-directory)
567 rtoy 1.92 ;; No directory, so relative to default. But
568     ;; if we're relative to default, NIL is as
569     ;; good as '(:relative) and it results in a
570     ;; shorter namestring.
571     #+nil (list :relative)
572     nil)
573 rtoy 1.91 ((and (>= prefix-len 1)
574 toy 1.72 (>= (length pathname-directory) prefix-len)
575     (compare-component (subseq pathname-directory
576     0 prefix-len)
577     defaults-directory))
578 rtoy 1.94 ;; Pathname starts with a prefix of default,
579     ;; which also means both are either :relative
580     ;; or :absolute directories. So just use a
581     ;; relative directory from then on out.
582     (let ((dir-tail (nthcdr prefix-len pathname-directory)))
583     ;; If both directories are identical, don't
584     ;; return just :relative. Returning NIL
585     ;; results in a shorter string.
586     (if dir-tail
587     (cons :relative dir-tail)
588     nil)))
589     ((and (eq (car pathname-directory) :relative)
590     (not (eq (car defaults-directory) :absolute)))
591     ;; Can't represent a relative directory
592     ;; relative to an absolute directory. But
593     ;; there's no problem if both are relative;
594     ;; we just return our path.
595     pathname-directory)
596 rtoy 1.91 ((eq (car pathname-directory) :absolute)
597     ;; We are an absolute pathname, so we can just use it.
598     pathname-directory)
599     (t
600     ;; We are a relative directory. So we lose.
601     (lose)))))
602     (strings (unparse-unix-directory-list result-dir)))
603     (let* ((pathname-version (%pathname-version pathname))
604     (version-needed (and pathname-version
605     (not (eq pathname-version :newest))))
606     (pathname-type (%pathname-type pathname))
607     (type-needed (or version-needed
608     (and pathname-type
609     (not (eq pathname-type :unspecific)))))
610     (pathname-name (%pathname-name pathname))
611     (name-needed (or type-needed
612     (and pathname-name
613     (not (compare-component pathname-name
614     (%pathname-name
615     defaults)))))))
616     (when name-needed
617     (unless pathname-name (lose))
618     (strings (unparse-unix-piece pathname-name)))
619     (when type-needed
620     (when (or (null pathname-type) (eq pathname-type :unspecific))
621     (lose))
622     (strings ".")
623     (strings (unparse-unix-piece pathname-type)))
624     (when version-needed
625     (typecase pathname-version
626     ((member :wild)
627     (strings ".~*~"))
628     (integer
629     (strings (format nil ".~~~D~~" pathname-version)))
630     (t
631     (lose)))))
632     (return-from unparse-unix-enough (apply #'concatenate 'simple-string (strings))))))))
633 ram 1.1
634    
635 wlott 1.16 (defstruct (unix-host
636     (:include host
637     (:parse #'parse-unix-namestring)
638     (:unparse #'unparse-unix-namestring)
639     (:unparse-host #'unparse-unix-host)
640     (:unparse-directory #'unparse-unix-directory)
641     (:unparse-file #'unparse-unix-file)
642     (:unparse-enough #'unparse-unix-enough)
643     (:customary-case :lower))
644     (:make-load-form-fun make-unix-host-load-form))
645     )
646 ram 1.1
647 wlott 1.16 (defvar *unix-host* (make-unix-host))
648 ram 1.1
649 wlott 1.16 (defun make-unix-host-load-form (host)
650     (declare (ignore host))
651     '*unix-host*)
652 ram 1.1
653 wlott 1.16
654     ;;;; Wildcard matching stuff.
655 ram 1.1
656 wlott 1.16 (defmacro enumerate-matches ((var pathname &optional result
657 dtc 1.57 &key (verify-existance t) (follow-links t))
658 wlott 1.16 &body body)
659     (let ((body-name (gensym)))
660     `(block nil
661     (flet ((,body-name (,var)
662     ,@body))
663     (%enumerate-matches (pathname ,pathname)
664 dtc 1.57 ,verify-existance ,follow-links
665 wlott 1.16 #',body-name)
666     ,result))))
667 ram 1.1
668 dtc 1.57 (defun %enumerate-matches (pathname verify-existance follow-links function)
669 ram 1.34 (when (pathname-type pathname)
670     (unless (pathname-name pathname)
671     (error "Cannot supply a type without a name:~% ~S" pathname)))
672     (let ((directory (pathname-directory pathname)))
673     (if directory
674     (ecase (car directory)
675     (:absolute
676     (%enumerate-directories "/" (cdr directory) pathname
677 dtc 1.57 verify-existance follow-links
678     nil function))
679 ram 1.34 (:relative
680     (%enumerate-directories "" (cdr directory) pathname
681 dtc 1.57 verify-existance follow-links
682     nil function)))
683 ram 1.34 (%enumerate-files "" pathname verify-existance function))))
684 ram 1.1
685 dtc 1.57 ;;; %enumerate-directories -- Internal
686     ;;;
687     ;;; The directory node and device numbers are maintained for the current path
688 toy 1.73 ;;; during the search for the detection of path loops upon :wild-inferiors.
689 dtc 1.57 ;;;
690     (defun %enumerate-directories (head tail pathname verify-existance
691     follow-links nodes function)
692 ram 1.37 (declare (simple-string head))
693 dtc 1.57 (macrolet ((unix-xstat (name)
694     `(if follow-links
695     (unix:unix-stat ,name)
696     (unix:unix-lstat ,name)))
697     (with-directory-node-noted ((head) &body body)
698     `(multiple-value-bind (res dev ino mode)
699     (unix-xstat ,head)
700     (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
701     (let ((nodes (cons (cons dev ino) nodes)))
702     ,@body))))
703     (do-directory-entries ((name directory) &body body)
704     `(let ((dir (unix:open-dir ,directory)))
705     (when dir
706     (unwind-protect
707     (loop
708     (let ((,name (unix:read-dir dir)))
709     (cond ((null ,name)
710     (return))
711     ((string= ,name "."))
712     ((string= ,name ".."))
713     (t
714     ,@body))))
715     (unix:close-dir dir))))))
716     (if tail
717     (let ((piece (car tail)))
718     (etypecase piece
719     (simple-string
720     (let ((head (concatenate 'string head piece)))
721     (with-directory-node-noted (head)
722     (%enumerate-directories (concatenate 'string head "/")
723     (cdr tail) pathname
724     verify-existance follow-links
725     nodes function))))
726     ((member :wild-inferiors)
727     (%enumerate-directories head (rest tail) pathname
728     verify-existance follow-links
729     nodes function)
730     (do-directory-entries (name head)
731     (let ((subdir (concatenate 'string head name)))
732     (multiple-value-bind (res dev ino mode)
733     (unix-xstat subdir)
734     (declare (type (or fixnum null) mode))
735     (when (and res (eql (logand mode unix:s-ifmt) unix:s-ifdir))
736     (unless (dolist (dir nodes nil)
737     (when (and (eql (car dir) dev)
738     (eql (cdr dir) ino))
739     (return t)))
740     (let ((nodes (cons (cons dev ino) nodes))
741     (subdir (concatenate 'string subdir "/")))
742     (%enumerate-directories subdir tail pathname
743     verify-existance follow-links
744     nodes function))))))))
745     ((or pattern (member :wild))
746     (do-directory-entries (name head)
747     (when (or (eq piece :wild) (pattern-matches piece name))
748     (let ((subdir (concatenate 'string head name)))
749     (multiple-value-bind (res dev ino mode)
750     (unix-xstat subdir)
751     (declare (type (or fixnum null) mode))
752     (when (and res
753     (eql (logand mode unix:s-ifmt) unix:s-ifdir))
754     (let ((nodes (cons (cons dev ino) nodes))
755     (subdir (concatenate 'string subdir "/")))
756     (%enumerate-directories subdir (rest tail) pathname
757     verify-existance follow-links
758     nodes function))))))))
759     ((member :up)
760     (let ((head (concatenate 'string head "..")))
761     (with-directory-node-noted (head)
762     (%enumerate-directories (concatenate 'string head "/")
763     (rest tail) pathname
764     verify-existance follow-links
765     nodes function))))))
766     (%enumerate-files head pathname verify-existance function))))
767 ram 1.1
768 wlott 1.16 (defun %enumerate-files (directory pathname verify-existance function)
769 ram 1.37 (declare (simple-string directory))
770 ram 1.36 (let ((name (%pathname-name pathname))
771     (type (%pathname-type pathname))
772     (version (%pathname-version pathname)))
773 ram 1.33 (cond ((member name '(nil :unspecific))
774 wlott 1.16 (when (or (not verify-existance)
775 wlott 1.26 (unix:unix-file-kind directory))
776 wlott 1.16 (funcall function directory)))
777     ((or (pattern-p name)
778     (pattern-p type)
779 ram 1.33 (eq name :wild)
780 rtoy 1.84 (eq type :wild)
781     (eq version :wild))
782 wlott 1.26 (let ((dir (unix:open-dir directory)))
783 wlott 1.16 (when dir
784     (unwind-protect
785     (loop
786 wlott 1.26 (let ((file (unix:read-dir dir)))
787 wlott 1.16 (if file
788 wlott 1.21 (unless (or (string= file ".")
789     (string= file ".."))
790     (multiple-value-bind
791     (file-name file-type file-version)
792     (let ((*ignore-wildcards* t))
793     (extract-name-type-and-version
794     file 0 (length file)))
795 toy 1.76 ;; Match also happens if the file has
796     ;; no explicit version and we're asking
797     ;; for version :NEWEST, since that's
798     ;; what no version means.
799 wlott 1.21 (when (and (components-match file-name name)
800     (components-match file-type type)
801 toy 1.76 (or (components-match file-version
802     version)
803     (and (eq file-version nil)
804     (eq version :newest))))
805 wlott 1.21 (funcall function
806     (concatenate 'string
807     directory
808     file)))))
809 wlott 1.16 (return))))
810 wlott 1.26 (unix:close-dir dir)))))
811 wlott 1.16 (t
812     (let ((file (concatenate 'string directory name)))
813 wlott 1.19 (unless (or (null type) (eq type :unspecific))
814 wlott 1.16 (setf file (concatenate 'string file "." type)))
815 toy 1.68 (unless (member version '(nil :newest :wild :unspecific))
816 toy 1.66 (setf file (concatenate 'string file ".~"
817     (quick-integer-to-string version)
818     "~")))
819 wlott 1.16 (when (or (not verify-existance)
820 ram 1.40 (unix:unix-file-kind file t))
821 wlott 1.16 (funcall function file)))))))
822 ram 1.1
823     (defun quick-integer-to-string (n)
824 wlott 1.16 (declare (type integer n))
825 ram 1.38 (cond ((not (fixnump n))
826     (write-to-string n :base 10 :radix nil))
827     ((zerop n) "0")
828 ram 1.1 ((eql n 1) "1")
829     ((minusp n)
830     (concatenate 'simple-string "-"
831     (the simple-string (quick-integer-to-string (- n)))))
832     (t
833     (do* ((len (1+ (truncate (integer-length n) 3)))
834     (res (make-string len))
835     (i (1- len) (1- i))
836     (q n)
837     (r 0))
838     ((zerop q)
839     (incf i)
840     (replace res res :start2 i :end2 len)
841 wlott 1.3 (shrink-vector res (- len i)))
842 ram 1.1 (declare (simple-string res)
843 ram 1.38 (fixnum len i r q))
844 ram 1.1 (multiple-value-setq (q r) (truncate q 10))
845     (setf (schar res i) (schar "0123456789" r))))))
846    
847 wlott 1.16
848     ;;;; UNIX-NAMESTRING -- public
849 wlott 1.5 ;;;
850 wlott 1.39 (defun unix-namestring (pathname &optional (for-input t) executable-only)
851 wlott 1.16 "Convert PATHNAME into a string that can be used with UNIX system calls.
852 pw 1.56 Search-lists and wild-cards are expanded. If optional argument
853     FOR-INPUT is true and PATHNAME doesn't exist, NIL is returned.
854     If optional argument EXECUTABLE-ONLY is true, NIL is returned
855     unless an executable version of PATHNAME exists."
856 ram 1.41 ;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
857     ;; pathnames too.
858     (let ((path (let ((lpn (pathname pathname)))
859     (if (logical-pathname-p lpn)
860     (namestring (translate-logical-pathname lpn))
861     pathname))))
862 wlott 1.16 (enumerate-search-list
863 ram 1.41 (pathname path)
864 wlott 1.16 (collect ((names))
865 dtc 1.57 (enumerate-matches (name pathname nil :verify-existance for-input
866     :follow-links t)
867 wlott 1.39 (when (or (not executable-only)
868     (and (eq (unix:unix-file-kind name) :file)
869     (unix:unix-access name unix:x_ok)))
870     (names name)))
871 wlott 1.16 (let ((names (names)))
872     (when names
873     (when (cdr names)
874 dtc 1.54 (error 'simple-file-error
875     :format-control "~S is ambiguous:~{~% ~A~}"
876     :format-arguments (list pathname names)))
877 ram 1.41 (return (car names))))))))
878 wlott 1.4
879 ram 1.1
880 wlott 1.16 ;;;; TRUENAME and PROBE-FILE.
881 ram 1.1
882     ;;; Truename -- Public
883     ;;;
884 wlott 1.4 ;;; Another silly file function trivially different from another function.
885 ram 1.1 ;;;
886     (defun truename (pathname)
887     "Return the pathname for the actual file described by the pathname
888 pw 1.47 An error of type file-error is signalled if no such file exists,
889     or the pathname is wild."
890     (if (wild-pathname-p pathname)
891 pw 1.51 (error 'simple-file-error
892 pw 1.47 :format-control "Bad place for a wild pathname."
893     :pathname pathname)
894     (let ((result (probe-file pathname)))
895     (unless result
896 pw 1.51 (error 'simple-file-error
897 pw 1.47 :pathname pathname
898     :format-control "The file ~S does not exist."
899     :format-arguments (list (namestring pathname))))
900     result)))
901 ram 1.1
902     ;;; Probe-File -- Public
903     ;;;
904 toy 1.71 ;;; If PATHNAME exists, return its truename, otherwise NIL.
905 ram 1.1 ;;;
906     (defun probe-file (pathname)
907     "Return a pathname which is the truename of the file if it exists, NIL
908 toy 1.73 otherwise. An error of type file-error is signalled if pathname is wild."
909 pw 1.47 (if (wild-pathname-p pathname)
910 pw 1.51 (error 'simple-file-error
911 pw 1.47 :pathname pathname
912     :format-control "Bad place for a wild pathname.")
913 toy 1.78 (let ((namestring (unix-namestring (merge-pathnames pathname) t)))
914 pw 1.47 (when (and namestring (unix:unix-file-kind namestring))
915     (let ((truename (unix:unix-resolve-links
916     (unix:unix-maybe-prepend-current-directory
917     namestring))))
918     (when truename
919     (let ((*ignore-wildcards* t))
920     (pathname (unix:unix-simplify-pathname truename)))))))))
921 ram 1.1
922    
923 wlott 1.4 ;;;; Other random operations.
924 ram 1.1
925     ;;; Rename-File -- Public
926     ;;;
927     (defun rename-file (file new-name)
928     "Rename File to have the specified New-Name. If file is a stream open to a
929 ram 1.35 file, then the associated file is renamed."
930 wlott 1.4 (let* ((original (truename file))
931 wlott 1.16 (original-namestring (unix-namestring original t))
932 wlott 1.4 (new-name (merge-pathnames new-name original))
933     (new-namestring (unix-namestring new-name nil)))
934 wlott 1.17 (unless new-namestring
935 pw 1.51 (error 'simple-file-error
936 pw 1.47 :pathname new-name
937     :format-control "~S can't be created."
938     :format-arguments (list new-name)))
939 wlott 1.4 (multiple-value-bind (res error)
940 wlott 1.26 (unix:unix-rename original-namestring
941 wlott 1.4 new-namestring)
942     (unless res
943 pw 1.51 (error 'simple-file-error
944 pw 1.47 :pathname new-name
945     :format-control "Failed to rename ~A to ~A: ~A"
946     :format-arguments (list original new-name
947     (unix:get-unix-error-msg error))))
948 wlott 1.4 (when (streamp file)
949     (file-name file new-namestring))
950 wlott 1.16 (values new-name original (truename new-name)))))
951 ram 1.1
952     ;;; Delete-File -- Public
953     ;;;
954     ;;; Delete the file, Man.
955     ;;;
956     (defun delete-file (file)
957     "Delete the specified file."
958 wlott 1.4 (let ((namestring (unix-namestring file t)))
959 ram 1.1 (when (streamp file)
960 rtoy 1.79 ;; Close the file, but don't try to revert or anything. We want
961     ;; to delete it, man!
962     (close file))
963 ram 1.24 (unless namestring
964 pw 1.51 (error 'simple-file-error
965 pw 1.47 :pathname file
966     :format-control "~S doesn't exist."
967     :format-arguments (list file)))
968 ram 1.24
969 wlott 1.26 (multiple-value-bind (res err) (unix:unix-unlink namestring)
970 ram 1.24 (unless res
971 pw 1.51 (error 'simple-file-error
972 pw 1.47 :pathname namestring
973     :format-control "Could not delete ~A: ~A."
974     :format-arguments (list namestring
975     (unix:get-unix-error-msg err))))))
976 ram 1.1 t)
977 wlott 1.4
978 toy 1.75 ;;; Purge-Backup-Files -- Public
979 toy 1.73 ;;;
980     ;;; Purge old file versions
981     ;;;
982 toy 1.75 (defun purge-backup-files (pathname &optional (keep 0))
983 toy 1.73 "Delete old versions of files matching the given Pathname,
984     optionally keeping some of the most recent old versions."
985     (declare (type (or pathname string stream) pathname)
986     (type (integer 0 *) keep))
987     (let ((hash (make-hash-table :test 'equal)))
988     (enumerate-search-list
989     (path (make-pathname :version :wild :defaults pathname))
990     (clrhash hash)
991     (enumerate-matches (name path nil :follow-links nil)
992     (let ((dot (position #\. name :from-end t))
993     (len (length name)))
994     (when (and dot
995     (> len (+ dot 3))
996     (char= (char name (1+ dot)) #\~)
997     (char= (char name (1- len)) #\~)
998     (eq (unix:unix-file-kind name) :file))
999     (multiple-value-bind (version next)
1000     (parse-integer name :start (+ dot 2) :end (1- len)
1001     :junk-allowed t)
1002     (when (and version (= next (1- len)))
1003     (push (cons version name)
1004     (gethash (subseq name 0 dot) hash '())))))))
1005     (maphash (lambda (key value)
1006     (declare (ignore key))
1007     (mapc #'unix:unix-unlink
1008     (mapcar #'cdr (nthcdr keep
1009     (sort value #'> :key #'car)))))
1010     hash))))
1011    
1012 ram 1.1
1013     ;;; User-Homedir-Pathname -- Public
1014     ;;;
1015 ram 1.12 ;;; Return Home:, which is set up for us at initialization time.
1016 ram 1.1 ;;;
1017     (defun user-homedir-pathname (&optional host)
1018     "Returns the home directory of the logged in user as a pathname.
1019 ram 1.12 This is obtained from the logical name \"home:\"."
1020 ram 1.1 (declare (ignore host))
1021 ram 1.12 #p"home:")
1022 ram 1.1
1023     ;;; File-Write-Date -- Public
1024     ;;;
1025     (defun file-write-date (file)
1026 pw 1.47 "Return file's creation date, or NIL if it doesn't exist.
1027 toy 1.73 An error of type file-error is signalled if file is a wild pathname"
1028 pw 1.47 (if (wild-pathname-p file)
1029 pw 1.51 (error 'simple-file-error
1030 pw 1.47 :pathname file
1031     :format-control "Bad place for a wild pathname.")
1032     (let ((name (unix-namestring file t)))
1033     (when name
1034     (multiple-value-bind
1035     (res dev ino mode nlink uid gid rdev size atime mtime)
1036     (unix:unix-stat name)
1037     (declare (ignore dev ino mode nlink uid gid rdev size atime))
1038     (when res
1039     (+ unix-to-universal-time mtime)))))))
1040 ram 1.1
1041     ;;; File-Author -- Public
1042     ;;;
1043     (defun file-author (file)
1044     "Returns the file author as a string, or nil if the author cannot be
1045 pw 1.47 determined. Signals an error of type file-error if file doesn't exist,
1046     or file is a wild pathname."
1047     (if (wild-pathname-p file)
1048 pw 1.51 (error 'simple-file-error
1049 pw 1.47 :pathname file
1050 emarsden 1.80 :format-control "Bad place for a wild pathname.")
1051 pw 1.47 (let ((name (unix-namestring (pathname file) t)))
1052     (unless name
1053 pw 1.51 (error 'simple-file-error
1054 pw 1.47 :pathname file
1055     :format-control "~S doesn't exist."
1056     :format-arguments (list file)))
1057     (multiple-value-bind (winp dev ino mode nlink uid)
1058     (unix:unix-stat name)
1059     (declare (ignore dev ino mode nlink))
1060 toy 1.71 (when winp
1061     (let ((user-info (unix:unix-getpwuid uid)))
1062     (when user-info
1063     (unix:user-info-name user-info))))))))
1064 ram 1.1
1065    
1066     ;;;; DIRECTORY.
1067    
1068 wlott 1.4 ;;; DIRECTORY -- public.
1069 toy 1.71 ;;;
1070 ram 1.23 (defun directory (pathname &key (all t) (check-for-subdirs t)
1071 dtc 1.58 (truenamep t) (follow-links t))
1072 ram 1.1 "Returns a list of pathnames, one for each file that matches the given
1073 ram 1.23 pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This
1074 dtc 1.58 never includes Unix dot and dot-dot in the result. If :TRUENAMEP is NIL,
1075 toy 1.73 then symbolic links in the result are not expanded, which is not the
1076     default because TRUENAME does follow links and the result pathnames are
1077 ram 1.23 defined to be the TRUENAME of the pathname (the truename of a link may well
1078 toy 1.73 be in another directory). If FOLLOW-LINKS is NIL then symbolic links are
1079 dtc 1.58 not followed."
1080 wlott 1.16 (let ((results nil))
1081     (enumerate-search-list
1082 wlott 1.21 (pathname (merge-pathnames pathname
1083     (make-pathname :name :wild
1084     :type :wild
1085 toy 1.77 :version :wild
1086     :defaults *default-pathname-defaults*)
1087 toy 1.75 :wild))
1088 dtc 1.57 (enumerate-matches (name pathname nil :follow-links follow-links)
1089 wlott 1.16 (when (or all
1090     (let ((slash (position #\/ name :from-end t)))
1091     (or (null slash)
1092     (= (1+ slash) (length name))
1093     (char/= (schar name (1+ slash)) #\.))))
1094     (push name results))))
1095     (let ((*ignore-wildcards* t))
1096     (mapcar #'(lambda (name)
1097 ram 1.23 (let ((name (if (and check-for-subdirs
1098 wlott 1.26 (eq (unix:unix-file-kind name)
1099 ram 1.23 :directory))
1100     (concatenate 'string name "/")
1101     name)))
1102 dtc 1.58 (if truenamep (truename name) (pathname name))))
1103 wlott 1.16 (sort (delete-duplicates results :test #'string=) #'string<)))))
1104 ram 1.1
1105 wlott 1.4
1106     ;;;; Printing directories.
1107 ram 1.1
1108     ;;; PRINT-DIRECTORY is exported from the EXTENSIONS package.
1109     ;;;
1110     (defun print-directory (pathname &optional stream &key all verbose return-list)
1111 toy 1.73 "Like Directory, but prints a terse, multi-column directory listing
1112 ram 1.1 instead of returning a list of pathnames. When :all is supplied and
1113 toy 1.73 non-nil, then Unix dot files are included too (as ls -a). When :verbose
1114 ram 1.1 is supplied and non-nil, then a long listing of miscellaneous
1115     information is output one file per line."
1116 dtc 1.50 (let ((*standard-output* (out-synonym-of stream))
1117 wlott 1.16 (pathname pathname))
1118 ram 1.1 (if verbose
1119     (print-directory-verbose pathname all return-list)
1120     (print-directory-formatted pathname all return-list))))
1121    
1122     (defun print-directory-verbose (pathname all return-list)
1123 ram 1.23 (let ((contents (directory pathname :all all :check-for-subdirs nil
1124 dtc 1.58 :truenamep nil))
1125 wlott 1.7 (result nil))
1126 toy 1.73 (format t "Directory of ~A:~%" (namestring pathname))
1127 wlott 1.7 (dolist (file contents)
1128     (let* ((namestring (unix-namestring file))
1129     (tail (subseq namestring
1130     (1+ (or (position #\/ namestring
1131     :from-end t
1132     :test #'char=)
1133     -1)))))
1134     (multiple-value-bind
1135     (reslt dev-or-err ino mode nlink uid gid rdev size atime mtime)
1136 wlott 1.26 (unix:unix-stat namestring)
1137 wlott 1.7 (declare (ignore ino gid rdev atime)
1138     (fixnum uid mode))
1139     (cond (reslt
1140     ;;
1141     ;; Print characters for file modes.
1142     (macrolet ((frob (bit name &optional sbit sname negate)
1143     `(if ,(if negate
1144     `(not (logbitp ,bit mode))
1145     `(logbitp ,bit mode))
1146     ,(if sbit
1147     `(if (logbitp ,sbit mode)
1148     (write-char ,sname)
1149     (write-char ,name))
1150     `(write-char ,name))
1151     (write-char #\-))))
1152     (frob 15 #\d nil nil t)
1153     (frob 8 #\r)
1154     (frob 7 #\w)
1155     (frob 6 #\x 11 #\s)
1156     (frob 5 #\r)
1157     (frob 4 #\w)
1158     (frob 3 #\x 10 #\s)
1159     (frob 2 #\r)
1160     (frob 1 #\w)
1161     (frob 0 #\x))
1162     ;;
1163     ;; Print the rest.
1164     (multiple-value-bind (sec min hour date month year)
1165     (get-decoded-time)
1166     (declare (ignore sec min hour date month))
1167     (format t "~2D ~8A ~8D ~12A ~A~@[/~]~%"
1168     nlink
1169 toy 1.71 (let ((user-info (unix:unix-getpwuid uid)))
1170     (if user-info (unix:user-info-name user-info) uid))
1171 wlott 1.7 size
1172     (decode-universal-time-for-files mtime year)
1173     tail
1174 wlott 1.27 (= (logand mode unix:s-ifmt) unix:s-ifdir))))
1175 wlott 1.7 (t (format t "Couldn't stat ~A -- ~A.~%"
1176     tail
1177 wlott 1.26 (unix:get-unix-error-msg dev-or-err))))
1178 ram 1.1 (when return-list
1179 wlott 1.27 (push (if (= (logand mode unix:s-ifmt) unix:s-ifdir)
1180 wlott 1.7 (pathname (concatenate 'string namestring "/"))
1181     file)
1182     result)))))
1183     (nreverse result)))
1184 ram 1.1
1185     (defun decode-universal-time-for-files (time current-year)
1186     (multiple-value-bind (sec min hour day month year)
1187     (decode-universal-time (+ time unix-to-universal-time))
1188     (declare (ignore sec))
1189     (format nil "~A ~2,' D ~:[ ~D~;~*~2,'0D:~2,'0D~]"
1190     (svref '#("Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug"
1191     "Sep" "Oct" "Nov" "Dec")
1192     (1- month))
1193     day (= current-year year) year hour min)))
1194    
1195     (defun print-directory-formatted (pathname all return-list)
1196     (let ((width (or (line-length *standard-output*) 80))
1197     (names ())
1198     (cnt 0)
1199     (max-len 0)
1200 dtc 1.58 (result (directory pathname :all all :truenamep nil)))
1201 ram 1.1 (declare (list names) (fixnum max-len cnt))
1202     ;;
1203     ;; Get the data.
1204 wlott 1.7 (dolist (file result)
1205     (let* ((name (unix-namestring file))
1206     (length (length name))
1207     (end (if (and (plusp length)
1208     (char= (schar name (1- length)) #\/))
1209     (1- length)
1210     length))
1211     (slash-name (subseq name
1212     (1+ (or (position #\/ name
1213     :from-end t
1214     :end end
1215     :test #'char=)
1216     -1))))
1217     (len (length slash-name)))
1218     (declare (simple-string slash-name)
1219     (fixnum len))
1220     (if (> len max-len) (setq max-len len))
1221     (incf cnt)
1222     (push slash-name names)))
1223     (setq names (nreverse names))
1224     ;;
1225     ;; Do the output.
1226     (let* ((col-width (1+ max-len))
1227     (cols (max (truncate width col-width) 1))
1228     (lines (ceiling cnt cols)))
1229     (declare (fixnum cols lines))
1230 toy 1.73 (format t "Directory of ~A:~%" (namestring pathname))
1231 wlott 1.7 (dotimes (i lines)
1232     (declare (fixnum i))
1233     (dotimes (j cols)
1234     (declare (fixnum j))
1235     (let ((name (nth (+ i (the fixnum (* j lines))) names)))
1236     (when name
1237     (write-string name)
1238     (unless (eql j (1- cols))
1239 wlott 1.15 (dotimes (i (- col-width (length (the simple-string name))))
1240     (write-char #\space))))))
1241 wlott 1.7 (terpri)))
1242     (when return-list
1243     result)))
1244 ram 1.1
1245    
1246 wlott 1.4 ;;;; File completion.
1247 ram 1.1
1248 chiles 1.13 ;;; COMPLETE-FILE -- Public
1249     ;;;
1250 wlott 1.4 (defun complete-file (pathname &key (defaults *default-pathname-defaults*)
1251     ignore-types)
1252 wlott 1.22 (let ((files (directory (complete-file-directory-arg pathname defaults)
1253 ram 1.23 :check-for-subdirs nil
1254 dtc 1.58 :truenamep nil)))
1255 wlott 1.4 (cond ((null files)
1256     (values nil nil))
1257     ((null (cdr files))
1258     (values (merge-pathnames (file-namestring (car files))
1259     pathname)
1260     t))
1261     (t
1262     (let ((good-files
1263     (delete-if #'(lambda (pathname)
1264 wlott 1.16 (and (simple-string-p
1265     (pathname-type pathname))
1266 wlott 1.4 (member (pathname-type pathname)
1267     ignore-types
1268     :test #'string=)))
1269     files)))
1270     (cond ((null good-files))
1271     ((null (cdr good-files))
1272     (return-from complete-file
1273     (values (merge-pathnames (file-namestring
1274     (car good-files))
1275     pathname)
1276     t)))
1277     (t
1278     (setf files good-files)))
1279     (let ((common (file-namestring (car files))))
1280     (dolist (file (cdr files))
1281     (let ((name (file-namestring file)))
1282     (dotimes (i (min (length common) (length name))
1283     (when (< (length name) (length common))
1284     (setf common name)))
1285     (unless (char= (schar common i) (schar name i))
1286     (setf common (subseq common 0 i))
1287     (return)))))
1288     (values (merge-pathnames common pathname)
1289     nil)))))))
1290 ram 1.1
1291 chiles 1.13 ;;; COMPLETE-FILE-DIRECTORY-ARG -- Internal.
1292     ;;;
1293     (defun complete-file-directory-arg (pathname defaults)
1294 wlott 1.22 (let* ((pathname (merge-pathnames pathname (directory-namestring defaults)))
1295 wlott 1.16 (type (pathname-type pathname)))
1296     (flet ((append-multi-char-wild (thing)
1297     (etypecase thing
1298     (null :wild)
1299     (pattern
1300     (make-pattern (append (pattern-pieces thing)
1301     (list :multi-char-wild))))
1302     (simple-string
1303     (make-pattern (list thing :multi-char-wild))))))
1304     (if (or (null type) (eq type :unspecific))
1305     ;; There is no type.
1306     (make-pathname :defaults pathname
1307     :name (append-multi-char-wild (pathname-name pathname))
1308     :type :wild)
1309     ;; There already is a type, so just extend it.
1310     (make-pathname :defaults pathname
1311     :name (pathname-name pathname)
1312     :type (append-multi-char-wild (pathname-type pathname)))))))
1313 chiles 1.13
1314 wlott 1.4 ;;; Ambiguous-Files -- Public
1315 ram 1.1 ;;;
1316 wlott 1.16 (defun ambiguous-files (pathname
1317     &optional (defaults *default-pathname-defaults*))
1318 wlott 1.4 "Return a list of all files which are possible completions of Pathname.
1319 chiles 1.13 We look in the directory specified by Defaults as well as looking down
1320     the search list."
1321 wlott 1.16 (directory (complete-file-directory-arg pathname defaults)
1322 dtc 1.58 :truenamep nil
1323 wlott 1.16 :check-for-subdirs nil))
1324 wlott 1.4
1325 wlott 1.16
1326 ram 1.1
1327     ;;; File-writable -- exported from extensions.
1328     ;;;
1329     ;;; Determines whether the single argument (which should be a pathname)
1330 dtc 1.46 ;;; can be written by the current task.
1331 wlott 1.16 ;;;
1332 ram 1.1 (defun file-writable (name)
1333     "File-writable accepts a pathname and returns T if the current
1334     process can write it, and NIL otherwise."
1335 wlott 1.16 (let ((name (unix-namestring name nil)))
1336 wlott 1.17 (cond ((null name)
1337     nil)
1338 wlott 1.26 ((unix:unix-file-kind name)
1339     (values (unix:unix-access name unix:w_ok)))
1340 wlott 1.17 (t
1341     (values
1342 wlott 1.26 (unix:unix-access (subseq name
1343 wlott 1.17 0
1344     (or (position #\/ name :from-end t)
1345     0))
1346 wlott 1.26 (logior unix:w_ok unix:x_ok)))))))
1347 ram 1.1
1348    
1349     ;;; Pathname-Order -- Internal
1350     ;;;
1351     ;;; Predicate to order pathnames by. Goes by name.
1352     ;;;
1353     (defun pathname-order (x y)
1354     (let ((xn (%pathname-name x))
1355     (yn (%pathname-name y)))
1356     (if (and xn yn)
1357     (let ((res (string-lessp xn yn)))
1358     (cond ((not res) nil)
1359     ((= res (length (the simple-string xn))) t)
1360     ((= res (length (the simple-string yn))) nil)
1361     (t t)))
1362     xn)))
1363    
1364    
1365     ;;; Default-Directory -- Public
1366     ;;;
1367 fgilham 1.103 #+ (and)
1368 fgilham 1.102 (defun default-directory ()
1369     "Returns the pathname for the default directory. This is the place where
1370     a file will be written if no directory is specified. This may be changed
1371     with setf."
1372     (multiple-value-bind (gr dir-or-error)
1373     (unix:unix-current-directory)
1374     (if gr
1375     (let ((*ignore-wildcards* t))
1376     (values
1377     (parse-namestring (concatenate 'simple-string dir-or-error "/")
1378     *unix-host*)))
1379     (error dir-or-error))))
1380 fgilham 1.103
1381 fgilham 1.102 ;;;
1382     ;;; XXXX This code was modified by me (fmg) to avoid calling
1383     ;;; concatenate. The reason for this is that there have been
1384     ;;; intermittent instabilities (segv on startup) when the function
1385     ;;; environment-init (in save.lisp) is called. Apparently the type
1386     ;;; system is not completely sorted out at the time this function is
1387     ;;; first called. As a result, strange, not completely reproducable
1388     ;;; things happen, related to something in the state of the
1389     ;;; environment (e.g. the paths or the user environment variables or
1390     ;;; something). These errors occur in the course of calling
1391     ;;; default-directory and the backtrace indicates they occur in the
1392     ;;; context of the type system. Since I haven't been able to figure
1393     ;;; out why they happen, I decided to punt.
1394     ;;;
1395     ;;; Hopefully someone will really fix the problem someday.
1396     ;;;
1397 fgilham 1.103 ;;; Seems like maybe it's fixed by changes made by Ray Toy to avoid heap corruption.
1398     #- (and)
1399 ram 1.1 (defun default-directory ()
1400     "Returns the pathname for the default directory. This is the place where
1401     a file will be written if no directory is specified. This may be changed
1402     with setf."
1403     (multiple-value-bind (gr dir-or-error)
1404 wlott 1.26 (unix:unix-current-directory)
1405 ram 1.1 (if gr
1406 fgilham 1.102 (let ((*ignore-wildcards* t)
1407     (string (make-string (1+ (length dir-or-error)) :initial-element #\/)))
1408 toy 1.70 (values
1409 fgilham 1.102 (parse-namestring (replace string dir-or-error) *unix-host*)))
1410 wlott 1.3 (error dir-or-error))))
1411 ram 1.1
1412 fgilham 1.102
1413    
1414    
1415 ram 1.1 ;;; %Set-Default-Directory -- Internal
1416     ;;;
1417     (defun %set-default-directory (new-val)
1418 wlott 1.17 (let ((namestring (unix-namestring new-val t)))
1419     (unless namestring
1420 toy 1.67 (error 'simple-file-error
1421     :format-control "~S doesn't exist."
1422     :format-arguments (list new-val)))
1423 wlott 1.17 (multiple-value-bind (gr error)
1424 wlott 1.26 (unix:unix-chdir namestring)
1425 wlott 1.17 (if gr
1426     (setf (search-list "default:") (default-directory))
1427 wlott 1.26 (error (unix:get-unix-error-msg error))))
1428 wlott 1.17 new-val))
1429 wlott 1.16 ;;;
1430     (defsetf default-directory %set-default-directory)
1431    
1432     (defun filesys-init ()
1433 toy 1.74 ;; Use :unspecific so we don't create file versions whenever merging
1434     ;; happens. If the user wants that, let him change
1435     ;; *default-pathname-defaults* appropriately.
1436 wlott 1.16 (setf *default-pathname-defaults*
1437 toy 1.74 (%make-pathname *unix-host* nil nil nil nil :unspecific))
1438 wlott 1.16 (setf (search-list "default:") (default-directory))
1439     nil)
1440 dtc 1.42
1441     ;;; Ensure-Directories-Exist -- Public
1442     ;;;
1443     (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
1444 pw 1.44 "Tests whether the directories containing the specified file
1445     actually exist, and attempts to create them if they do not.
1446     Portable programs should avoid using the :MODE keyword argument."
1447 dtc 1.43 (let* ((pathname (pathname pathspec))
1448     (pathname (if (logical-pathname-p pathname)
1449     (translate-logical-pathname pathname)
1450     pathname))
1451     (created-p nil))
1452     (when (wild-pathname-p pathname)
1453 pw 1.51 (error 'simple-file-error
1454 pw 1.47 :format-control "Bad place for a wild pathname."
1455     :pathname pathspec))
1456 dtc 1.45 (enumerate-search-list (pathname pathname)
1457     (let ((dir (pathname-directory pathname)))
1458     (loop for i from 1 upto (length dir)
1459     do (let ((newpath (make-pathname
1460     :host (pathname-host pathname)
1461     :device (pathname-device pathname)
1462     :directory (subseq dir 0 i))))
1463 rtoy 1.87 (tagbody
1464     retry
1465     (restart-case
1466     (unless (probe-file newpath)
1467     (let ((namestring (namestring newpath)))
1468     (when verbose
1469     (format *standard-output* "~&Creating directory: ~A~%"
1470     namestring))
1471     (unix:unix-mkdir namestring mode)
1472     (unless (probe-file namestring)
1473     (error 'simple-file-error
1474     :pathname pathspec
1475     :format-control "Can't create directory ~A."
1476     :format-arguments (list namestring)))
1477     (setf created-p t)))
1478     (retry () :report "Try to create the directory again"
1479     (go retry))))))
1480 dtc 1.45 ;; Only the first path in a search-list is considered.
1481     (return (values pathname created-p))))))

  ViewVC Help
Powered by ViewVC 1.1.5