-;;;; 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")
-
-(defmacro !enumerate-matches ((var pathname &optional result
- &key (verify-existence t)
- (follow-links t))
- &body body)
- `(block nil
- (%enumerate-matches (pathname ,pathname)
- ,verify-existence
- ,follow-links
- (lambda (,var) ,@body))
- ,result))
-
-(/show0 "filesys.lisp 500")
-
-;;; Call FUNCTION on matches.
-;;;
-;;; KLUDGE: this assumes that an absolute pathname is indicated to the
-;;; operating system by having a directory separator as the first
-;;; character in the directory part. This is true for Win32 pathnames
-;;; and for Unix pathnames, but it isn't true for LispM pathnames (and
-;;; their bastard offspring, logical pathnames. Also it assumes that
-;;; Unix pathnames have an empty or :unspecific device, and that
-;;; windows drive letters are the only kinds of non-empty/:UNSPECIFIC
-;;; devices.
-(defun %enumerate-matches (pathname verify-existence follow-links function)
- (/noshow0 "entering %ENUMERATE-MATCHES")
- (when (pathname-type pathname)
- (unless (pathname-name pathname)
- (error "cannot supply a type without a name:~% ~S" pathname)))
- (when (and (integerp (pathname-version pathname))
- (member (pathname-type pathname) '(nil :unspecific)))
- (error "cannot supply a version without a type:~% ~S" pathname))
- (let ((host (pathname-host pathname))
- (device (pathname-device pathname))
- (directory (pathname-directory pathname)))
- (/noshow0 "computed HOST and DIRECTORY")
- (let* ((dirstring (if directory
- (ecase (first directory)
- (:absolute (host-unparse-directory-separator host))
- (:relative ""))
- ""))
- (devstring (if (and device (not (eq device :unspecific)))
- (concatenate 'simple-string (string device) (string #\:))
- ""))
- (headstring (concatenate 'simple-string devstring dirstring)))
- (if directory
- (%enumerate-directories headstring (rest directory) pathname
- verify-existence follow-links nil function)
- (%enumerate-files headstring pathname verify-existence function)))))
-
-;;; Call FUNCTION on directories.
-(defun %enumerate-directories (head tail pathname verify-existence
- follow-links nodes function
- &aux (host (pathname-host pathname)))
- (declare (simple-string head))
- #!+win32
- (setf follow-links nil)
- (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))))
- (with-directory-node-removed ((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 (remove (cons dev ino) nodes :test #'equal)))
- ,@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
- (host-unparse-directory-separator host))
- (cdr tail) pathname
- verify-existence follow-links
- nodes function))))
- ((member :wild-inferiors)
- ;; now with extra error case handling from CLHS
- ;; 19.2.2.4.3 -- CSR, 2004-01-24
- (when (member (cadr tail) '(:up :back))
- (error 'simple-file-error
- :pathname pathname
- :format-control "~@<invalid use of ~S after :WILD-INFERIORS~@:>."
- :format-arguments (list (cadr tail))))
- (%enumerate-directories head (rest tail) pathname
- verify-existence follow-links
- nodes function)
- (dolist (name (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)
- #!+win32 ;; KLUDGE
- (not (zerop ino))
- (eql (cdr dir) ino))
- (return t)))
- (let ((nodes (cons (cons dev ino) nodes))
- (subdir (concatenate 'string subdir (host-unparse-directory-separator host))))
- (%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 (host-unparse-directory-separator host))))
- (%enumerate-directories subdir (rest tail) pathname
- verify-existence follow-links
- nodes function))))))))
- ((member :up)
- (when (string= head (host-unparse-directory-separator host))
- (error 'simple-file-error
- :pathname pathname
- :format-control "~@<invalid use of :UP after :ABSOLUTE.~@:>"))
- (with-directory-node-removed (head)
- (let ((head (concatenate 'string head "..")))
- (with-directory-node-noted (head)
- (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host))
- (rest tail) pathname
- verify-existence follow-links
- nodes function)))))
- ((member :back)
- ;; :WILD-INFERIORS is handled above, so the only case here
- ;; should be (:ABSOLUTE :BACK)
- (aver (string= head (host-unparse-directory-separator host)))
- (error 'simple-file-error
- :pathname pathname
- :format-control "~@<invalid use of :BACK after :ABSOLUTE.~@:>"))))
- (%enumerate-files head pathname verify-existence function))))
-
-;;; Call FUNCTION on files.
-(defun %enumerate-files (directory pathname verify-existence function)
- (declare (simple-string directory))
- (/noshow0 "entering %ENUMERATE-FILES")
- (let ((name (%pathname-name pathname))
- (type (%pathname-type pathname))
- (version (%pathname-version pathname)))
- (/noshow0 "computed NAME, TYPE, and VERSION")
- (cond ((member name '(nil :unspecific))
- (/noshow0 "UNSPECIFIC, more or less")
- (let ((directory (coerce directory 'string)))
- (when (or (not verify-existence)
- (sb!unix:unix-file-kind directory))
- (funcall function directory))))
- ((or (pattern-p name)
- (pattern-p type)
- (eq name :wild)
- (eq type :wild))
- (/noshow0 "WILD, more or less")
- ;; 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
- (/noshow0 "default case")
- (let ((file (concatenate 'string directory name)))
- (/noshow "computed basic FILE")
- (unless (or (null type) (eq type :unspecific))
- (/noshow0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
- (setf file (concatenate 'string file "." type)))
- (unless (member version '(nil :newest :wild :unspecific))
- (/noshow0 "tweaking FILE for more-or-less-:WILD case")
- (setf file (concatenate 'string file "."
- (quick-integer-to-string version))))
- (/noshow0 "finished possibly tweaking FILE")
- (when (or (not verify-existence)
- (sb!unix:unix-file-kind file t))
- (/noshow0 "calling FUNCTION on FILE")
- (funcall function file)))))))
-
-(/noshow0 "filesys.lisp 603")
-
-;;; FIXME: Why do we need this?
-(defun quick-integer-to-string (n)
- (declare (type integer n))
- (cond ((not (fixnump n))
- (write-to-string n :base 10 :radix nil))
- ((zerop n) "0")
- ((eql n 1) "1")
- ((minusp n)
- (concatenate 'simple-base-string "-"
- (the simple-base-string (quick-integer-to-string (- n)))))
- (t
- (do* ((len (1+ (truncate (integer-length n) 3)))
- (res (make-string len :element-type 'base-char))
- (i (1- len) (1- i))
- (q n)
- (r 0))
- ((zerop q)
- (incf i)
- (replace res res :start2 i :end2 len)
- (%shrink-vector res (- len i)))
- (declare (simple-string res)
- (fixnum len i r q))
- (multiple-value-setq (q r) (truncate q 10))
- (setf (schar res i) (schar "0123456789" r))))))
-\f
-;;;; UNIX-NAMESTRING
-
-(defun empty-relative-pathname-spec-p (x)
- (or (equal x "")
- (and (pathnamep x)
- (or (equal (pathname-directory x) '(:relative))
- ;; KLUDGE: I'm not sure this second check should really
- ;; have to be here. But on sbcl-0.6.12.7,
- ;; (PATHNAME-DIRECTORY (PATHNAME "")) is NIL, and
- ;; (PATHNAME "") seems to act like an empty relative
- ;; pathname, so in order to work with that, I test
- ;; for NIL here. -- WHN 2001-05-18
- (null (pathname-directory x)))
- (null (pathname-name x))
- (null (pathname-type x)))
- ;; (The ANSI definition of "pathname specifier" has
- ;; other cases, but none of them seem to admit the possibility
- ;; of being empty and relative.)
- ))
-
-;;; Convert PATHNAME into a string that can be used with UNIX system
-;;; calls, or return NIL if no match is found. Wild-cards are expanded.
-;;;
-;;; FIXME: apart from the error checking (for wildness and for
-;;; existence) and conversion to physical pathanme, this is redundant
-;;; with UNPARSE-NATIVE-UNIX-NAMESTRING; one should probably be
-;;; written in terms of the other.
-;;;
-;;; FIXME: actually this (I think) works not just for Unix.
-(defun unix-namestring (pathname-spec &optional (for-input t))
- (let* ((namestring (physicalize-pathname (merge-pathnames pathname-spec)))
- (matches nil)) ; an accumulator for actual matches
- (when (wild-pathname-p namestring)
- (error 'simple-file-error
- :pathname namestring
- :format-control "bad place for a wild pathname"))
- (!enumerate-matches (match namestring nil :verify-existence for-input)
- (push match matches))
- (case (length matches)
- (0 nil)
- (1 (first matches))
- (t (bug "!ENUMERATE-MATCHES returned more than one match on a non-wild pathname")))))