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

Contents of /src/code/filesys.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.114 - (show annotations)
Tue Mar 1 04:32:58 2011 UTC (3 years, 1 month ago) by rtoy
Branch: MAIN
CVS Tags: GIT-CONVERSION, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-03, HEAD
Changes since 1.113: +1 -34 lines
Remove commented-out DEFAULT-DIRECTORY written by fmg.

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

  ViewVC Help
Powered by ViewVC 1.1.5