Skip testl fcntl.flock.2 on NetBSD.

[sbcl.git] / src / code / filesys.lisp

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index a0d844e..be6cc69 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -296,6 +296,22 @@
             (sb!unix:unix-stat filename)
           (declare (ignore ino nlink gid rdev size atime
                            #!+win32 uid))
+          #!+win32
+          ;; On win32, stat regards UNC pathnames and device names as
+          ;; nonexisting, so we check once more with the native API.
+          (unless existsp
+            (setf existsp
+                  (let ((handle (sb!win32:create-file
+                                 filename 0 0 nil
+                                 sb!win32:file-open-existing
+                                 0 0)))
+                    (when (/= -1 handle)
+                      (setf mode
+                            (or mode
+                                (if (logbitp 4
+                                             (sb!win32:get-file-attributes filename))
+                                    sb!unix:s-ifdir 0)))
+                      (progn (sb!win32:close-handle handle) t)))))
           (if existsp
               (case query-for
                 (:existence (nth-value
@@ -477,9 +493,9 @@ If FILE is a stream, on Windows the stream is closed immediately. On Unix
 plaforms the stream remains open, allowing IO to continue: the OS resources
 associated with the deleted file remain available till the stream is closed as
 per standard Unix unlink() behaviour."
-  (let* ((pathname (translate-logical-pathname file))
+  (let* ((pathname (translate-logical-pathname
+                    (merge-pathnames file (sane-default-pathname-defaults))))
          (namestring (native-namestring pathname :as-file t)))
-    (truename file) ; for error-checking side-effect
     #!+win32
     (when (streamp file)
       (close file))
@@ -502,9 +518,7 @@ the directory could not be deleted for any reason.
 
 \(DELETE-DIRECTORY \"/tmp/foo\") and \(DELETE-DIRECTORY \"/tmp/foo/\") both
 delete the \"foo\" subdirectory of \"/tmp\", or signal an error if it does not
-exist or is a file.
-
-Experimental: interface subject to change."
+exist or is a file."
   (declare (type pathname-designator pathspec))
   (with-pathname (pathname pathspec)
     (let ((truename (truename (translate-logical-pathname pathname))))
@@ -542,30 +556,32 @@ Experimental: interface subject to change."
                                *default-pathname-defaults*
                                :as-directory t))))
 
+(defun user-homedir-namestring (&optional username)
+  (if username
+      (sb!unix:user-homedir username)
+      (let ((env-home (posix-getenv "HOME")))
+        (if (and env-home (not (string= env-home "")))
+            env-home
+            #!-win32
+            (sb!unix:uid-homedir (sb!unix:unix-getuid))))))
+
 ;;; (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."
+system. HOST argument is ignored by SBCL."
   (declare (ignore host))
-  (let ((env-home (posix-getenv "HOME")))
-    (values
-     (parse-native-namestring
-      (if (and env-home (not (string= env-home "")))
-          env-home
-          #!-win32
-          (sb!unix:uid-homedir (sb!unix:unix-getuid))
-          #!+win32
-          ;; Needs to bypass PARSE-NATIVE-NAMESTRING & ENSURE-TRAILING-SLASH
-          ;; What?! -- RMK, 2007-12-31
-          (return-from user-homedir-pathname
-            (sb!win32::get-folder-pathname sb!win32::csidl_profile)))
-      #!-win32 sb!impl::*unix-host*
-      #!+win32 sb!impl::*win32-host*
-      *default-pathname-defaults*
-      :as-directory t))))
+  (values
+   (parse-native-namestring
+    (or (user-homedir-namestring)
+        #!+win32
+        (sb!win32::get-folder-namestring sb!win32::csidl_profile))
+    #!-win32 sb!impl::*unix-host*
+    #!+win32 sb!impl::*win32-host*
+    *default-pathname-defaults*
+    :as-directory t)))
 
 \f
 ;;;; DIRECTORY
@@ -721,7 +737,7 @@ matching filenames."
 ;;; This is our core directory access interface that we use to implement
 ;;; DIRECTORY.
 (defun map-directory (function directory &key (files t) (directories t)
-                      (classify-symlinks) (errorp t))
+                      (classify-symlinks t) (errorp t))
   #!+sb-doc
   "Map over entries in DIRECTORY. Keyword arguments specify which entries to
 map over, and how:
@@ -737,12 +753,12 @@ map over, and how:
    pathname. Defaults to T.
 
  :CLASSIFY-SYMLINKS
-   If T, the decision to call FUNCTION with the pathname of a symbolic link
+   If true, the decision to call FUNCTION with the pathname of a symbolic link
    depends on the resolution of the link: if it points to a directory, it is
    considered a directory entry, otherwise a file entry. If false, all
-   symbolic links are considered file entries. Defaults to T. In both cases
-   the pathname used for the symbolic link is not fully resolved, but names it
-   as an immediate child of DIRECTORY.
+   symbolic links are considered file entries. In both cases the pathname used
+   for the symbolic link is not fully resolved, but names it as an immediate
+   child of DIRECTORY. Defaults to T.
 
  :ERRORP
    If true, signal an error if DIRECTORY does not exist, cannot be read, etc.
@@ -989,7 +1005,7 @@ Experimental: interface subject to change."
            ((or (null one) (eq one :unspecific)) two)
            ((or (null two) (eq two :unspecific)) one)
            ((string= one two) one)
-           (t nil)))
+           (t (return-from pathname-intersections nil))))
        (intersect-directory (one two)
          (aver (typep one '(or null (member :wild :unspecific) list)))
          (aver (typep two '(or null (member :wild :unspecific) list)))