X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=53ff874e234af3edfcf5cdd02669f3b11ce02394;hb=279283bc1724b60ef9ebbf31ab4837061989be18;hp=d1de6bea1eaf73fbe3aa7fdb74a39d12b6f54c0a;hpb=c7142fb2d5f30fcdbcd89e37e46e5be02ecc97b2;p=sbcl.git diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index d1de6be..53ff874 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -55,9 +55,9 @@ #!+sb-doc "Remove any occurrences of #\\ from the string because we've already checked for whatever they may have protected." - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) - (let* ((result (make-string (- end start) :element-type 'base-char)) + (let* ((result (make-string (- end start) :element-type 'character)) (dst 0) (quoted nil)) (do ((src start (1+ src))) @@ -85,7 +85,7 @@ (/show0 "filesys.lisp 86") (defun maybe-make-pattern (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (if *ignore-wildcards* (subseq namestr start end) @@ -158,7 +158,7 @@ (/show0 "filesys.lisp 160") (defun extract-name-type-and-version (namestr start end) - (declare (type simple-base-string namestr) + (declare (type simple-string namestr) (type index start end)) (let* ((last-dot (position #\. namestr :start (1+ start) :end end :from-end t))) @@ -239,9 +239,9 @@ (:relative "")) "")) (devstring (if (and device (not (eq device :unspecific))) - (concatenate 'simple-base-string (string device) (string #\:)) + (concatenate 'simple-string (string device) (string #\:)) "")) - (headstring (concatenate 'simple-base-string devstring dirstring))) + (headstring (concatenate 'simple-string devstring dirstring))) (if directory (%enumerate-directories headstring (rest directory) pathname verify-existence follow-links nil function) @@ -252,6 +252,8 @@ 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) @@ -274,10 +276,10 @@ (let ((piece (car tail))) (etypecase piece (simple-string - (let ((head (concatenate 'base-string head piece))) + (let ((head (concatenate 'string head piece))) (with-directory-node-noted (head) (%enumerate-directories - (concatenate 'base-string head + (concatenate 'string head (host-unparse-directory-separator host)) (cdr tail) pathname verify-existence follow-links @@ -293,8 +295,8 @@ (%enumerate-directories head (rest tail) pathname verify-existence follow-links nodes function) - (dolist (name (ignore-errors (directory-lispy-filenames head))) - (let ((subdir (concatenate 'base-string head name))) + (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)) @@ -302,17 +304,19 @@ 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 'base-string subdir (host-unparse-directory-separator host)))) + (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 'base-string head name))) + (let ((subdir (concatenate 'string head name))) (multiple-value-bind (res dev ino mode) (unix-xstat subdir) (declare (type (or fixnum null) mode)) @@ -320,7 +324,7 @@ (eql (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)) (let ((nodes (cons (cons dev ino) nodes)) - (subdir (concatenate 'base-string subdir (host-unparse-directory-separator host)))) + (subdir (concatenate 'string subdir (host-unparse-directory-separator host)))) (%enumerate-directories subdir (rest tail) pathname verify-existence follow-links nodes function)))))))) @@ -330,9 +334,9 @@ :pathname pathname :format-control "~@")) (with-directory-node-removed (head) - (let ((head (concatenate 'base-string head ".."))) + (let ((head (concatenate 'string head ".."))) (with-directory-node-noted (head) - (%enumerate-directories (concatenate 'base-string head (host-unparse-directory-separator host)) + (%enumerate-directories (concatenate 'string head (host-unparse-directory-separator host)) (rest tail) pathname verify-existence follow-links nodes function))))) @@ -355,7 +359,7 @@ (/noshow0 "computed NAME, TYPE, and VERSION") (cond ((member name '(nil :unspecific)) (/noshow0 "UNSPECIFIC, more or less") - (let ((directory (coerce directory 'base-string))) + (let ((directory (coerce directory 'string))) (when (or (not verify-existence) (sb!unix:unix-file-kind directory)) (funcall function directory)))) @@ -382,19 +386,19 @@ (components-match file-type type) (components-match file-version version)) (funcall function - (concatenate 'base-string + (concatenate 'string directory complete-filename)))))) (t (/noshow0 "default case") - (let ((file (concatenate 'base-string directory name))) + (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 'base-string file "." type))) + (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 'base-string file "." + (setf file (concatenate 'string file "." (quick-integer-to-string version)))) (/noshow0 "finished possibly tweaking FILE") (when (or (not verify-existence) @@ -479,11 +483,11 @@ (defun truename (pathname) #!+sb-doc "Return the pathname for the actual file described by PATHNAME. - An error of type FILE-ERROR is signalled if no such file exists, - or the pathname is wild. +An error of type FILE-ERROR is signalled if no such file exists, or the +pathname is wild. - Under Unix, the TRUENAME of a broken symlink is considered to be - the name of the broken symlink itself." +Under Unix, the TRUENAME of a broken symlink is considered to be the name of +the broken symlink itself." (let ((result (probe-file pathname))) (unless result (error 'simple-file-error @@ -495,7 +499,7 @@ (defun probe-file (pathname) #!+sb-doc "Return a pathname which is the truename of the file if it exists, or NIL - otherwise. An error of type FILE-ERROR is signaled if pathname is wild." +otherwise. An error of type FILE-ERROR is signaled if pathname is wild." (let* ((defaulted-pathname (merge-pathnames pathname (sane-default-pathname-defaults))) @@ -504,7 +508,9 @@ (let ((trueishname (sb!unix:unix-resolve-links namestring))) (when trueishname (let* ((*ignore-wildcards* t) - (name (sb!unix:unix-simplify-pathname trueishname))) + (name (simplify-namestring + trueishname + (pathname-host defaulted-pathname)))) (if (eq (sb!unix:unix-file-kind name) :directory) ;; FIXME: this might work, but it's ugly. (pathname (concatenate 'string name "/")) @@ -572,21 +578,24 @@ ;;; (This is an ANSI Common Lisp function.) (defun user-homedir-pathname (&optional host) + #!+sb-doc "Return the home directory of the user as a pathname. If the HOME environment variable has been specified, the directory it designates is returned; otherwise obtains the home directory from the operating system." (declare (ignore host)) - (parse-native-namestring - (ensure-trailing-slash - (if (posix-getenv "HOME") - (posix-getenv "HOME") - #!-win32 - (sb!unix:uid-homedir (sb!unix:unix-getuid)) - #!+win32 - ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH - (return-from user-homedir-pathname - (sb!win32::get-folder-pathname sb!win32::csidl_profile)))))) + (let ((env-home (posix-getenv "HOME"))) + (parse-native-namestring + (ensure-trailing-slash + (if (and env-home + (not (equal env-home ""))) + env-home + #!-win32 + (sb!unix:uid-homedir (sb!unix:unix-getuid)) + #!+win32 + ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH + (return-from user-homedir-pathname + (sb!win32::get-folder-pathname sb!win32::csidl_profile))))))) (defun file-write-date (file) #!+sb-doc @@ -810,8 +819,8 @@ system." ;; grounds that the implementation should have repeatable ;; behavior when possible. (sort (loop for name being each hash-key in truenames - using (hash-value truename) - collect (cons name truename)) + using (hash-value truename) + collect (cons name truename)) #'string< :key #'car)))) @@ -848,7 +857,7 @@ system." :device (pathname-device pathname) :directory (subseq dir 0 i)))) (unless (probe-file newpath) - (let ((namestring (coerce (namestring newpath) 'base-string))) + (let ((namestring (coerce (namestring newpath) 'string))) (when verbose (format *standard-output* "~&creating directory: ~A~%"