;;;; files for more information.
(in-package "SB!IMPL")
-
-(file-comment
- "$Header$")
\f
;;;; Unix pathname host support
(position #\. namestr :start (1+ start)
:end last-dot :from-end t)))
(version :newest))
- ;; If there is a second-to-last dot, check to see whether there is a valid
- ;; version after the last dot.
+ ;; If there is a second-to-last dot, check to see whether there is
+ ;; a valid version after the last dot.
(when second-to-last-dot
(cond ((and (= (+ last-dot 2) end)
(char= (schar namestr (1+ last-dot)) #\*))
(/show0 "filesys.lisp 200")
;;; Take a string and return a list of cons cells that mark the char
-;;; separated subseq. The first value t if absolute directories location.
+;;; separated subseq. The first value is true if absolute directories
+;;; location.
(defun split-at-slashes (namestr start end)
(declare (type simple-base-string namestr)
(type index start end))
(t
(pieces "/"))))
(:relative
- ;; Nothing special.
+ ;; nothing special
))
(dolist (dir directory)
(typecase dir
(collect ((strings))
(let* ((name (%pathname-name pathname))
(type (%pathname-type pathname))
- (type-supplied (not (or (null type) (eq type :unspecific))))
- (version (%pathname-version pathname))
- (version-supplied (not (or (null version) (eq version :newest)))))
+ (type-supplied (not (or (null type) (eq type :unspecific)))))
+ ;; Note: by ANSI 19.3.1.1.5, we ignore the version slot when
+ ;; translating logical pathnames to a filesystem without
+ ;; versions (like Unix).
(when name
(strings (unparse-unix-piece name)))
(when type-supplied
(unless name
(error "cannot specify the type without a file: ~S" pathname))
(strings ".")
- (strings (unparse-unix-piece type)))
- (when version-supplied
- (unless type-supplied
- (error "cannot specify the version without a type: ~S" pathname))
- (strings (if (eq version :wild)
- ".*"
- (format nil ".~D" version)))))
+ (strings (unparse-unix-piece type))))
(apply #'concatenate 'simple-string (strings))))
(/show0 "filesys.lisp 406")
(let* ((pathname-directory (%pathname-directory pathname))
(defaults-directory (%pathname-directory defaults))
(prefix-len (length defaults-directory))
- (result-dir
+ (result-directory
(cond ((and (> prefix-len 1)
(>= (length pathname-directory) prefix-len)
(compare-component (subseq pathname-directory
(t
;; We are a relative directory. So we lose.
(lose)))))
- (strings (unparse-unix-directory-list result-dir)))
+ (strings (unparse-unix-directory-list result-directory)))
(let* ((pathname-version (%pathname-version pathname))
(version-needed (and pathname-version
(not (eq pathname-version :newest))))
\f
;;;; wildcard matching stuff
+;;; Return a list of all the Lispy filenames (not including e.g. the
+;;; Unix magic "." and "..") in the directory named by DIRECTORY-NAME.
+(defun directory-lispy-filenames (directory-name)
+ (with-alien ((adlf (* c-string)
+ (alien-funcall (extern-alien
+ "alloc_directory_lispy_filenames"
+ (function (* c-string) c-string))
+ directory-name)))
+ (if (null-alien adlf)
+ (error 'simple-file-error
+ :pathname directory-name
+ :format-control "~@<couldn't read directory ~S: ~2I~_~A~:>"
+ :format-arguments (list directory-name (strerror)))
+ (unwind-protect
+ (c-strings->string-list adlf)
+ (alien-funcall (extern-alien "free_directory_lispy_filenames"
+ (function void (* c-string)))
+ adlf)))))
+
(/show0 "filesys.lisp 498")
;;; FIXME: could maybe be EVAL-WHEN (COMPILE EVAL)
+
(defmacro enumerate-matches ((var pathname &optional result
- &key (verify-existence t))
+ &key (verify-existence t)
+ (follow-links t))
&body body)
- (let ((body-name (gensym)))
+ (let ((body-name (gensym "ENUMERATE-MATCHES-BODY-FUN-")))
`(block nil
(flet ((,body-name (,var)
,@body))
+ (declare (dynamic-extent ,body-name))
(%enumerate-matches (pathname ,pathname)
,verify-existence
+ ,follow-links
#',body-name)
,result))))
(/show0 "filesys.lisp 500")
-(defun %enumerate-matches (pathname verify-existence function)
+;;; Call FUNCTION on matches.
+(defun %enumerate-matches (pathname verify-existence follow-links function)
(/show0 "entering %ENUMERATE-MATCHES")
(when (pathname-type pathname)
(unless (pathname-name pathname)
(:absolute
(/show0 "absolute directory")
(%enumerate-directories "/" (cdr directory) pathname
- verify-existence function))
+ verify-existence follow-links
+ nil function))
(:relative
(/show0 "relative directory")
(%enumerate-directories "" (cdr directory) pathname
- verify-existence function)))
+ verify-existence follow-links
+ nil function)))
(%enumerate-files "" pathname verify-existence function))))
-(defun %enumerate-directories (head tail pathname verify-existence function)
+;;; Call FUNCTION on directories.
+(defun %enumerate-directories (head tail pathname verify-existence
+ follow-links nodes function)
(declare (simple-string head))
- (if tail
- (let ((piece (car tail)))
- (etypecase piece
- (simple-string
- (%enumerate-directories (concatenate 'string head piece "/")
- (cdr tail) pathname verify-existence
- function))
- ((or pattern (member :wild :wild-inferiors))
- (let ((dir (sb!unix:open-dir head)))
- (when dir
- (unwind-protect
- (loop
- (let ((name (sb!unix:read-dir dir)))
- (cond ((null name)
- (return))
- ((string= name "."))
- ((string= name ".."))
- ((pattern-matches piece name)
- (let ((subdir (concatenate 'string
- head name "/")))
- (when (eq (sb!unix:unix-file-kind subdir)
- :directory)
- (%enumerate-directories
- subdir (cdr tail) pathname verify-existence
- function)))))))
- (sb!unix:close-dir dir)))))
+ (macrolet ((unix-xstat (name)
+ `(if follow-links
+ (sb!unix:unix-stat ,name)
+ (sb!unix:unix-lstat ,name)))
+ (with-directory-node-noted ((head) &body body)
+ `(multiple-value-bind (res dev ino mode)
+ (unix-xstat ,head)
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (cons (cons dev ino) nodes)))
+ ,@body)))))
+ (if tail
+ (let ((piece (car tail)))
+ (etypecase piece
+ (simple-string
+ (let ((head (concatenate 'string head piece)))
+ (with-directory-node-noted (head)
+ (%enumerate-directories (concatenate 'string head "/")
+ (cdr tail) pathname
+ verify-existence follow-links
+ nodes function))))
+ ((member :wild-inferiors)
+ (%enumerate-directories head (rest tail) pathname
+ verify-existence follow-links
+ nodes function)
+ (dolist (name (ignore-errors (directory-lispy-filenames head)))
+ (let ((subdir (concatenate 'string head name)))
+ (multiple-value-bind (res dev ino mode)
+ (unix-xstat subdir)
+ (declare (type (or fixnum null) mode))
+ (when (and res (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (unless (dolist (dir nodes nil)
+ (when (and (eql (car dir) dev)
+ (eql (cdr dir) ino))
+ (return t)))
+ (let ((nodes (cons (cons dev ino) nodes))
+ (subdir (concatenate 'string subdir "/")))
+ (%enumerate-directories subdir tail pathname
+ verify-existence follow-links
+ nodes function))))))))
+ ((or pattern (member :wild))
+ (dolist (name (directory-lispy-filenames head))
+ (when (or (eq piece :wild) (pattern-matches piece name))
+ (let ((subdir (concatenate 'string head name)))
+ (multiple-value-bind (res dev ino mode)
+ (unix-xstat subdir)
+ (declare (type (or fixnum null) mode))
+ (when (and res
+ (eql (logand mode sb!unix:s-ifmt)
+ sb!unix:s-ifdir))
+ (let ((nodes (cons (cons dev ino) nodes))
+ (subdir (concatenate 'string subdir "/")))
+ (%enumerate-directories subdir (rest tail) pathname
+ verify-existence follow-links
+ nodes function))))))))
((member :up)
- (%enumerate-directories (concatenate 'string head "../")
- (cdr tail) pathname verify-existence
- function))))
- (%enumerate-files head pathname verify-existence function)))
+ (let ((head (concatenate 'string head "..")))
+ (with-directory-node-noted (head)
+ (%enumerate-directories (concatenate 'string head "/")
+ (rest tail) pathname
+ verify-existence follow-links
+ nodes function))))))
+ (%enumerate-files head pathname verify-existence function))))
+;;; Call FUNCTION on files.
(defun %enumerate-files (directory pathname verify-existence function)
(declare (simple-string directory))
(/show0 "entering %ENUMERATE-FILES")
(eq name :wild)
(eq type :wild))
(/show0 "WILD, more or less")
- (let ((dir (sb!unix:open-dir directory)))
- (when dir
- (unwind-protect
- (loop
- (/show0 "at head of LOOP")
- (let ((file (sb!unix:read-dir dir)))
- (if file
- (unless (or (string= file ".")
- (string= file ".."))
- (multiple-value-bind
- (file-name file-type file-version)
- (let ((*ignore-wildcards* t))
- (extract-name-type-and-version
- file 0 (length file)))
- (when (and (components-match file-name name)
- (components-match file-type type)
- (components-match file-version
- version))
- (funcall function
- (concatenate 'string
- directory
- file)))))
- (return))))
- (sb!unix:close-dir dir)))))
+ ;; I IGNORE-ERRORS here just because the original CMU CL
+ ;; code did. I think the intent is that it's not an error
+ ;; to request matches to a wild pattern when no matches
+ ;; exist, but I haven't tried to figure out whether
+ ;; everything is kosher. (E.g. what if we try to match a
+ ;; wildcard but we don't have permission to read one of the
+ ;; relevant directories?) -- WHN 2001-04-17
+ (dolist (complete-filename (ignore-errors
+ (directory-lispy-filenames directory)))
+ (multiple-value-bind
+ (file-name file-type file-version)
+ (let ((*ignore-wildcards* t))
+ (extract-name-type-and-version
+ complete-filename 0 (length complete-filename)))
+ (when (and (components-match file-name name)
+ (components-match file-type type)
+ (components-match file-version version))
+ (funcall function
+ (concatenate 'string
+ directory
+ complete-filename))))))
(t
(/show0 "default case")
(let ((file (concatenate 'string directory name)))
(/show0 "computed basic FILE=..")
- #!+sb-show (%primitive print file)
+ (/primitive-print file)
(unless (or (null type) (eq type :unspecific))
(/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
(setf file (concatenate 'string file "." type)))
(setf file (concatenate 'string file "."
(quick-integer-to-string version))))
(/show0 "finished possibly tweaking FILE=..")
- #!+sb-show (%primitive print file)
+ (/primitive-print file)
(when (or (not verify-existence)
(sb!unix:unix-file-kind file t))
(/show0 "calling FUNCTION on FILE")
;; toy@rtp.ericsson.se: Let unix-namestring also handle logical
;; pathnames too.
;; FIXME: What does this ^ mean? A bug? A remark on a change already made?
- (/show0 "entering UNIX-NAMESTRING")
(let ((path (let ((lpn (pathname pathname)))
(if (typep lpn 'logical-pathname)
(namestring (translate-logical-pathname lpn))
pathname))))
- (/show0 "PATH computed, enumerating search list")
(enumerate-search-list
(pathname path)
(collect ((names))
- (/show0 "collecting NAMES")
(enumerate-matches (name pathname nil :verify-existence for-input)
(when (or (not executable-only)
(and (eq (sb!unix:unix-file-kind name)
(sb!unix:unix-access name
sb!unix:x_ok)))
(names name)))
- (/show0 "NAMES collected")
(let ((names (names)))
(when names
- (/show0 "NAMES is true.")
(when (cdr names)
- (/show0 "Alas! CDR NAMES")
(error 'simple-file-error
:format-control "~S is ambiguous:~{~% ~A~}"
:format-arguments (list pathname names)))
- (/show0 "returning from UNIX-NAMESTRING")
(return (car names))))))))
\f
;;;; TRUENAME and PROBE-FILE
(defun probe-file (pathname)
#!+sb-doc
"Return a pathname which is the truename of the file if it exists, NIL
- otherwise. An error of type file-error is signaled if pathname is wild."
- (/show0 "entering PROBE-FILE")
+ otherwise. An error of type FILE-ERROR is signaled if pathname is wild."
(if (wild-pathname-p pathname)
(error 'simple-file-error
:pathname pathname
:format-control "bad place for a wild pathname")
(let ((namestring (unix-namestring pathname t)))
- (/show0 "NAMESTRING computed")
(when (and namestring (sb!unix:unix-file-kind namestring))
- (/show0 "NAMESTRING is promising.")
(let ((truename (sb!unix:unix-resolve-links
(sb!unix:unix-maybe-prepend-current-directory
namestring))))
- (/show0 "TRUENAME computed")
(when truename
- (/show0 "TRUENAME is true.")
(let ((*ignore-wildcards* t))
(pathname (sb!unix:unix-simplify-pathname truename)))))))))
\f
(defun rename-file (file new-name)
#!+sb-doc
- "Rename File to have the specified New-Name. If file is a stream open to a
+ "Rename FILE to have the specified NEW-NAME. If FILE is a stream open to a
file, then the associated file is renamed."
(let* ((original (truename file))
(original-namestring (unix-namestring original t))
(unless res
(error 'simple-file-error
:pathname new-name
- :format-control "failed to rename ~A to ~A: ~A"
- :format-arguments (list original new-name
- (sb!unix:get-unix-error-msg error))))
+ :format-control "~@<couldn't rename ~2I~_~A ~I~_to ~2I~_~A: ~
+ ~I~_~A~:>"
+ :format-arguments (list original new-name (strerror error))))
(when (streamp file)
(file-name file new-namestring))
(values new-name original (truename new-name)))))
(defun delete-file (file)
#!+sb-doc
- "Delete the specified file."
+ "Delete the specified FILE."
(let ((namestring (unix-namestring file t)))
(when (streamp file)
(close file :abort t))
:pathname file
:format-control "~S doesn't exist."
:format-arguments (list file)))
-
(multiple-value-bind (res err) (sb!unix:unix-unlink namestring)
(unless res
- (error 'simple-file-error
- :pathname namestring
- :format-control "could not delete ~A: ~A"
- :format-arguments (list namestring
- (sb!unix:get-unix-error-msg err))))))
+ (simple-file-perror "couldn't delete ~A" namestring err))))
t)
\f
-;;; Return Home:, which is set up for us at initialization time.
+;;; (This is an ANSI Common Lisp function.)
+;;;
+;;; This is obtained from the logical name \"home:\", which is set
+;;; up for us at initialization time.
(defun user-homedir-pathname (&optional host)
- #!+sb-doc
- "Returns the home directory of the logged in user as a pathname.
- This is obtained from the logical name \"home:\"."
+ "Return the home directory of the user as a pathname."
(declare (ignore host))
;; Note: CMU CL did #P"home:" here instead of using a call to
;; PATHNAME. Delaying construction of the pathname until we're
(follow-links t))
#!+sb-doc
"Returns a list of pathnames, one for each file that matches the given
- pathname. Supplying :ALL as nil causes this to ignore Unix dot files. This
+ pathname. Supplying :ALL as NIL causes this to ignore Unix dot files. This
never includes Unix dot and dot-dot in the result. If :FOLLOW-LINKS is NIL,
- then symblolic links in the result are not expanded. This is not the
+ then symbolic links in the result are not expanded. This is not the
default because TRUENAME does follow links, and the result pathnames are
defined to be the TRUENAME of the pathname (the truename of a link may well
be in another directory.)"
(char/= (schar name (1+ slash)) #\.))))
(push name results))))
(let ((*ignore-wildcards* t))
- (mapcar #'(lambda (name)
- (let ((name (if (and check-for-subdirs
- (eq (sb!unix:unix-file-kind name)
- :directory))
- (concatenate 'string name "/")
- name)))
- (if follow-links (truename name) (pathname name))))
+ (mapcar (lambda (name)
+ (let ((name (if (and check-for-subdirs
+ (eq (sb!unix:unix-file-kind name)
+ :directory))
+ (concatenate 'string name "/")
+ name)))
+ (if follow-links (truename name) (pathname name))))
(sort (delete-duplicates results :test #'string=) #'string<)))))
\f
;;;; translating Unix uid's
\f
(/show0 "filesys.lisp 899")
-;;; Predicate to order pathnames by. Goes by name.
+;;; predicate to order pathnames by; goes by name
(defun pathname-order (x y)
(let ((xn (%pathname-name x))
(yn (%pathname-name y)))
(t t)))
xn)))
\f
+;;;; DEFAULT-DIRECTORY stuff
+;;;;
+;;;; FIXME: *DEFAULT-DIRECTORY-DEFAULTS* seems to be the ANSI way to
+;;;; deal with this, so we should beef up *DEFAULT-DIRECTORY-DEFAULTS*
+;;;; and make all the old DEFAULT-DIRECTORY stuff go away. (At that
+;;;; time the need for UNIX-CHDIR will go away too, I think.)
+
(defun default-directory ()
#!+sb-doc
"Returns the pathname for the default directory. This is the place where
(multiple-value-bind (gr error) (sb!unix:unix-chdir namestring)
(if gr
(setf (search-list "default:") (default-directory))
- (error (sb!unix:get-unix-error-msg error))))
+ (simple-file-perror "couldn't set default directory to ~S"
+ new-val
+ error)))
new-val))
(/show0 "filesys.lisp 934")
-(defun !filesys-cold-init ()
- (/show0 "entering !FILESYS-COLD-INIT")
- (setf *default-pathname-defaults*
- (%make-pathname *unix-host* nil nil nil nil :newest))
- (setf (search-list "default:") (default-directory))
- (/show0 "leaving !FILESYS-COLD-INIT")
- nil)
+(/show0 "entering what used to be !FILESYS-COLD-INIT")
+(defvar *default-pathname-defaults*
+ (%make-pathname *unix-host* nil nil nil nil :newest))
+(setf (search-list "default:") (default-directory))
+(/show0 "leaving what used to be !FILESYS-COLD-INIT")
\f
(defun ensure-directories-exist (pathspec &key verbose (mode #o777))
#!+sb-doc
"Tests whether the directories containing the specified file
actually exist, and attempts to create them if they do not.
- Portable programs should avoid using the :MODE keyword argument."
+ Portable programs should avoid using the :MODE argument."
(let* ((pathname (pathname pathspec))
(pathname (if (typep pathname 'logical-pathname)
(translate-logical-pathname pathname)
projects / sbcl.git / blobdiff