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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5