From: Stas Boukarev <stassats@gmail.com>
Date: Sun, 10 Nov 2013 18:26:17 +0000 (+0400)
Subject: More robust homedir detection on Windows.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1975bd0492ed33de669f92d8c03d75bca19ed011;p=sbcl.git

More robust homedir detection on Windows.

After consulting HOME, try USERPROFILE, then HOMEDRIVE+HOMEPATH.

Fixes lp#922117.
---

diff --git a/NEWS b/NEWS
index 898f465..30f7f79 100644
--- a/NEWS
+++ b/NEWS
@@ -12,7 +12,7 @@ changes relative to sbcl-1.1.13:
   * bug fix: EQUALP now compares correctly structures with raw slots larger
     than a single word.
   * bug fix: contribs couldn't be built on Windows with MinGW.
-  * bug fix: Better pathname handling on Windows.
+  * bug fix: Better pathname handling on Windows. (lp#922117)
 
 changes in sbcl-1.1.13 relative to sbcl-1.1.12:
   * optimization: better distribution of SXHASH over small conses of related
diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 960cf4e..c10aabc 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -584,13 +584,21 @@ exist or if is a file or a symbolic link."
                                :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)