1 ;;;; file system interface functions -- fairly Unix-centric, but with
2 ;;;; differences between Unix and Win32 papered over.
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
13 (in-package "SB!IMPL")
15 ;;;; Unix pathname host support
17 ;;; FIXME: the below shouldn't really be here, but in documentation
18 ;;; (chapter 19 makes a lot of requirements for documenting
19 ;;; implementation-dependent decisions), but anyway it's probably not
20 ;;; what we currently do.
22 ;;; Unix namestrings have the following format:
24 ;;; namestring := [ directory ] [ file [ type [ version ]]]
25 ;;; directory := [ "/" ] { file "/" }*
27 ;;; type := "." [^/.]*
28 ;;; version := "." ([0-9]+ | "*")
30 ;;; Note: this grammar is ambiguous. The string foo.bar.5 can be
31 ;;; parsed as either just the file specified or as specifying the
32 ;;; file, type, and version. Therefore, we use the following rules
33 ;;; when confronted with an ambiguous file.type.version string:
35 ;;; - If the first character is a dot, it's part of the file. It is not
36 ;;; considered a dot in the following rules.
38 ;;; - Otherwise, the last dot separates the file and the type.
40 ;;; Wildcard characters:
42 ;;; If the directory, file, type components contain any of the
43 ;;; following characters, it is considered part of a wildcard pattern
44 ;;; and has the following meaning.
46 ;;; ? - matches any one character
47 ;;; * - matches any zero or more characters.
48 ;;; [abc] - matches any of a, b, or c.
49 ;;; {str1,str2,...,strn} - matches any of str1, str2, ..., or strn.
50 ;;; (FIXME: no it doesn't)
52 ;;; Any of these special characters can be preceded by a backslash to
53 ;;; cause it to be treated as a regular character.
54 (defun remove-backslashes (namestr start end)
56 "Remove any occurrences of #\\ from the string because we've already
57 checked for whatever they may have protected."
58 (declare (type simple-string namestr)
59 (type index start end))
60 (let* ((result (make-string (- end start) :element-type 'character))
63 (do ((src start (1+ src)))
66 (setf (schar result dst) (schar namestr src))
70 (let ((char (schar namestr src)))
71 (cond ((char= char #\\)
74 (setf (schar result dst) char)
77 (error 'namestring-parse-error
78 :complaint "backslash in a bad place"
81 (%shrink-vector result dst)))
83 (defvar *ignore-wildcards* nil)
85 (/show0 "filesys.lisp 86")
87 (defun maybe-make-pattern (namestr start end)
88 (declare (type simple-string namestr)
89 (type index start end))
90 (if *ignore-wildcards*
91 (subseq namestr start end)
95 (last-regular-char nil)
97 (flet ((flush-pending-regulars ()
98 (when last-regular-char
99 (pattern (if any-quotes
100 (remove-backslashes namestr
103 (subseq namestr last-regular-char index)))
104 (setf any-quotes nil)
105 (setf last-regular-char nil))))
109 (let ((char (schar namestr index)))
116 (unless last-regular-char
117 (setf last-regular-char index))
120 (flush-pending-regulars)
121 (pattern :single-char-wild)
124 (flush-pending-regulars)
125 (pattern :multi-char-wild)
128 (flush-pending-regulars)
130 (position #\] namestr :start index :end end)))
131 (unless close-bracket
132 (error 'namestring-parse-error
133 :complaint "#\\[ with no corresponding #\\]"
136 (pattern (cons :character-set
140 (setf index (1+ close-bracket))))
142 (unless last-regular-char
143 (setf last-regular-char index))
145 (flush-pending-regulars)))
146 (cond ((null (pattern))
148 ((null (cdr (pattern)))
149 (let ((piece (first (pattern))))
151 ((member :multi-char-wild) :wild)
152 (simple-string piece)
154 (make-pattern (pattern))))))
156 (make-pattern (pattern)))))))
158 (/show0 "filesys.lisp 160")
160 (defun extract-name-type-and-version (namestr start end)
161 (declare (type simple-string namestr)
162 (type index start end))
163 (let* ((last-dot (position #\. namestr :start (1+ start) :end end
167 (values (maybe-make-pattern namestr start last-dot)
168 (maybe-make-pattern namestr (1+ last-dot) end)
171 (values (maybe-make-pattern namestr start end)
175 (/show0 "filesys.lisp 200")
178 ;;;; wildcard matching stuff
180 ;;; Return a list of all the Lispy filenames (not including e.g. the
181 ;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME.
182 (defun directory-lispy-filenames (directory-name)
183 (with-alien ((adlf (* c-string)
184 (alien-funcall (extern-alien
185 "alloc_directory_lispy_filenames"
186 (function (* c-string) c-string))
188 (if (null-alien adlf)
189 (error 'simple-file-error
190 :pathname directory-name
191 :format-control "~@<couldn't read directory ~S: ~2I~_~A~:>"
192 :format-arguments (list directory-name (strerror)))
194 (c-strings->string-list adlf)
195 (alien-funcall (extern-alien "free_directory_lispy_filenames"
196 (function void (* c-string)))
199 (/show0 "filesys.lisp 498")
201 ;; TODO: the implementation !enumerate-matches is some hairy stuff
202 ;; that we mostly don't need. Couldn't we use POSIX fts(3) to walk
203 ;; the file system and PATHNAME-MATCH-P to select matches, at least on
205 (defmacro !enumerate-matches ((var pathname &optional result
206 &key (verify-existence t)
210 (%enumerate-matches (pathname ,pathname)
213 (lambda (,var) ,@body))
216 (/show0 "filesys.lisp 500")
218 ;;; Call FUNCTION on matches.
220 ;;; KLUDGE: this assumes that an absolute pathname is indicated to the
221 ;;; operating system by having a directory separator as the first
222 ;;; character in the directory part. This is true for Win32 pathnames
223 ;;; and for Unix pathnames, but it isn't true for LispM pathnames (and
224 ;;; their bastard offspring, logical pathnames. Also it assumes that
225 ;;; Unix pathnames have an empty or :unspecific device, and that
226 ;;; windows drive letters are the only kinds of non-empty/:UNSPECIFIC
228 (defun %enumerate-matches (pathname verify-existence follow-links function)
229 (/noshow0 "entering %ENUMERATE-MATCHES")
230 (when (pathname-type pathname)
231 (unless (pathname-name pathname)
232 (error "cannot supply a type without a name:~% ~S" pathname)))
233 (when (and (integerp (pathname-version pathname))
234 (member (pathname-type pathname) '(nil :unspecific)))
235 (error "cannot supply a version without a type:~% ~S" pathname))
236 (let ((host (pathname-host pathname))
237 (device (pathname-device pathname))
238 (directory (pathname-directory pathname)))
239 (/noshow0 "computed HOST and DIRECTORY")
240 (let* ((dirstring (if directory
241 (ecase (first directory)
242 (:absolute (host-unparse-directory-separator host))
245 (devstring (if (and device (not (eq device :unspecific)))
246 (concatenate 'simple-string (string device) (string #\:))
248 (headstring (concatenate 'simple-string devstring dirstring)))
250 (%enumerate-directories headstring (rest directory) pathname
251 verify-existence follow-links nil function)
252 (%enumerate-files headstring pathname verify-existence function)))))
254 ;;; Call FUNCTION on directories.
255 (defun %enumerate-directories (head tail pathname verify-existence
256 follow-links nodes function
257 &aux (host (pathname-host pathname)))
258 (declare (simple-string head))
260 (setf follow-links nil)
261 (macrolet ((unix-xstat (name)
263 (sb!unix:unix-stat ,name)
264 (sb!unix:unix-lstat ,name)))
265 (with-directory-node-noted ((head) &body body)
266 `(multiple-value-bind (res dev ino mode)
268 (when (and res (eql (logand mode sb!unix:s-ifmt)
270 (let ((nodes (cons (cons dev ino) nodes)))
272 (with-directory-node-removed ((head) &body body)
273 `(multiple-value-bind (res dev ino mode)
275 (when (and res (eql (logand mode sb!unix:s-ifmt)
277 (let ((nodes (remove (cons dev ino) nodes :test #'equal)))
280 (let ((piece (car tail)))
283 (let ((head (concatenate 'string head piece)))
284 (with-directory-node-noted (head)
285 (%enumerate-directories
286 (concatenate 'string head
287 (host-unparse-directory-separator host))
289 verify-existence follow-links
291 ((member :wild-inferiors)
292 ;; now with extra error case handling from CLHS
293 ;; 19.2.2.4.3 -- CSR, 2004-01-24
294 (when (member (cadr tail) '(:up :back))
295 (error 'simple-file-error
297 :format-control "~@<invalid use of ~S after :WILD-INFERIORS~@:>."
298 :format-arguments (list (cadr tail))))
299 (%enumerate-directories head (rest tail) pathname
300 verify-existence follow-links
302 (dolist (name (directory-lispy-filenames head))
303 (let ((subdir (concatenate 'string head name)))
304 (multiple-value-bind (res dev ino mode)
306 (declare (type (or fixnum null) mode))
307 (when (and res (eql (logand mode sb!unix:s-ifmt)
309 (unless (dolist (dir nodes nil)
310 (when (and (eql (car dir) dev)
315 (let ((nodes (cons (cons dev ino) nodes))
316 (subdir (concatenate 'string subdir (host-unparse-directory-separator host))))
317 (%enumerate-directories subdir tail pathname
318 verify-existence follow-links
319 nodes function))))))))
320 ((or pattern (member :wild))
321 (dolist (name (directory-lispy-filenames head))
322 (when (or (eq piece :wild) (pattern-matches piece name))
323 (let ((subdir (concatenate 'string head name)))
324 (multiple-value-bind (res dev ino mode)
326 (declare (type (or fixnum null) mode))
328 (eql (logand mode sb!unix:s-ifmt)
330 (let ((nodes (cons (cons dev ino) nodes))
331 (subdir (concatenate 'string subdir (host-unparse-directory-separator host))))
332 (%enumerate-directories subdir (rest tail) pathname
333 verify-existence follow-links
334 nodes function))))))))
336 (when (string= head (host-unparse-directory-separator host))
337 (error 'simple-file-error
339 :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
340 (with-directory-node-removed (head)
341 (let ((head (concatenate 'string head "..")))
342 (with-directory-node-noted (head)
343 (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host))
345 verify-existence follow-links
348 ;; :WILD-INFERIORS is handled above, so the only case here
349 ;; should be (:ABSOLUTE :BACK)
350 (aver (string= head (host-unparse-directory-separator host)))
351 (error 'simple-file-error
353 :format-control "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))
354 (%enumerate-files head pathname verify-existence function))))
356 ;;; Call FUNCTION on files.
357 (defun %enumerate-files (directory pathname verify-existence function)
358 (declare (simple-string directory))
359 (/noshow0 "entering %ENUMERATE-FILES")
360 (let ((name (%pathname-name pathname))
361 (type (%pathname-type pathname))
362 (version (%pathname-version pathname)))
363 (/noshow0 "computed NAME, TYPE, and VERSION")
364 (cond ((member name '(nil :unspecific))
365 (/noshow0 "UNSPECIFIC, more or less")
366 (let ((directory (coerce directory 'string)))
367 (when (or (not verify-existence)
368 (sb!unix:unix-file-kind directory))
369 (funcall function directory))))
370 ((or (pattern-p name)
374 (/noshow0 "WILD, more or less")
375 ;; I IGNORE-ERRORS here just because the original CMU CL
376 ;; code did. I think the intent is that it's not an error
377 ;; to request matches to a wild pattern when no matches
378 ;; exist, but I haven't tried to figure out whether
379 ;; everything is kosher. (E.g. what if we try to match a
380 ;; wildcard but we don't have permission to read one of the
381 ;; relevant directories?) -- WHN 2001-04-17
382 (dolist (complete-filename (ignore-errors
383 (directory-lispy-filenames directory)))
385 (file-name file-type file-version)
386 (let ((*ignore-wildcards* t))
387 (extract-name-type-and-version
388 complete-filename 0 (length complete-filename)))
389 (when (and (components-match file-name name)
390 (components-match file-type type)
391 (components-match file-version version))
395 complete-filename))))))
397 (/noshow0 "default case")
398 (let ((file (concatenate 'string directory name)))
399 (/noshow "computed basic FILE")
400 (unless (or (null type) (eq type :unspecific))
401 (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
402 (setf file (concatenate 'string file "." type)))
403 (unless (member version '(nil :newest :wild :unspecific))
404 (/noshow0 "tweaking FILE for more-or-less-:WILD case")
405 (setf file (concatenate 'string file "."
406 (quick-integer-to-string version))))
407 (/noshow0 "finished possibly tweaking FILE")
408 (when (or (not verify-existence)
409 (sb!unix:unix-file-kind file t))
410 (/noshow0 "calling FUNCTION on FILE")
411 (funcall function file)))))))
413 (/noshow0 "filesys.lisp 603")
415 ;;; FIXME: Why do we need this?
416 (defun quick-integer-to-string (n)
417 (declare (type integer n))
418 (cond ((not (fixnump n))
419 (write-to-string n :base 10 :radix nil))
423 (concatenate 'simple-base-string "-"
424 (the simple-base-string (quick-integer-to-string (- n)))))
426 (do* ((len (1+ (truncate (integer-length n) 3)))
427 (res (make-string len :element-type 'base-char))
433 (replace res res :start2 i :end2 len)
434 (%shrink-vector res (- len i)))
435 (declare (simple-string res)
437 (multiple-value-setq (q r) (truncate q 10))
438 (setf (schar res i) (schar "0123456789" r))))))
440 ;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE.
442 ;;; Rewritten in 12/2007 by RMK, replacing 13+ year old CMU code that
443 ;;; made a mess of things in order to support search lists (which SBCL
444 ;;; has never had). These are now all relatively straightforward
445 ;;; wrappers around stat(2) and realpath(2), with the same basic logic
446 ;;; in all cases. The wrinkles to be aware of:
448 ;;; * SBCL defines the truename of an existing, dangling or
449 ;;; self-referring symlink to be the symlink itself.
450 ;;; * The old version of PROBE-FILE merged the pathspec against
451 ;;; *DEFAULT-PATHNAME-DEFAULTS* twice, and so lost when *D-P-D*
452 ;;; was a relative pathname. Even if the case where *D-P-D* is a
453 ;;; relative pathname is problematic, there's no particular reason
454 ;;; to get that wrong, so let's try not to.
455 ;;; * Note that while stat(2) is probably atomic, getting the truename
456 ;;; for a filename involves poking all over the place, and so is
457 ;;; subject to race conditions if other programs mutate the file
458 ;;; system while we're resolving symlinks. So it's not implausible for
459 ;;; realpath(3) to fail even if stat(2) succeeded. There's nothing
460 ;;; obvious we can do about this, however.
461 ;;; * Windows' apparent analogue of realpath(3) is called
462 ;;; GetFullPathName, and it's a bit less useful than realpath(3).
463 ;;; In particular, while realpath(3) errors in case the file doesn't
464 ;;; exist, GetFullPathName seems to return a filename in all cases.
465 ;;; As realpath(3) is not atomic anyway, we only ever call it when
466 ;;; we think a file exists, so just be careful when rewriting this
469 ;;; Given a pathname designator, some quality to query for, return one
470 ;;; of a pathname, a universal time, or a string (a file-author), or
471 ;;; NIL. QUERY-FOR may be one of :TRUENAME, :EXISTENCE, :WRITE-DATE,
472 ;;; :AUTHOR. If ERRORP is false, return NIL in case the file system
473 ;;; returns an error code; otherwise, signal an error. Accepts
474 ;;; logical pathnames, too (but never returns LPNs). For internal
476 (defun query-file-system (pathspec query-for &optional (errorp t))
477 (let ((pathname (translate-logical-pathname
480 (sane-default-pathname-defaults)))))
481 (when (wild-pathname-p pathname)
482 (error 'simple-file-error
484 :format-control "~@<can't find the ~A of wild pathname ~A~
485 (physicalized from ~A).~:>"
486 :format-arguments (list query-for pathname pathspec)))
487 (flet ((fail (note-format pathname errno)
489 (simple-file-perror note-format pathname errno)
490 (return-from query-file-system nil))))
491 (let ((filename (native-namestring pathname :as-file t)))
492 (multiple-value-bind (existsp errno ino mode nlink uid gid rdev size
494 (sb!unix:unix-stat filename)
495 (declare (ignore ino nlink gid rdev size atime))
498 (:existence (nth-value
500 (parse-native-namestring
502 (pathname-host pathname)
503 (sane-default-pathname-defaults)
504 :as-directory (eql (logand mode sb!unix:s-ifmt)
506 (:truename (nth-value
508 (parse-native-namestring
509 ;; Note: in case the file is stat'able, POSIX
510 ;; realpath(3) gets us a canonical absolute
511 ;; filename, even if the post-merge PATHNAME
512 ;; is not absolute...
513 (multiple-value-bind (realpath errno)
514 (sb!unix:unix-realpath filename)
517 (fail "couldn't resolve ~A" filename errno)))
518 (pathname-host pathname)
519 (sane-default-pathname-defaults)
520 ;; ... but without any trailing slash.
521 :as-directory (eql (logand mode sb!unix:s-ifmt)
523 (:author (sb!unix:uid-username uid))
524 (:write-date (+ unix-to-universal-time mtime)))
526 ;; SBCL has for many years had a policy that a pathname
527 ;; that names an existing, dangling or self-referential
528 ;; symlink denotes the symlink itself. stat(2) fails
529 ;; and sets errno to ENOENT or ELOOP respectively, but
530 ;; we must distinguish cases where the symlink exists
531 ;; from ones where there's a loop in the apparent
532 ;; containing directory.
534 (multiple-value-bind (linkp ignore ino mode nlink uid gid rdev
536 (sb!unix:unix-lstat filename)
537 (declare (ignore ignore ino mode nlink gid rdev size atime))
538 (when (and (or (= errno sb!unix:enoent)
539 (= errno sb!unix:eloop))
541 (return-from query-file-system
544 ;; We do this reparse so as to return a
545 ;; normalized pathname.
546 (parse-native-namestring
547 filename (pathname-host pathname)))
549 ;; So here's a trick: since lstat succeded,
550 ;; FILENAME exists, so its directory exists and
551 ;; only the non-directory part is loopy. So
552 ;; let's resolve FILENAME's directory part with
553 ;; realpath(3), in order to get a canonical
554 ;; absolute name for the directory, and then
555 ;; return a pathname having PATHNAME's name,
556 ;; type, and version, but the rest from the
557 ;; truename of the directory. Since we turned
558 ;; PATHNAME into FILENAME "as a file", FILENAME
559 ;; does not end in a slash, and so we get the
560 ;; directory part of FILENAME by reparsing
561 ;; FILENAME and masking off its name, type, and
562 ;; version bits. But note not to call ourselves
563 ;; recursively, because we don't want to
564 ;; re-merge against *DEFAULT-PATHNAME-DEFAULTS*,
565 ;; since PATHNAME may be a relative pathname.
569 (parse-native-namestring
570 (multiple-value-bind (realpath errno)
571 (sb!unix:unix-realpath
577 :defaults (parse-native-namestring
579 (pathname-host pathname)
580 (sane-default-pathname-defaults)))))
583 (fail "couldn't resolve ~A" filename errno)))
584 (pathname-host pathname)
585 (sane-default-pathname-defaults)
588 (:author (sb!unix:uid-username uid))
589 (:write-date (+ unix-to-universal-time mtime))))))
590 ;; If we're still here, the file doesn't exist; error.
592 (format nil "failed to find the ~A of ~~A" query-for)
593 pathspec errno))))))))
596 (defun probe-file (pathspec)
598 "Return the truename of PATHSPEC if the truename can be found,
599 or NIL otherwise. See TRUENAME for more information."
600 (query-file-system pathspec :truename nil))
602 (defun truename (pathspec)
604 "If PATHSPEC is a pathname that names an existing file, return
605 a pathname that denotes a canonicalized name for the file. If
606 pathspec is a stream associated with a file, return a pathname
607 that denotes a canonicalized name for the file associated with
610 An error of type FILE-ERROR is signalled if no such file exists
611 or if the file system is such that a canonicalized file name
612 cannot be determined or if the pathname is wild.
614 Under Unix, the TRUENAME of a symlink that links to itself or to
615 a file that doesn't exist is considered to be the name of the
616 broken symlink itself."
617 ;; Note that eventually this routine might be different for streams
618 ;; than for other pathname designators.
619 (if (streamp pathspec)
620 (query-file-system pathspec :truename)
621 (query-file-system pathspec :truename)))
623 (defun file-author (pathspec)
625 "Return the author of the file specified by PATHSPEC. Signal an
626 error of type FILE-ERROR if no such file exists, or if PATHSPEC
628 (query-file-system pathspec :author))
630 (defun file-write-date (pathspec)
632 "Return the write date of the file specified by PATHSPEC.
633 An error of type FILE-ERROR is signaled if no such file exists,
634 or if PATHSPEC is a wild pathname."
635 (query-file-system pathspec :write-date))
637 ;;;; miscellaneous other operations
639 (/show0 "filesys.lisp 700")
641 (defun rename-file (file new-name)
643 "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a
644 file, then the associated file is renamed."
645 (let* ((original (truename file))
646 (original-namestring (native-namestring original :as-file t))
647 (new-name (merge-pathnames new-name original))
648 (new-namestring (native-namestring new-name :as-file t)))
649 (unless new-namestring
650 (error 'simple-file-error
652 :format-control "~S can't be created."
653 :format-arguments (list new-name)))
654 (multiple-value-bind (res error)
655 (sb!unix:unix-rename original-namestring new-namestring)
657 (error 'simple-file-error
659 :format-control "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
661 :format-arguments (list original new-name (strerror error))))
663 (file-name file new-name))
664 (values new-name original (truename new-name)))))
666 (defun delete-file (file)
668 "Delete the specified FILE."
669 (let* ((truename (probe-file file))
670 (namestring (when truename
671 (native-namestring truename :as-file t))))
673 (close file :abort t))
675 (error 'simple-file-error
677 :format-control "~S doesn't exist."
678 :format-arguments (list file)))
679 (multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
681 (simple-file-perror "couldn't delete ~A" namestring err))))
684 (defun sbcl-homedir-pathname ()
685 (let ((sbcl-home (posix-getenv "SBCL_HOME")))
686 ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores
687 (when (and sbcl-home (not (string= sbcl-home "")))
688 (parse-native-namestring sbcl-home
689 #!-win32 sb!impl::*unix-host*
690 #!+win32 sb!impl::*win32-host*
691 *default-pathname-defaults*
694 ;;; (This is an ANSI Common Lisp function.)
695 (defun user-homedir-pathname (&optional host)
697 "Return the home directory of the user as a pathname. If the HOME
698 environment variable has been specified, the directory it designates
699 is returned; otherwise obtains the home directory from the operating
701 (declare (ignore host))
702 (let ((env-home (posix-getenv "HOME")))
704 (parse-native-namestring
705 (if (and env-home (not (string= env-home "")))
708 (sb!unix:uid-homedir (sb!unix:unix-getuid))
710 ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH
711 ;; What?! -- RMK, 2007-12-31
712 (return-from user-homedir-pathname
713 (sb!win32::get-folder-pathname sb!win32::csidl_profile)))
714 #!-win32 sb!impl::*unix-host*
715 #!+win32 sb!impl::*win32-host*
716 *default-pathname-defaults*
722 (/show0 "filesys.lisp 800")
724 ;;; NOTE: There is a fair amount of hair below that is probably not
725 ;;; strictly necessary.
727 ;;; The issue is the following: what does (DIRECTORY "SYS:*;") mean?
728 ;;; Until 2004-01, SBCL's behaviour was unquestionably wrong, as it
729 ;;; did not translate the logical pathname at all, but instead treated
730 ;;; it as a physical one. Other Lisps seem to to treat this call as
731 ;;; equivalent to (DIRECTORY (TRANSLATE-LOGICAL-PATHNAME "SYS:*;")),
732 ;;; which is fine as far as it goes, but not very interesting, and
733 ;;; arguably counterintuitive. (PATHNAME-MATCH-P "SYS:SRC;" "SYS:*;")
734 ;;; is true, so why should "SYS:SRC;" not show up in the call to
735 ;;; DIRECTORY? (assuming the physical pathname corresponding to it
736 ;;; exists, of course).
738 ;;; So, the interpretation that I am pushing is for all pathnames
739 ;;; matching the input pathname to be queried. This means that we
740 ;;; need to compute the intersection of the input pathname and the
741 ;;; logical host FROM translations, and then translate the resulting
742 ;;; pathname using the host to the TO translation; this treatment is
743 ;;; recursively invoked until we get a physical pathname, whereupon
744 ;;; our physical DIRECTORY implementation takes over.
746 ;;; FIXME: this is an incomplete implementation. It only works when
747 ;;; both are logical pathnames (which is OK, because that's the only
748 ;;; case when we call it), but there are other pitfalls as well: see
749 ;;; the DIRECTORY-HELPER below for some, but others include a lack of
750 ;;; pattern handling.
752 ;;; The above was written by CSR, I (RMK) believe. The argument that
753 ;;; motivates the interpretation is faulty, however: PATHNAME-MATCH-P
754 ;;; returns true for (PATHNAME-MATCH-P #P"/tmp/*/" #P"/tmp/../"), but
755 ;;; the latter pathname is not in the result of DIRECTORY on the
756 ;;; former. Indeed, if DIRECTORY were constrained to return the
757 ;;; truename for every pathname for which PATHNAME-MATCH-P returned
758 ;;; true and which denoted a filename that named an existing file,
759 ;;; (DIRECTORY #P"/tmp/**/") would be required to list every file on a
760 ;;; Unix system, since any file can be named as though it were "below"
761 ;;; /tmp, given the dotdot entries. So I think the strongest
762 ;;; "consistency" we can define between PATHNAME-MATCH-P and DIRECTORY
763 ;;; is that PATHNAME-MATCH-P returns true of everything DIRECTORY
764 ;;; returns, but not vice versa.
766 ;;; In any case, even if the motivation were sound, DIRECTORY on a
767 ;;; wild logical pathname has no portable semantics. I see nothing in
768 ;;; ANSI that requires implementations to support wild physical
769 ;;; pathnames, and so there need not be any translation of a wild
770 ;;; logical pathname to a phyiscal pathname. So a program that calls
771 ;;; DIRECTORY on a wild logical pathname is doing something
772 ;;; non-portable at best. And if the only sensible semantics for
773 ;;; DIRECTORY on a wild logical pathname is something like the
774 ;;; following, it would be just as well if it signaled an error, since
775 ;;; a program can't possibly rely on the result of an intersection of
776 ;;; user-defined translations with a file system probe. (Potentially
777 ;;; useful kinds of "pathname" that might not support wildcards could
778 ;;; include pathname hosts that model unqueryable namespaces like HTTP
779 ;;; URIs, or that model namespaces that it's not convenient to
780 ;;; investigate, such as the namespace of TCP ports that some network
781 ;;; host listens on. I happen to think it a bad idea to try to
782 ;;; shoehorn such namespaces into a pathnames system, but people
783 ;;; sometimes claim to want pathnames for these things.) -- RMK
786 (defun pathname-intersections (one two)
787 (aver (logical-pathname-p one))
788 (aver (logical-pathname-p two))
790 ((intersect-version (one two)
791 (aver (typep one '(or null (member :newest :wild :unspecific)
793 (aver (typep two '(or null (member :newest :wild :unspecific)
798 ((or (null one) (eq one :unspecific)) two)
799 ((or (null two) (eq two :unspecific)) one)
802 (intersect-name/type (one two)
803 (aver (typep one '(or null (member :wild :unspecific) string)))
804 (aver (typep two '(or null (member :wild :unspecific) string)))
808 ((or (null one) (eq one :unspecific)) two)
809 ((or (null two) (eq two :unspecific)) one)
810 ((string= one two) one)
812 (intersect-directory (one two)
813 (aver (typep one '(or null (member :wild :unspecific) list)))
814 (aver (typep two '(or null (member :wild :unspecific) list)))
818 ((or (null one) (eq one :unspecific)) two)
819 ((or (null two) (eq two :unspecific)) one)
820 (t (aver (eq (car one) (car two)))
822 (lambda (x) (cons (car one) x))
823 (intersect-directory-helper (cdr one) (cdr two)))))))
824 (let ((version (intersect-version
825 (pathname-version one) (pathname-version two)))
826 (name (intersect-name/type
827 (pathname-name one) (pathname-name two)))
828 (type (intersect-name/type
829 (pathname-type one) (pathname-type two)))
830 (host (pathname-host one)))
832 (make-pathname :host host :name name :type type
833 :version version :directory d))
835 (pathname-directory one) (pathname-directory two))))))
837 ;;; FIXME: written as its own function because I (CSR) don't
838 ;;; understand it, so helping both debuggability and modularity. In
839 ;;; case anyone is motivated to rewrite it, it returns a list of
840 ;;; sublists representing the intersection of the two input directory
841 ;;; paths (excluding the initial :ABSOLUTE or :RELATIVE).
843 ;;; FIXME: Does not work with :UP or :BACK
844 ;;; FIXME: Does not work with patterns
846 ;;; FIXME: PFD suggests replacing this implementation with a DFA
847 ;;; conversion of a NDFA. Find out (a) what this means and (b) if it
848 ;;; turns out to be worth it.
849 (defun intersect-directory-helper (one two)
850 (flet ((simple-intersection (cone ctwo)
852 ((eq cone :wild) ctwo)
853 ((eq ctwo :wild) cone)
854 (t (aver (typep cone 'string))
855 (aver (typep ctwo 'string))
856 (if (string= cone ctwo) cone nil)))))
858 ((loop-possible-wild-inferiors-matches
859 (lower-bound bounding-sequence order)
860 (let ((index (gensym)) (g2 (gensym)) (g3 (gensym)) (l (gensym)))
861 `(let ((,l (length ,bounding-sequence)))
862 (loop for ,index from ,lower-bound to ,l
863 append (mapcar (lambda (,g2)
865 (butlast ,bounding-sequence (- ,l ,index))
870 (if (eq (car (nthcdr ,index ,bounding-sequence))
874 (intersect-directory-helper
876 `((nthcdr ,index one) (cdr two))
877 `((cdr one) (nthcdr ,index two)))))))))))
879 ((and (eq (car one) :wild-inferiors)
880 (eq (car two) :wild-inferiors))
882 (append (mapcar (lambda (x) (cons :wild-inferiors x))
883 (intersect-directory-helper (cdr one) (cdr two)))
884 (loop-possible-wild-inferiors-matches 2 one t)
885 (loop-possible-wild-inferiors-matches 2 two nil))
887 ((eq (car one) :wild-inferiors)
888 (delete-duplicates (loop-possible-wild-inferiors-matches 0 two nil)
890 ((eq (car two) :wild-inferiors)
891 (delete-duplicates (loop-possible-wild-inferiors-matches 0 one t)
893 ((and (null one) (null two)) (list nil))
896 (t (and (simple-intersection (car one) (car two))
897 (mapcar (lambda (x) (cons (simple-intersection
898 (car one) (car two)) x))
899 (intersect-directory-helper (cdr one) (cdr two)))))))))
901 (defun directory (pathname &key (resolve-symlinks t))
903 "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
904 given pathname. Note that the interaction between this ANSI-specified
905 TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
906 means this function can sometimes return files which don't have the same
907 directory as PATHNAME. If :RESOLVE-SYMLINKS is NIL, don't resolve
908 symbolic links in matching filenames."
909 (let (;; We create one entry in this hash table for each truename,
910 ;; as an asymptotically efficient way of removing duplicates
911 ;; (which can arise when e.g. multiple symlinks map to the
913 (filenames (make-hash-table :test #'equal))
914 ;; FIXME: Possibly this MERGE-PATHNAMES call should only
915 ;; happen once we get a physical pathname.
916 (merged-pathname (merge-pathnames pathname)))
917 (labels ((do-physical-directory (pathname)
918 (aver (not (logical-pathname-p pathname)))
919 (!enumerate-matches (match pathname)
920 (let* ((*ignore-wildcards* t)
921 ;; FIXME: Why not TRUENAME? As reported by
922 ;; Milan Zamazal sbcl-devel 2003-10-05, using
923 ;; TRUENAME causes a race condition whereby
924 ;; removal of a file during the directory
925 ;; operation causes an error. It's not clear
926 ;; what the right thing to do is, though. --
928 (filename (if resolve-symlinks
929 (query-file-system match :truename nil)
930 (query-file-system match :existence nil))))
932 (setf (gethash (namestring filename) filenames)
934 (do-directory (pathname)
935 (if (logical-pathname-p pathname)
936 (let ((host (intern-logical-host (pathname-host pathname))))
937 (dolist (x (logical-host-canon-transls host))
938 (destructuring-bind (from to) x
940 (pathname-intersections pathname from)))
941 (dolist (p intersections)
942 (do-directory (translate-pathname p from to)))))))
943 (do-physical-directory pathname))))
944 (do-directory merged-pathname))
946 ;; Sorting isn't required by the ANSI spec, but sorting
947 ;; into some canonical order seems good just on the
948 ;; grounds that the implementation should have repeatable
949 ;; behavior when possible.
950 (sort (loop for name being each hash-key in filenames
951 using (hash-value filename)
952 collect (cons name filename))
956 (/show0 "filesys.lisp 899")
958 ;;; predicate to order pathnames by; goes by name
959 ;; FIXME: Does anything use this? It's not exported, and I don't find
960 ;; the name anywhere else.
961 (defun pathname-order (x y)
962 (let ((xn (%pathname-name x))
963 (yn (%pathname-name y)))
965 (let ((res (string-lessp xn yn)))
966 (cond ((not res) nil)
967 ((= res (length (the simple-string xn))) t)
968 ((= res (length (the simple-string yn))) nil)
972 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
974 "Test whether the directories containing the specified file
975 actually exist, and attempt to create them if they do not.
976 The MODE argument is a CMUCL/SBCL-specific extension to control
977 the Unix permission bits."
978 (let ((pathname (physicalize-pathname (merge-pathnames (pathname pathspec))))
980 (when (wild-pathname-p pathname)
981 (error 'simple-file-error
982 :format-control "bad place for a wild pathname"
984 (let ((dir (pathname-directory pathname)))
985 (loop for i from 1 upto (length dir)
986 do (let ((newpath (make-pathname
987 :host (pathname-host pathname)
988 :device (pathname-device pathname)
989 :directory (subseq dir 0 i))))
990 (unless (probe-file newpath)
991 (let ((namestring (coerce (native-namestring newpath)
994 (format *standard-output*
995 "~&creating directory: ~A~%"
997 (sb!unix:unix-mkdir namestring mode)
998 (unless (probe-file newpath)
1003 "can't create directory ~A"
1004 :format-arguments (list namestring))
1006 :report "Retry directory creation."
1007 (ensure-directories-exist
1009 :verbose verbose :mode mode))
1012 "Continue as if directory creation was successful."
1014 (setf created-p t)))))
1015 (values pathspec created-p))))
1017 (/show0 "filesys.lisp 1000")