From: Simon Marlow <marlowsd@gmail.com>
Date: Wed, 13 Aug 2008 14:34:36 +0000 (+0000)
Subject: FIX #2492: ghc-pkg insists on having HOME environment variable set
X-Git-Tag: 2008-09-12~197
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=6d574977031d878d5994689e4c4b5ea1159eef06

FIX #2492: ghc-pkg insists on having HOME environment variable set
---

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 86fd652..1605cd2 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -398,18 +398,24 @@ getPkgDatabases modify my_flags = do
       else return []
 
   -- get the location of the user package database, and create it if necessary
-  appdir <- getAppUserDataDirectory "ghc"
-
-  let
-        subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
-        archdir   = appdir </> subdir
-        user_conf = archdir </> "package.conf"
-  user_exists <- doesFileExist user_conf
+  -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
+  appdir <- try $ getAppUserDataDirectory "ghc"
+
+  mb_user_conf <-
+     case appdir of
+       Right dir -> do
+               let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
+                   user_conf = dir </> subdir </> "package.conf"
+               user_exists <- doesFileExist user_conf
+               return (Just (user_conf,user_exists))
+       Left ex ->
+               return Nothing
 
   -- If the user database doesn't exist, and this command isn't a
   -- "modify" command, then we won't attempt to create or use it.
   let sys_databases
-        | modify || user_exists = user_conf : global_confs ++ [global_conf]
+        | Just (user_conf,user_exists) <- mb_user_conf,
+          modify || user_exists = user_conf : global_confs ++ [global_conf]
         | otherwise             = global_confs ++ [global_conf]
 
   e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
@@ -426,7 +432,9 @@ getPkgDatabases modify my_flags = do
       virt_global_conf = last env_stack
 
   let db_flags = [ f | Just f <- map is_db_flag my_flags ]
-         where is_db_flag FlagUser       = Just user_conf
+         where is_db_flag FlagUser
+                      | Just (user_conf,user_exists) <- mb_user_conf 
+                      = Just user_conf
                is_db_flag FlagGlobal     = Just virt_global_conf
                is_db_flag (FlagConfig f) = Just f
                is_db_flag _              = Nothing