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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5