From 621eebe206ae6c6d0d0897d43247ce5e05c2359a Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 20 May 2009 13:51:53 +0000 Subject: [PATCH] 1.0.28.61: partial re-implementation of DIRECTORY * Rip out !ENUMERATE-MATCHES, which insisted on walking the directory tree from the root -- making using DIRECTORY on UNC pathnames a losing proposition. * New guts built on top of MAP-DIRECTORY, and it's lower level cousin WITH-NATIVE-DIRECTORY-ITERATOR. This seems easier to understand to me at least, and was certainly easier than trying to re-architect !ENUMERATE-MATCHES. ...and DIRECTORY now works on UNC shares, yay! ...and a bunch of associated secondary changes: ** Rename UNIX-FILE-KIND NATIVE-FILE-KIND, and move it to filesys.lisp. ** Add functions UNIX-OPENDIR, UNIX-READDIR, UNIX-CLOSEDIR, and UNIX-DIRENT-NAME -- later to be turned into OS-*, and possibly moved into SB-SYS. ** *IGNORE-WILDCARDS* is no longer needed in MAYBE-MAKE-PATTERN, kill it. ** Share UNPARSE-*-PIECE as UNPARSE-PHYSICAL-PIECE between Win32 and Unix: both have the same lisp namestring syntax for pieces, and if a third pathname host appears it probably should too. ** Fix DEFKNOWN of DIRECTORY: RESOLVE-SYMLINKS needs to be a keyword there. ** Kill QUICK-INTEGER-TO-STRING -- use %OUTPUT-INTEGER-IN-BASE in GENSYM instead. ** Kill PATHAME-ORDER, unused. ** Follow the same convention as elsewhere for :AS-FILE in NATIVE-NAMESTRING on Windows -- users needing the no-trailing-slash version are supposed to say :AS-FILE. OS pickiness on slash-or-no seems universal... --- NEWS | 1 - package-data-list.lisp-expr | 11 +- src/code/filesys.lisp | 814 +++++++++++++++++++++-------------------- src/code/symbol.lisp | 8 +- src/code/target-pathname.lisp | 2 +- src/code/unix-pathname.lisp | 55 +-- src/code/unix.lisp | 61 ++- src/code/win32-pathname.lisp | 94 ++--- src/compiler/fndb.lisp | 2 +- src/runtime/wrap.c | 103 ++---- version.lisp-expr | 2 +- 11 files changed, 531 insertions(+), 622 deletions(-) diff --git a/NEWS b/NEWS index f878720..2c13f97 100644 --- a/NEWS +++ b/NEWS @@ -15,7 +15,6 @@ efficiency measure for threaded platforms, but also valueable in expressing intent. * new feature: UNC pathnames are now understood by the system on Windows. - However, DIRECTORY does not yet support them -- but OPEN &co do. * optimization: the compiler uses a specialized version of FILL when the element type is know in more cases, making eg. (UNSIGNED-BYTE 8) case almost 90% faster. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 8debd87..f078e71 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -2274,7 +2274,7 @@ no guarantees of interface stability." "RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND" "RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK" "RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" "RUSEAGE" - "R_OK" "S-IEXEC" "S-IFBLK" "S-IFCHR" "S-IFDIR" "S-IFLNK" "S-IFMT" + "R_OK" "S-IEXEC" "S-IFBLK" "S-IFCHR" "S-IFDIR" "S-IFIFO" "S-IFLNK" "S-IFMT" "S-IFREG" "S-IFSOCK" "S-IREAD" "S-ISGID" "S-ISUID" "S-ISVTX" "S-IWRITE" "SAVETEXT" "SB-MKSTEMP" "SC-MASK" "SC-ONSTACK" "SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL" @@ -2285,12 +2285,13 @@ no guarantees of interface stability." "TIOCGPGRP" "TIOCGWINSZ" "TIOCNOTTY" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TIOCSPGRP" "TIOCSWINSZ" "TV-SEC" "TV-USEC" "TZ-DSTTIME" "TZ-MINUTESWEST" "UID-T" "UNIX-CLOSE" - "UNIX-DUP""UNIX-EXIT" "UNIX-FILE-MODE" "UNIX-FSTAT" + "UNIX-CLOSEDIR" "UNIX-DIRENT-NAME" "UNIX-DUP""UNIX-EXIT" + "UNIX-FILE-MODE" "UNIX-FSTAT" "UNIX-GETHOSTNAME" "UNIX-GETPID" "UNIX-GETRUSAGE" "UNIX-GETTIMEOFDAY" "UNIX-GETUID" "UNIX-GID" "UNIX-IOCTL" "UNIX-ISATTY" "UNIX-LSEEK" "UNIX-LSTAT" "UNIX-MKDIR" - "UNIX-OPEN" "UNIX-PATHNAME" "UNIX-PID" - "UNIX-PIPE" "UNIX-READ" "UNIX-READLINK" "UNIX-REALPATH" + "UNIX-OPEN" "UNIX-OPENDIR" "UNIX-PATHNAME" "UNIX-PID" + "UNIX-PIPE" "UNIX-READ" "UNIX-READDIR" "UNIX-READLINK" "UNIX-REALPATH" "UNIX-RENAME" "UNIX-SELECT" "UNIX-STAT" "UNIX-UID" "UNIX-UNLINK" "UNIX-WRITE" "WINSIZE" @@ -2323,7 +2324,7 @@ no guarantees of interface stability." "EUSERS" "EVICEERR" "EVICEOP" "EWOULDBLOCK" "EXDEV" "FD-ISSET" "FD-SET" "LTCHARS" "UNIX-FAST-SELECT" - "UNIX-FILE-KIND" "UNIX-KILL" "CODESET" + "UNIX-KILL" "CODESET" "TCSETPGRP" "FD-ZERO" "FD-CLR" "CHECK" "UNIX-RESOLVE-LINKS" "FD-SETSIZE" "TCGETPGRP" "UNIX-FAST-GETRUSAGE" "UNIX-KILLPG" diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index 520fa92..2013e12 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -80,80 +80,127 @@ :offset (1- end))) (%shrink-vector result dst))) -(defvar *ignore-wildcards* nil) - -(/show0 "filesys.lisp 86") - (defun maybe-make-pattern (namestr start end) (declare (type simple-string namestr) (type index start end)) - (if *ignore-wildcards* - (subseq namestr start end) - (collect ((pattern)) - (let ((quoted nil) - (any-quotes nil) - (last-regular-char nil) - (index start)) - (flet ((flush-pending-regulars () - (when last-regular-char - (pattern (if any-quotes - (remove-backslashes namestr - last-regular-char - index) - (subseq namestr last-regular-char index))) - (setf any-quotes nil) - (setf last-regular-char nil)))) - (loop - (when (>= index end) - (return)) - (let ((char (schar namestr index))) - (cond (quoted - (incf index) - (setf quoted nil)) - ((char= char #\\) - (setf quoted t) - (setf any-quotes t) - (unless last-regular-char - (setf last-regular-char index)) - (incf index)) - ((char= char #\?) - (flush-pending-regulars) - (pattern :single-char-wild) - (incf index)) - ((char= char #\*) - (flush-pending-regulars) - (pattern :multi-char-wild) - (incf index)) - ((char= char #\[) - (flush-pending-regulars) - (let ((close-bracket - (position #\] namestr :start index :end end))) - (unless close-bracket - (error 'namestring-parse-error - :complaint "#\\[ with no corresponding #\\]" - :namestring namestr - :offset index)) - (pattern (cons :character-set - (subseq namestr - (1+ index) - close-bracket))) - (setf index (1+ close-bracket)))) - (t - (unless last-regular-char - (setf last-regular-char index)) - (incf index))))) - (flush-pending-regulars))) - (cond ((null (pattern)) - "") - ((null (cdr (pattern))) - (let ((piece (first (pattern)))) - (typecase piece - ((member :multi-char-wild) :wild) - (simple-string piece) - (t - (make-pattern (pattern)))))) + (collect ((pattern)) + (let ((quoted nil) + (any-quotes nil) + (last-regular-char nil) + (index start)) + (flet ((flush-pending-regulars () + (when last-regular-char + (pattern (if any-quotes + (remove-backslashes namestr + last-regular-char + index) + (subseq namestr last-regular-char index))) + (setf any-quotes nil) + (setf last-regular-char nil)))) + (loop + (when (>= index end) + (return)) + (let ((char (schar namestr index))) + (cond (quoted + (incf index) + (setf quoted nil)) + ((char= char #\\) + (setf quoted t) + (setf any-quotes t) + (unless last-regular-char + (setf last-regular-char index)) + (incf index)) + ((char= char #\?) + (flush-pending-regulars) + (pattern :single-char-wild) + (incf index)) + ((char= char #\*) + (flush-pending-regulars) + (pattern :multi-char-wild) + (incf index)) + ((char= char #\[) + (flush-pending-regulars) + (let ((close-bracket + (position #\] namestr :start index :end end))) + (unless close-bracket + (error 'namestring-parse-error + :complaint "#\\[ with no corresponding #\\]" + :namestring namestr + :offset index)) + (pattern (cons :character-set + (subseq namestr + (1+ index) + close-bracket))) + (setf index (1+ close-bracket)))) + (t + (unless last-regular-char + (setf last-regular-char index)) + (incf index))))) + (flush-pending-regulars))) + (cond ((null (pattern)) + "") + ((null (cdr (pattern))) + (let ((piece (first (pattern)))) + (typecase piece + ((member :multi-char-wild) :wild) + (simple-string piece) + (t + (make-pattern (pattern)))))) + (t + (make-pattern (pattern)))))) + +(defun unparse-physical-piece (thing) + (etypecase thing + ((member :wild) "*") + (simple-string + (let* ((srclen (length thing)) + (dstlen srclen)) + (dotimes (i srclen) + (case (schar thing i) + ((#\* #\? #\[) + (incf dstlen)))) + (let ((result (make-string dstlen)) + (dst 0)) + (dotimes (src srclen) + (let ((char (schar thing src))) + (case char + ((#\* #\? #\[) + (setf (schar result dst) #\\) + (incf dst))) + (setf (schar result dst) char) + (incf dst))) + result))) + (pattern + (with-output-to-string (s) + (dolist (piece (pattern-pieces thing)) + (etypecase piece + (simple-string + (write-string piece s)) + (symbol + (ecase piece + (:multi-char-wild + (write-string "*" s)) + (:single-char-wild + (write-string "?" s)))) + (cons + (case (car piece) + (:character-set + (write-string "[" s) + (write-string (cdr piece) s) + (write-string "]" s)) (t - (make-pattern (pattern))))))) + (error "invalid pattern piece: ~S" piece)))))))))) + +(defun make-matcher (piece) + (cond ((eq piece :wild) + (constantly t)) + ((typep piece 'pattern) + (lambda (other) + (when (stringp other) + (pattern-matches piece other)))) + (t + (lambda (other) + (equal piece other))))) (/show0 "filesys.lisp 160") @@ -175,267 +222,22 @@ (/show0 "filesys.lisp 200") -;;;; 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 "~@" - :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") - -;; TODO: the implementation !enumerate-matches is some hairy stuff -;; that we mostly don't need. Couldn't we use POSIX fts(3) to walk -;; the file system and PATHNAME-MATCH-P to select matches, at least on -;; Unices? -(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 "~@." - :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 "~@")) - (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 "~@")))) - (%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)))))) +;;;; Grabbing the kind of file when we have a namestring. +(defun native-file-kind (namestring) + (multiple-value-bind (existsp errno ino mode) + #!-win32 + (sb!unix:unix-lstat namestring) + #!+win32 + (sb!unix:unix-stat namestring) + (declare (ignore errno ino)) + (when existsp + (let ((ifmt (logand mode sb!unix:s-ifmt))) + (case ifmt + (#.sb!unix:s-ifreg :file) + (#.sb!unix:s-ifdir :directory) + #!-win32 + (#.sb!unix:s-iflnk :symlink) + (t :special)))))) ;;;; TRUENAME, PROBE-FILE, FILE-AUTHOR, FILE-WRITE-DATE. @@ -719,7 +521,284 @@ system." ;;;; DIRECTORY -(/show0 "filesys.lisp 800") +(defun directory (pathspec &key (resolve-symlinks t)) + #!+sb-doc + "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the +given pathname. Note that the interaction between this ANSI-specified +TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) means +this function can sometimes return files which don't have the same directory +as PATHNAME. If :RESOLVE-SYMLINKS is NIL, don't resolve symbolic links in +matching filenames." + (let (;; We create one entry in this hash table for each truename, + ;; as an asymptotically efficient way of removing duplicates + ;; (which can arise when e.g. multiple symlinks map to the + ;; same truename). + (truenames (make-hash-table :test #'equal))) + (labels ((record (pathname) + (let ((truename (if resolve-symlinks + ;; FIXME: Why not not TRUENAME? As reported by + ;; Milan Zamazal sbcl-devel 2003-10-05, using + ;; TRUENAME causes a race condition whereby + ;; removal of a file during the directory + ;; operation causes an error. It's not clear + ;; what the right thing to do is, though. -- + ;; CSR, 2003-10-13 + (query-file-system pathname :truename nil) + (query-file-system pathname :existence nil)))) + (when truename + (setf (gethash (namestring truename) truenames) + truename)))) + (do-physical-pathnames (pathname) + (aver (not (logical-pathname-p pathname))) + (let* ((name (pathname-name pathname)) + (type (pathname-type pathname)) + ;; KLUDGE: We want #p"/foo" to match #p"/foo/, + ;; so cobble up a directory name component from + ;; name and type -- just take care with "*.*"! + (dirname (if (and (eq :wild name) (eq :wild type)) + "*" + (with-output-to-string (s) + (when name + (write-string (unparse-physical-piece name) s)) + (when type + (write-string "." s) + (write-string (unparse-physical-piece type) s))))) + (dir (maybe-make-pattern dirname 0 (length dirname))) + (match-name (make-matcher name)) + (match-type (make-matcher type)) + (match-dir (make-matcher dir))) + (map-matching-directories + (if (or name type) + (lambda (directory) + (map-matching-files #'record + directory + match-name + match-type + match-dir)) + #'record) + pathname))) + (do-pathnames (pathname) + (if (logical-pathname-p pathname) + (let ((host (intern-logical-host (pathname-host pathname)))) + (dolist (x (logical-host-canon-transls host)) + (destructuring-bind (from to) x + (let ((intersections + (pathname-intersections pathname from))) + (dolist (p intersections) + (do-pathnames (translate-pathname p from to))))))) + (do-physical-pathnames pathname)))) + (declare (truly-dynamic-extent #'record)) + (do-pathnames (merge-pathnames pathspec))) + (mapcar #'cdr + ;; Sorting isn't required by the ANSI spec, but sorting into some + ;; canonical order seems good just on the grounds that the + ;; implementation should have repeatable behavior when possible. + (sort (loop for namestring being each hash-key in truenames + using (hash-value truename) + collect (cons namestring truename)) + #'string< + :key #'car)))) + +;;; Given a native namestring, provides a WITH-HASH-TABLE-ITERATOR style +;;; interface to mapping over namestrings of entries in the corresponding +;;; directory. +(defmacro with-native-directory-iterator ((iterator namestring &key errorp) &body body) + (with-unique-names (one-iter) + `(dx-flet + ((iterate (,one-iter) + (declare (type function ,one-iter)) + (macrolet ((,iterator () + `(funcall ,',one-iter))) + ,@body))) + (call-with-native-directory-iterator #'iterate ,namestring ,errorp)))) + +(defun call-with-native-directory-iterator (function namestring errorp) + (declare (type (or null string) namestring) + (function function)) + (let (dp) + (when namestring + (dx-flet + ((one-iter () + (tagbody + :next + (let ((ent (sb!unix:unix-readdir dp nil))) + (when ent + (let ((name (sb!unix:unix-dirent-name ent))) + (when name + (cond ((equal "." name) + (go :next)) + ((equal ".." name) + (go :next)) + (t + (return-from one-iter name)))))))))) + (unwind-protect + (progn + (setf dp (sb!unix:unix-opendir namestring errorp)) + (when dp + (funcall function #'one-iter))) + (when dp + (sb!unix:unix-closedir dp nil))))))) + +;;; This is our core directory access interface that we use to implement +;;; DIRECTORY. +(defun map-directory (function directory &key (files t) (directories t) (errorp t)) + #!+sb-doc + "Call FUNCTION with the pathname for each entry in DIRECTORY as follows: if +FILES is true (the default), FUNCTION is called for each file in the +directory; if DIRECTORIES is true (the default), FUNCTION is called for each +subdirectory. If ERRORP is true (the default) signal an error if DIRECTORY +does not exist, cannot be read, etc. + +On platforms supporting symbolic links the decision to call FUNCTION with its +pathname depends on the resolution of the link: if it points to a directory, +it is considered a directory entry. Whether it is considered a file or a +directory, the provided pathname is not fully resolved, but rather names the +symbolic link as an immediate child of DIRECTORY. + +Experimental: interface subject to change." + (let* ((fun (%coerce-callable-to-fun function)) + (realname (or (query-file-system directory :existence errorp) + (return-from map-directory nil))) + (host (pathname-host realname)) + ;; We want the trailing separator: better to ask the + ;; provide it rather than reason about its presence here. + (dirname (native-namestring realname :as-file nil))) + (with-native-directory-iterator (next dirname :errorp errorp) + (loop for name = (next) + while name + do (let* ((full (concatenate 'string dirname name)) + (kind (native-file-kind full))) + (when kind + (case kind + (:directory + (when directories + (funcall fun (parse-native-namestring + full host realname :as-directory t)))) + (:symlink + (let* ((tmpname (parse-native-namestring + full host realname :as-directory nil)) + (truename (query-file-system tmpname :truename nil))) + (if (or (not truename) + (or (pathname-name truename) (pathname-type truename))) + (when files + (funcall fun tmpname)) + (when directories + (funcall fun (parse-native-namestring + full host realname :as-directory t)))))) + (t + ;; Anything else parses as a file. + (when files + (funcall fun (parse-native-namestring + full host realname :as-directory nil))))))))))) + +;;; Part of DIRECTORY: implements matching the directory spec. Calls FUNCTION +;;; with all DIRECTORIES that match the directory portion of PATHSPEC. +(defun map-matching-directories (function pathspec) + (let* ((dir (pathname-directory pathspec)) + (length (length dir)) + (wild (position-if (lambda (elt) + (or (eq :wild elt) (typep elt 'pattern))) + dir)) + (wild-inferiors (position :wild-inferiors dir)) + (end (cond ((and wild wild-inferiors) + (min wild wild-inferiors)) + (t + (or wild wild-inferiors length)))) + (rest (subseq dir end)) + (starting-point (make-pathname :directory (subseq dir 0 end) + :device (pathname-device pathspec) + :host (pathname-host pathspec) + :name nil + :type nil + :version nil))) + (cond (wild-inferiors + (map-wild-inferiors function rest starting-point)) + (wild + (map-wild function rest starting-point)) + (t + ;; Nothing wild -- the directory matches itself. + (funcall function starting-point))))) + +(defun last-directory-piece (pathname) + (car (last (pathname-directory pathname)))) + +;;; Part of DIRECTORY: implements iterating over a :WILD or pattern component +;;; in the directory spec. +(defun map-wild (function more directory) + (let ((this (pop more)) + (next (car more))) + (flet ((cont (subdirectory) + (cond ((not more) + ;; end of the line + (funcall function subdirectory)) + ((or (eq :wild next) (typep next 'pattern)) + (lambda (pathname) + (map-wild function more pathname))) + ((eq :wild-inferiors next) + (lambda (pathname) + (map-wild-inferiors function more pathname))) + (t + (lambda (pathname) + (let ((this (pathname-directory pathname))) + (when (equal next (car (last this))) + (map-matching-directories + function + (make-pathname :directory (append this more) + :defaults pathname))))))))) + (map-directory + (if (eq :wild this) + #'cont + (lambda (sub) + (awhen (pattern-matches this (last-directory-piece sub)) + (funcall #'cont it)))) + directory + :files nil + :directories t + :errorp nil)))) + +;;; Part of DIRECTORY: implements iterating over a :WILD-INFERIORS component +;;; in the directory spec. +(defun map-wild-inferiors (function more directory) + (loop while (member (car more) '(:wild :wild-inferiors)) + do (pop more)) + (let ((next (car more)) + (rest (cdr more))) + (unless more + (funcall function directory)) + (map-directory + (cond ((not more) + (lambda (pathname) + (funcall function pathname) + (map-wild-inferiors function more pathname))) + (t + (lambda (pathname) + (let ((this (pathname-directory pathname))) + (when (equal next (car (last this))) + (map-matching-directories + function + (make-pathname :directory (append this rest) + :defaults pathname))) + (map-wild-inferiors function more pathname))))) + directory + :files nil + :directories t + :errorp nil))) + +;;; Part of DIRECTORY: implements iterating over files in a directory, and matching +;;; them. +(defun map-matching-files (function directory match-name match-type match-dir) + (map-directory + (lambda (file) + (let ((pname (pathname-name file)) + (ptype (pathname-type file))) + (when (if (or pname ptype) + (and (funcall match-name pname) (funcall match-type ptype)) + (funcall match-dir (last-directory-piece file))) + (funcall function file)))) + directory + :files t + :directories t + :errorp nil)) ;;; NOTE: There is a fair amount of hair below that is probably not ;;; strictly necessary. @@ -897,77 +976,6 @@ system." (mapcar (lambda (x) (cons (simple-intersection (car one) (car two)) x)) (intersect-directory-helper (cdr one) (cdr two))))))))) - -(defun directory (pathname &key (resolve-symlinks t)) - #!+sb-doc - "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the - given pathname. Note that the interaction between this ANSI-specified - TRUENAMEing and the semantics of the Unix filesystem (symbolic links..) - means this function can sometimes return files which don't have the same - directory as PATHNAME. If :RESOLVE-SYMLINKS is NIL, don't resolve - symbolic links in matching filenames." - (let (;; We create one entry in this hash table for each truename, - ;; as an asymptotically efficient way of removing duplicates - ;; (which can arise when e.g. multiple symlinks map to the - ;; same truename). - (filenames (make-hash-table :test #'equal)) - ;; FIXME: Possibly this MERGE-PATHNAMES call should only - ;; happen once we get a physical pathname. - (merged-pathname (merge-pathnames pathname))) - (labels ((do-physical-directory (pathname) - (aver (not (logical-pathname-p pathname))) - (!enumerate-matches (match pathname) - (let* ((*ignore-wildcards* t) - ;; FIXME: Why not TRUENAME? As reported by - ;; Milan Zamazal sbcl-devel 2003-10-05, using - ;; TRUENAME causes a race condition whereby - ;; removal of a file during the directory - ;; operation causes an error. It's not clear - ;; what the right thing to do is, though. -- - ;; CSR, 2003-10-13 - (filename (if resolve-symlinks - (query-file-system match :truename nil) - (query-file-system match :existence nil)))) - (when filename - (setf (gethash (namestring filename) filenames) - filename))))) - (do-directory (pathname) - (if (logical-pathname-p pathname) - (let ((host (intern-logical-host (pathname-host pathname)))) - (dolist (x (logical-host-canon-transls host)) - (destructuring-bind (from to) x - (let ((intersections - (pathname-intersections pathname from))) - (dolist (p intersections) - (do-directory (translate-pathname p from to))))))) - (do-physical-directory pathname)))) - (do-directory merged-pathname)) - (mapcar #'cdr - ;; Sorting isn't required by the ANSI spec, but sorting - ;; into some canonical order seems good just on the - ;; grounds that the implementation should have repeatable - ;; behavior when possible. - (sort (loop for name being each hash-key in filenames - using (hash-value filename) - collect (cons name filename)) - #'string< - :key #'car)))) - -(/show0 "filesys.lisp 899") - -;;; predicate to order pathnames by; goes by name -;; FIXME: Does anything use this? It's not exported, and I don't find -;; the name anywhere else. -(defun pathname-order (x y) - (let ((xn (%pathname-name x)) - (yn (%pathname-name y))) - (if (and xn yn) - (let ((res (string-lessp xn yn))) - (cond ((not res) nil) - ((= res (length (the simple-string xn))) t) - ((= res (length (the simple-string yn))) nil) - (t t))) - xn))) (defun ensure-directories-exist (pathspec &key verbose (mode #o777)) #!+sb-doc diff --git a/src/code/symbol.lisp b/src/code/symbol.lisp index c95370f..30e629e 100644 --- a/src/code/symbol.lisp +++ b/src/code/symbol.lisp @@ -264,7 +264,7 @@ distinct from the global value. Can also be SETF." (let ((new (etypecase old (index (1+ old)) (unsigned-byte (1+ old))))) - (declare (optimize (speed 3) (safety 0)(inhibit-warnings 3))) + (declare (optimize (speed 3) (safety 0) (inhibit-warnings 3))) (setq *gensym-counter* new))) (multiple-value-bind (prefix int) (etypecase thing @@ -273,9 +273,9 @@ distinct from the global value. Can also be SETF." (string (values (coerce thing 'simple-string) old))) (declare (simple-string prefix)) (make-symbol - (concatenate 'simple-string prefix - (the simple-string - (quick-integer-to-string int))))))) + (with-output-to-string (s) + (write-string prefix s) + (%output-integer-in-base int 10 s)))))) (defvar *gentemp-counter* 0) (declaim (type unsigned-byte *gentemp-counter*)) diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 4536eb3..04c5845 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -1064,7 +1064,7 @@ system's syntax for files." (frob %pathname-directory directory-components-match) (frob %pathname-name) (frob %pathname-type) - (or (eq (%pathname-host wildname) *unix-host*) + (or (eq (%pathname-host wildname) *physical-host*) (frob %pathname-version))))))) ;;; Place the substitutions into the pattern and return the string or pattern diff --git a/src/code/unix-pathname.lisp b/src/code/unix-pathname.lisp index e7faa3e..82b39b7 100644 --- a/src/code/unix-pathname.lisp +++ b/src/code/unix-pathname.lisp @@ -132,51 +132,6 @@ ;; 2002-05-09 "") -(defun unparse-unix-piece (thing) - (etypecase thing - ((member :wild) "*") - (simple-string - (let* ((srclen (length thing)) - (dstlen srclen)) - (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (incf dstlen)))) - (let ((result (make-string dstlen)) - (dst 0)) - (dotimes (src srclen) - (let ((char (schar thing src))) - (case char - ((#\* #\? #\[) - (setf (schar result dst) #\\) - (incf dst))) - (setf (schar result dst) char) - (incf dst))) - result))) - (pattern - (collect ((strings)) - (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string - (strings piece)) - (symbol - (ecase piece - (:multi-char-wild - (strings "*")) - (:single-char-wild - (strings "?")))) - (cons - (case (car piece) - (:character-set - (strings "[") - (strings (cdr piece)) - (strings "]")) - (t - (error "invalid pattern piece: ~S" piece)))))) - (apply #'concatenate - 'simple-string - (strings)))))) - (defun unparse-unix-directory-list (directory) (declare (type list directory)) (collect ((pieces)) @@ -196,7 +151,7 @@ ((member :wild-inferiors) (pieces "**/")) ((or simple-string pattern (member :wild)) - (pieces (unparse-unix-piece dir)) + (pieces (unparse-physical-piece dir)) (pieces "/")) (t (error "invalid directory component: ~S" dir))))) @@ -224,7 +179,7 @@ (when (and (typep name 'string) (string= name "")) (error "name is of length 0: ~S" pathname)) - (strings (unparse-unix-piece name))) + (strings (unparse-physical-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) @@ -232,7 +187,7 @@ (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece type)))) + (strings (unparse-physical-piece type)))) (apply #'concatenate 'simple-string (strings)))) (/show0 "filesys.lisp 406") @@ -329,7 +284,7 @@ (typep pathname-name 'simple-string) (position #\. pathname-name :start 1)) (error "too many dots in the name: ~S" pathname)) - (strings (unparse-unix-piece pathname-name))) + (strings (unparse-physical-piece pathname-name))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) @@ -337,7 +292,7 @@ (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece pathname-type)))) + (strings (unparse-physical-piece pathname-type)))) (apply #'concatenate 'simple-string (strings))))) (defun simplify-unix-namestring (src) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index f885d57..971979f 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -949,24 +949,6 @@ corresponds to NAME, or NIL if there is none." ;;; enough of them all in one place here that they should probably be ;;; removed by hand. -;;;; support routines for dealing with Unix pathnames - -(defun unix-file-kind (name &optional check-for-links) - #!+sb-doc - "Return either :FILE, :DIRECTORY, :LINK, :SPECIAL, or NIL." - (declare (simple-string name)) - (multiple-value-bind (res dev ino mode) - (if check-for-links (unix-lstat name) (unix-stat name)) - (declare (type (or fixnum null) mode) - (ignore dev ino)) - (when res - (let ((kind (logand mode s-ifmt))) - (cond ((eql kind s-ifdir) :directory) - ((eql kind s-ifreg) :file) - #!-win32 - ((eql kind s-iflnk) :link) - (t :special)))))) - (defconstant micro-seconds-per-internal-time-unit (/ 1000000 sb!xc:internal-time-units-per-second)) @@ -1054,6 +1036,49 @@ corresponds to NAME, or NIL if there is none." micro-seconds-per-internal-time-unit)))) result)))) +;;;; opendir, readdir, closedir, and dirent-name + +(declaim (inline unix-opendir)) +(defun unix-opendir (namestring &optional (errorp t)) + (let ((dir (alien-funcall + (extern-alien "sb_opendir" + (function system-area-pointer c-string)) + namestring))) + (if (zerop (sap-int dir)) + (when errorp (simple-perror + (format nil "Error opening directory ~S" + namestring))) + dir))) + +(declaim (inline unix-readdir)) +(defun unix-readdir (dir &optional (errorp t) namestring) + (let ((ent (alien-funcall + (extern-alien "sb_readdir" + (function system-area-pointer system-area-pointer)) + dir))) + (if (zerop (sap-int ent)) + (when errorp (simple-perror + (format nil "Error reading directory entry~@[ from ~S~]" + namestring))) + ent))) + +(declaim (inline unix-closedir)) +(defun unix-closedir (dir &optional (errorp t) namestring) + (let ((r (alien-funcall + (extern-alien "sb_closedir" (function int system-area-pointer)) + dir))) + (if (minusp r) + (when errorp (simple-perror + (format nil "Error closing directory~@[ ~S~]" + namestring))) + r))) + +(declaim (inline unix-dirent-name)) +(defun unix-dirent-name (ent) + (alien-funcall + (extern-alien "sb_dirent_name" (function c-string system-area-pointer)) + ent)) + ;;;; A magic constant for wait3(). ;;;; ;;;; FIXME: This used to be defined in run-program.lisp as diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp index c521dca..80ea088 100644 --- a/src/code/win32-pathname.lisp +++ b/src/code/win32-pathname.lisp @@ -172,51 +172,6 @@ (t (concatenate 'simple-string "\\\\" device))))) -(defun unparse-win32-piece (thing) - (etypecase thing - ((member :wild) "*") - (simple-string - (let* ((srclen (length thing)) - (dstlen srclen)) - (dotimes (i srclen) - (case (schar thing i) - ((#\* #\? #\[) - (incf dstlen)))) - (let ((result (make-string dstlen)) - (dst 0)) - (dotimes (src srclen) - (let ((char (schar thing src))) - (case char - ((#\* #\? #\[) - (setf (schar result dst) #\\) - (incf dst))) - (setf (schar result dst) char) - (incf dst))) - result))) - (pattern - (collect ((strings)) - (dolist (piece (pattern-pieces thing)) - (etypecase piece - (simple-string - (strings piece)) - (symbol - (ecase piece - (:multi-char-wild - (strings "*")) - (:single-char-wild - (strings "?")))) - (cons - (case (car piece) - (:character-set - (strings "[") - (strings (cdr piece)) - (strings "]")) - (t - (error "invalid pattern piece: ~S" piece)))))) - (apply #'concatenate - 'simple-string - (strings)))))) - (defun unparse-win32-directory-list (directory) (declare (type list directory)) (collect ((pieces)) @@ -236,7 +191,7 @@ ((member :wild-inferiors) (pieces "**\\")) ((or simple-string pattern (member :wild)) - (pieces (unparse-unix-piece dir)) + (pieces (unparse-physical-piece dir)) (pieces "\\")) (t (error "invalid directory component: ~S" dir))))) @@ -264,7 +219,7 @@ (when (and (typep name 'string) (string= name "")) (error "name is of length 0: ~S" pathname)) - (strings (unparse-unix-piece name))) + (strings (unparse-physical-piece name))) (when type-supplied (unless name (error "cannot specify the type without a file: ~S" pathname)) @@ -272,7 +227,7 @@ (when (position #\. type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece type)))) + (strings (unparse-physical-piece type)))) (apply #'concatenate 'simple-string (strings)))) (defun unparse-win32-namestring (pathname) @@ -283,9 +238,7 @@ (unparse-win32-file pathname))) (defun unparse-native-win32-namestring (pathname as-file) - (declare (type pathname pathname) - ;; Windows doesn't like directory names with trailing slashes. - (ignore as-file)) + (declare (type pathname pathname)) (let* ((device (pathname-device pathname)) (directory (pathname-directory pathname)) (name (pathname-name pathname)) @@ -294,28 +247,27 @@ (type (pathname-type pathname)) (type-present-p (typep type '(not (member nil :unspecific)))) (type-string (if type-present-p type ""))) + (when name-present-p + (setf as-file nil)) (coerce (with-output-to-string (s) (when device (write-string (unparse-win32-device pathname) s)) - (tagbody - (when directory - (ecase (pop directory) - (:absolute (write-char #\\ s)) - (:relative))) - (unless directory (go :done)) - :subdir - (let ((piece (pop directory))) - (typecase piece - ((member :up) (write-string ".." s)) - (string (write-string piece s)) - (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" - piece))) - (when (or directory name) - (write-char #\\ s))) - (when directory - (go :subdir)) - :done) + (when directory + (ecase (car directory) + (:absolute (write-char #\\ s)) + (:relative))) + (loop for (piece . subdirs) on (cdr directory) + do (typecase piece + ((member :up) (write-string ".." s)) + (string (write-string piece s)) + (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S" + piece))) + if (or subdirs (stringp name)) + do (write-char #\\ s) + else + do (unless as-file + (write-char #\\ s))) (if name-present-p (progn (unless (stringp name-string) ;some kind of wild field @@ -375,7 +327,7 @@ (typep pathname-name 'simple-string) (position #\. pathname-name :start 1)) (error "too many dots in the name: ~S" pathname)) - (strings (unparse-unix-piece pathname-name))) + (strings (unparse-physical-piece pathname-name))) (when type-needed (when (or (null pathname-type) (eq pathname-type :unspecific)) (lose)) @@ -383,7 +335,7 @@ (when (position #\. pathname-type) (error "type component can't have a #\. inside: ~S" pathname))) (strings ".") - (strings (unparse-unix-piece pathname-type)))) + (strings (unparse-physical-piece pathname-type)))) (apply #'concatenate 'simple-string (strings))))) ;; FIXME: This has been converted rather blindly from the Unix diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 8bea7e4..23a916c 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1257,7 +1257,7 @@ (:external-format keyword)) t) -(defknown directory (pathname-designator &key (resolve-symlinks t)) +(defknown directory (pathname-designator &key (:resolve-symlinks t)) list ()) ;;;; from the "Conditions" chapter: diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 5f18738..8493bf6 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -62,73 +62,6 @@ extern char **environ; * stuff needed by CL:DIRECTORY and other Lisp directory operations */ -/* Unix directory operations think of "." and ".." as filenames, but - * Lisp directory operations do not. */ -int -is_lispy_filename(const char *filename) -{ - return strcmp(filename, ".") && strcmp(filename, ".."); -} - -/* Return a zero-terminated array of strings holding the Lispy filenames - * (i.e. excluding the Unix magic "." and "..") in the named directory. */ -char** -alloc_directory_lispy_filenames(const char *directory_name) -{ - DIR *dir_ptr = opendir(directory_name); - char **result = 0; - - if (dir_ptr) { /* if opendir success */ - - struct voidacc va; - - if (0 == voidacc_ctor(&va)) { /* if voidacc_ctor success */ - struct dirent *dirent_ptr; - - while ( (dirent_ptr = readdir(dir_ptr)) ) { /* until end of data */ - char* original_name = dirent_ptr->d_name; - if (is_lispy_filename(original_name)) { - /* strdup(3) is in Linux and *BSD. If you port - * somewhere else that doesn't have it, it's easy - * to reimplement. */ - char* dup_name = strdup(original_name); - if (!dup_name) { /* if strdup failure */ - goto dtors; - } - if (voidacc_acc(&va, dup_name)) { /* if acc failure */ - goto dtors; - } - } - } - result = (char**)voidacc_give_away_result(&va); - } - - dtors: - voidacc_dtor(&va); - /* ignoring closedir(3) return code, since what could we do? - * - * "Never ask questions you don't want to know the answer to." - * -- William Irving Zumwalt (Rich Cook, _The Wizardry Quested_) */ - closedir(dir_ptr); - } - - return result; -} - -/* Free a result returned by alloc_directory_lispy_filenames(). */ -void -free_directory_lispy_filenames(char** directory_lispy_filenames) -{ - char** p; - - /* Free the strings. */ - for (p = directory_lispy_filenames; *p; ++p) { - free(*p); - } - - /* Free the table of strings. */ - free(directory_lispy_filenames); -} /* * readlink(2) stuff @@ -195,6 +128,42 @@ char * sb_realpath (char *path) #endif } +/* readdir, closedir, and dirent name accessor. The first three are not strictly + * necessary, but should save us some #!+netbsd in the build, and this also allows + * building Windows versions using the non-ANSI variants of FindFirstFile &co + * under the same API. (Use a structure that appends the handle to the WIN32_FIND_DATA + * as the return value from sb_opendir, on sb_readdir grab the name from the previous + * call and save the new one.) Nikodemus thought he would have to do that to support + * DIRECTORY on UNC paths, but turns out opendir &co do TRT on Windows already -- so + * leaving that bit of tedium for a later date, once we figure out the whole *A vs. *W + * issue out properly. ...FIXME, obviously, as per above. + * + * Once that is done, the lisp side functions are best named OS-OPENDIR, etc. + */ +extern DIR * +sb_opendir(char * name) +{ + return opendir(name); +} + +extern struct dirent * +sb_readdir(DIR * dirp) +{ + return readdir(dirp); +} + +extern int +sb_closedir(DIR * dirp) +{ + return closedir(dirp); +} + +extern char * +sb_dirent_name(struct dirent * ent) +{ + return ent->d_name; +} + /* * stat(2) stuff */ diff --git a/version.lisp-expr b/version.lisp-expr index 286ec14..9536e8f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.28.60" +"1.0.28.61" -- 1.7.10.4