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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.89 - (show annotations)
Mon Sep 12 14:38:17 2005 UTC (8 years, 7 months ago) by rtoy
Branch: MAIN
Changes since 1.88: +18 -5 lines
Fix some issues with printing (make-pathname :directory '(:relative)),
which used to print as #p"", and with reading #p".", #p"./".

code/filesys.lisp:
o When parsing a unix namestring, delete any "." elements of the
  directory list.
o If we've parsed a namestring such that the file name is ".", replace
  that with :name NIL and adjust the :directory component
  appropriately, because on Unix, "." can't be the name of a file.
o Make :directory '(:relative) be printed as "./"

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

  ViewVC Help
Powered by ViewVC 1.1.5