Commit be8b6cd5 authored by simonmar's avatar simonmar

[project @ 2005-11-04 15:48:25 by simonmar]

- Add support for the GHC_PACKAGE_PATH environment variable, which
  specifies a :-separated (;-separated on Windows) list of package
  database files.  If the list ends in : (; on Windows), then the
  normal user and global databases are added.

  GHC_PACKAGE_PATH is searched left-to-right for packages, like
  $PATH, but unlike -package-conf flags, which are searched
  right-to-left.  This isn't ideal, but it seemed the least worst to me
  (command line flags always override right-to-left (except -i),
  whereas the PATH environment variable overrides left-to-right, I chose
  to follow the environment variable convention).  I can always change
  it if there's an outcry.

- Rationalise the interpretation of --user, --global, and -f on the
  ghc-pkg command line.  The story is now this: --user and --global
  say which package database to *act upon*, they do not change the
  shape of the database stack.  -f pushes a database on the stack, and
  also requests that the specified database be the one to act upon, for
  commands that modify the database.  If a database is already on the stack,
  then -f just selects it as the one to act upon.

  This means you can have a bunch of databases in GHC_PACKAGE_PATH, and
  use -f to select the one to modify.
parent de808d3b
......@@ -61,6 +61,7 @@ import System.Directory ( getAppUserDataDirectory )
import Compat.Directory ( getAppUserDataDirectory )
#endif
import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
......@@ -207,33 +208,46 @@ initPackages dflags = do
readPackageConfigs :: DynFlags -> IO PackageConfigMap
readPackageConfigs dflags = do
e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
system_pkgconfs <- getSystemPackageConfigs dflags
let pkgconfs = case e_pkg_path of
Left _ -> system_pkgconfs
Right path
| last cs == "" -> init cs ++ system_pkgconfs
| otherwise -> cs
where cs = parseSearchPath path
-- if the path ends in a separator (eg. "/foo/bar:")
-- the we tack on the system paths.
-- Read all the ones mentioned in -package-conf flags
pkg_map <- foldM (readPackageConfig dflags) emptyPackageConfigMap
(reverse pkgconfs ++ extraPkgConfs dflags)
return pkg_map
getSystemPackageConfigs :: DynFlags -> IO [FilePath]
getSystemPackageConfigs dflags = do
-- System one always comes first
system_pkgconf <- getPackageConfigPath
pkg_map1 <- readPackageConfig dflags emptyPackageConfigMap system_pkgconf
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
-- unless the -no-user-package-conf flag was given.
-- We only do this when getAppUserDataDirectory is available
-- (GHC >= 6.3).
(exists, pkgconf) <- catch (do
user_pkgconf <- handle (\_ -> return []) $ do
appdir <- getAppUserDataDirectory "ghc"
let
pkgconf = appdir
`joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
`joinFileName` "package.conf"
flg <- doesFileExist pkgconf
return (flg, pkgconf))
-- gobble them all up and turn into False.
(\ _ -> return (False, ""))
pkg_map2 <- if (dopt Opt_ReadUserPackageConf dflags && exists)
then readPackageConfig dflags pkg_map1 pkgconf
else return pkg_map1
-- Read all the ones mentioned in -package-conf flags
pkg_map <- foldM (readPackageConfig dflags) pkg_map2
(extraPkgConfs dflags)
if (flg && dopt Opt_ReadUserPackageConf dflags)
then return [pkgconf]
else return []
return pkg_map
return (user_pkgconf ++ [system_pkgconf])
readPackageConfig
......
......@@ -70,6 +70,7 @@ module Util (
replaceFilenameSuffix, directoryOf, filenameOf,
replaceFilenameDirectory,
escapeSpaces, isPathSeparator,
parseSearchPath,
normalisePath, platformPath, pgmPath,
) where
......@@ -950,6 +951,40 @@ isPathSeparator ch =
ch == '/'
#endif
--------------------------------------------------------------
-- * Search path
--------------------------------------------------------------
-- | The function splits the given string to substrings
-- using the 'searchPathSeparator'.
parseSearchPath :: String -> [FilePath]
parseSearchPath path = split path
where
split :: String -> [String]
split s =
case rest' of
[] -> [chunk]
_:rest -> chunk : split rest
where
chunk =
case chunk' of
#ifdef mingw32_HOST_OS
('\"':xs@(_:_)) | last xs == '\"' -> init xs
#endif
_ -> chunk'
(chunk', rest') = break (==searchPathSeparator) s
-- | A platform-specific character used to separate search path strings in
-- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
-- and a semicolon (\";\") on the Windows operating system.
searchPathSeparator :: Char
#if mingw32_HOST_OS || mingw32_TARGET_OS
searchPathSeparator = ';'
#else
searchPathSeparator = ':'
#endif
-----------------------------------------------------------------------------
-- Convert filepath into platform / MSDOS form.
......
......@@ -47,6 +47,7 @@ import System ( getArgs, getProgName, getEnv,
exitWith, ExitCode(..)
)
import System.IO
import System.IO.Error (try)
import Data.List ( isPrefixOf, isSuffixOf, intersperse, groupBy, sortBy )
#ifdef mingw32_HOST_OS
......@@ -294,36 +295,53 @@ getPkgDatabases modify flags = do
user_conf = archdir `joinFileName` "package.conf"
user_exists <- doesFileExist user_conf
let
-- The semantics here are slightly strange. If we are
-- *modifying* the database, then the default is to modify
-- the global database by default, unless you say --user.
-- If we are not modifying (eg. list, describe etc.) then
-- the user database is included by default.
databases
| modify = foldl addDB [global_conf] flags
| not user_exists = foldl addDB [global_conf] flags
| otherwise = foldl addDB [user_conf,global_conf] flags
-- implement the following rules:
-- --user means overlap with the user database
-- --global means reset to just the global database
-- -f <file> means overlap with <file>
addDB dbs FlagUser
| user_conf `elem` dbs = dbs
| modify || user_exists = user_conf : dbs
addDB dbs FlagGlobal = [global_conf]
addDB dbs (FlagConfig f) = f : dbs
addDB dbs _ = dbs
-- 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_conf]
| otherwise = [global_conf]
e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH")
let env_stack =
case e_pkg_path of
Left _ -> sys_databases
Right path
| last cs == "" -> init cs ++ sys_databases
| otherwise -> cs
where cs = parseSearchPath path
-- -f flags on the command line add to the database stack, unless any
-- of them are present in the stack already.
let flag_stack = filter (`notElem` env_stack)
[ f | FlagConfig f <- reverse flags ] ++ env_stack
-- Now we have the full stack of databases. Next, if the current
-- command is a "modify" type command, then we truncate the stack
-- so that the topmost element is the database being modified.
final_stack <-
if not modify
then return flag_stack
else let
go (FlagUser : fs) = modifying user_conf
go (FlagGlobal : fs) = modifying global_conf
go (FlagConfig f : fs) = modifying f
go (_ : fs) = go fs
go [] = modifying global_conf
modifying f
| f `elem` flag_stack = return (dropWhile (/= f) flag_stack)
| otherwise = die ("requesting modification of database:\n\t" ++ f ++ "\n\twhich is not in the database stack.")
in
go flags
-- we create the user database iff (a) we're modifying, and (b) the
-- user asked to use it by giving the --user flag.
when (not user_exists && user_conf `elem` databases) $ do
when (not user_exists && user_conf `elem` final_stack) $ do
putStrLn ("Creating user package database in " ++ user_conf)
createDirectoryIfMissing True archdir
writeFile user_conf emptyPackageConfig
db_stack <- mapM readParseDatabase databases
db_stack <- mapM readParseDatabase final_stack
return db_stack
readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
......@@ -1101,3 +1119,34 @@ pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
-- | The function splits the given string to substrings
-- using the 'searchPathSeparator'.
parseSearchPath :: String -> [FilePath]
parseSearchPath path = split path
where
split :: String -> [String]
split s =
case rest' of
[] -> [chunk]
_:rest -> chunk : split rest
where
chunk =
case chunk' of
#ifdef mingw32_HOST_OS
('\"':xs@(_:_)) | last xs == '\"' -> init xs
#endif
_ -> chunk'
(chunk', rest') = break (==searchPathSeparator) s
-- | A platform-specific character used to separate search path strings in
-- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
-- and a semicolon (\";\") on the Windows operating system.
searchPathSeparator :: Char
#if mingw32_HOST_OS || mingw32_TARGET_OS
searchPathSeparator = ';'
#else
searchPathSeparator = ':'
#endif
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment