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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.90 - (hide annotations)
Wed Sep 21 20:01:34 2005 UTC (8 years, 6 months ago) by rtoy
Branch: MAIN
Changes since 1.89: +15 -4 lines
code/filesys.lisp:

o Make the #p reader treat ".." as a directory, not a file.
o Make the #p reader treat "<lots of dots>" be a file with that name
  instead of name with one fewer dot and type "".  So #p"..." has
  :name "...", :type nil instead of :name "..", :type "".

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

  ViewVC Help
Powered by ViewVC 1.1.5