More robust homedir detection on Windows.

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

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index b51c601..c10aabc 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -579,19 +579,26 @@ exist or if is a file or a symbolic link."
     ;; SBCL_HOME isn't set for :EXECUTABLE T embedded cores
     (when (and sbcl-home (not (string= sbcl-home "")))
       (parse-native-namestring sbcl-home
-                               #!-win32 sb!impl::*unix-host*
-                               #!+win32 sb!impl::*win32-host*
+                               *physical-host*
                                *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
+  (flet ((not-empty (x)
+           (and (not (equal x "")) x)))
+    (if username
+        (sb!unix:user-homedir username)
+        (or (not-empty (posix-getenv "HOME"))
+            #!+win32
+            (not-empty (posix-getenv "USERPROFILE"))
+            #!+win32
+            (let ((drive (not-empty (posix-getenv "HOMEDRIVE")))
+                  (path (not-empty (posix-getenv "HOMEPATH"))))
+              (and drive path
+                   (concatenate 'string drive path)))
             #!-win32
-            (sb!unix:uid-homedir (sb!unix:unix-getuid))))))
+            (not-empty (sb!unix:uid-homedir (sb!unix:unix-getuid)))
+            (error "Couldn't find home directory.")))))
 
 ;;; (This is an ANSI Common Lisp function.)
 (defun user-homedir-pathname (&optional host)
@@ -606,8 +613,7 @@ system. HOST argument is ignored by SBCL."
     (or (user-homedir-namestring)
         #!+win32
         (sb!win32::get-folder-namestring sb!win32::csidl_profile))
-    #!-win32 sb!impl::*unix-host*
-    #!+win32 sb!impl::*win32-host*
+    *physical-host*
     *default-pathname-defaults*
     :as-directory t)))