-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.58 2001/03/27 16:55:03 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.66 2001/05/04 16:36:38 simonmar Exp $
--
-- GHC Interactive User Interface
--
{-# OPTIONS -#include "Linker.h" #-}
module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
+#include "../includes/config.h"
#include "HsVersions.h"
import CompManager
import DriverState
import DriverUtil
import Linker
+import Finder ( flushPackageCache )
import Util
import Name ( Name )
import Outputable
import Panic ( GhcException(..) )
import Config
+import Posix
import Exception
import Dynamic
-#ifndef NO_READLINE
-import Readline
+#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
+import Readline
#endif
import IOExts
-- link in the available packages
pkgs <- getPackageInfo
initLinker
- linkPackages cmdline_libs (reverse pkgs)
+ linkPackages cmdline_libs pkgs
(cmstate, ok, mods) <-
case mod of
Nothing -> return (cmstate, True, [])
Just m -> cmLoadModule cmstate m
-#ifndef NO_READLINE
+#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
Readline.initialize
#endif
(unGHCi runGHCi) GHCiState{ target = mod,
cmstate = cmstate,
- options = [ShowTiming] }
+ options = [] }
return ()
runGHCi :: GHCi ()
runGHCi = do
- -- read in ./.ghci
- dot_ghci <- io (IO.try (openFile "./.ghci" ReadMode))
- case dot_ghci of
- Left e -> return ()
- Right hdl -> fileLoop hdl False
+ -- Read in ./.ghci.
+ let file = "./.ghci"
+ exists <- io (doesFileExist file)
+ when exists $ do
+ dir_ok <- io (checkPerms ".")
+ file_ok <- io (checkPerms file)
+ when (dir_ok && file_ok) $ do
+ either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
+ case either_hdl of
+ Left e -> return ()
+ Right hdl -> fileLoop hdl False
- -- read in ~/.ghci
- home <- io (IO.try (getEnv "HOME"))
- case home of
- Left e -> return ()
- Right dir -> do
+ -- Read in $HOME/.ghci
+ either_dir <- io (IO.try (getEnv "HOME"))
+ case either_dir of
+ Left e -> return ()
+ Right dir -> do
cwd <- io (getCurrentDirectory)
- when (dir /= cwd) $ do
- dot_ghci <- io (IO.try (openFile (dir ++ "/.ghci") ReadMode))
- case dot_ghci of
- Left e -> return ()
- Right hdl -> fileLoop hdl False
+ when (dir /= cwd) $ do
+ let file = dir ++ "/.ghci"
+ ok <- io (checkPerms file)
+ either_hdl <- io (IO.try (openFile file ReadMode))
+ case either_hdl of
+ Left e -> return ()
+ Right hdl -> fileLoop hdl False
-- read commands from stdin
-#ifndef NO_READLINE
+#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
readlineLoop
#else
fileLoop stdin True
io $ do putStrLn "Leaving GHCi."
+-- NOTE: We only read .ghci files if they are owned by the current user,
+-- and aren't world writable. Otherwise, we could be accidentally
+-- running code planted by a malicious third party.
+
+-- Furthermore, We only read ./.ghci if both . and ./.ghci are
+-- owned by the current user and aren't writable by anyone else. I
+-- think this is sufficient: we don't need to check .. and
+-- ../.. etc. because "." always refers to the same directory while a
+-- process is running.
+
+checkPerms :: String -> IO Bool
+checkPerms name =
+ handle (\_ -> return False) $ do
+ st <- getFileStatus name
+ me <- getRealUserID
+ if fileOwner st /= me then do
+ putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
+ return False
+ else do
+ let mode = fileMode st
+ if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
+ || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
+ then do
+ putStrLn $ "*** WARNING: " ++ name ++
+ " is writable by someone else, IGNORING!"
+ return False
+ else return True
+
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl prompt = do
st <- getGHCiState
mod <- io (cmGetContext (cmstate st))
- when prompt (io (hPutStr hdl (mod ++ "> ")))
+ when prompt (io (putStr (mod ++ "> ")))
l <- io (IO.try (hGetLine hdl))
case l of
Left e | isEOFError e -> return ()
l -> do quit <- runCommand l
if quit then return () else stringLoop ss
-#ifndef NO_READLINE
+#if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS
readlineLoop :: GHCi ()
readlineLoop = do
st <- getGHCiState
io ( putStrLn ("Phase " ++ phase ++ " failed (code "
++ show code ++ ")"))
Interrupted -> io (putStrLn "Interrupted.")
+ -- omit the location for CmdLineError
+ CmdLineError s -> io (putStrLn s)
other -> io (putStrLn (show (ghc_ex :: GhcException)))
other -> io (putStrLn ("*** Exception: " ++ show exception))
foldr1 (\a b -> a ++ ',':b) (map fst cs)
++ ")") >> return False)
-noArgs c = throwDyn (OtherError ("command `" ++ c ++ "' takes no arguments"))
+noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments"))
-----------------------------------------------------------------------------
-- Commands
help _ = io (putStr helpText)
addModule :: String -> GHCi ()
-addModule _ = throwDyn (OtherError ":add not implemented")
+addModule _ = throwDyn (InstallationError ":add not implemented")
setContext :: String -> GHCi ()
setContext ""
- = throwDyn (OtherError "syntax: `:m <module>'")
+ = throwDyn (CmdLineError "syntax: `:m <module>'")
setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m))
- = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'"))
+ = throwDyn (CmdLineError ("strange looking module name: `" ++ m ++ "'"))
setContext str
= do st <- getGHCiState
new_cmstate <- io (cmSetContext (cmstate st) str)
let (macro_name, definition) = break isSpace s
cmds <- io (readIORef commands)
if (null macro_name)
- then throwDyn (OtherError "invalid macro name")
+ then throwDyn (CmdLineError "invalid macro name")
else do
if (macro_name `elem` map fst cmds)
- then throwDyn (OtherError
+ then throwDyn (CmdLineError
("command `" ++ macro_name ++ "' is already defined"))
else do
undefineMacro macro_name = do
cmds <- io (readIORef commands)
if (macro_name `elem` map fst builtin_commands)
- then throwDyn (OtherError
+ then throwDyn (CmdLineError
("command `" ++ macro_name ++ "' cannot be undefined"))
else do
if (macro_name `notElem` map fst cmds)
- then throwDyn (OtherError
+ then throwDyn (CmdLineError
("command `" ++ macro_name ++ "' not defined"))
else do
io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
loadModule' path = do
state <- getGHCiState
- cmstate1 <- io (cmUnload (cmstate state))
+ dflags <- io (getDynFlags)
+ cmstate1 <- io (cmUnload (cmstate state) dflags)
io (revertCAFs) -- always revert CAFs on load.
(cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path)
let new_state = state{ cmstate = cmstate2,
))
setOptions str
= do -- first, deal with the GHCi opts (+s, +t, etc.)
- let opts = words str
- (minus_opts, rest1) = partition isMinus opts
- (plus_opts, rest2) = partition isPlus rest1
-
- if (not (null rest2))
- then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
- else do
-
- mapM setOpt plus_opts
-
- -- now, the GHC flags
- io (do -- first, static flags
- leftovers <- processArgs static_flags minus_opts []
-
- -- then, dynamic flags
- dyn_flags <- readIORef v_InitDynFlags
- writeIORef v_DynFlags dyn_flags
- leftovers <- processArgs dynamic_flags leftovers []
- dyn_flags <- readIORef v_DynFlags
- writeIORef v_InitDynFlags dyn_flags
-
- if (not (null leftovers))
- then throwDyn (OtherError ("unrecognised flags: " ++
+ let (plus_opts, minus_opts) = partition isPlus (words str)
+ mapM setOpt plus_opts
+
+ -- now, the GHC flags
+ pkgs_before <- io (readIORef v_Packages)
+ leftovers <- io (processArgs static_flags minus_opts [])
+ pkgs_after <- io (readIORef v_Packages)
+
+ -- update things if the users wants more packages
+ when (pkgs_before /= pkgs_after) $
+ newPackages (pkgs_after \\ pkgs_before)
+
+ -- then, dynamic flags
+ io $ do
+ dyn_flags <- readIORef v_InitDynFlags
+ writeIORef v_DynFlags dyn_flags
+ leftovers <- processArgs dynamic_flags leftovers []
+ dyn_flags <- readIORef v_DynFlags
+ writeIORef v_InitDynFlags dyn_flags
+
+ if (not (null leftovers))
+ then throwDyn (CmdLineError ("unrecognised flags: " ++
unwords leftovers))
- else return ()
- )
+ else return ()
+
unsetOptions :: String -> GHCi ()
unsetOptions str
-- can't do GHC flags for now
if (not (null minus_opts))
- then throwDyn (OtherError "can't unset GHC command-line flags")
+ then throwDyn (CmdLineError "can't unset GHC command-line flags")
else return ()
isMinus ('-':s) = True
optToStr ShowType = "t"
optToStr RevertCAFs = "r"
+newPackages new_pkgs = do
+ state <- getGHCiState
+ dflags <- io (getDynFlags)
+ cmstate1 <- io (cmUnload (cmstate state) dflags)
+ setGHCiState state{ cmstate = cmstate1, target = Nothing }
+
+ io $ do
+ pkgs <- getPackageInfo
+ flushPackageCache pkgs
+
+ new_pkg_info <- getPackageDetails new_pkgs
+ mapM_ (linkPackage False) (reverse new_pkg_info)
+
-----------------------------------------------------------------------------
-- GHCi monad
linkPackages :: [LibrarySpec] -> [PackageConfig] -> IO ()
linkPackages cmdline_lib_specs pkgs
- = do mapM_ linkPackage pkgs
+ = do sequence_ [ linkPackage (name p `elem` loaded) p | p <- reverse pkgs ]
mapM_ preloadLib cmdline_lib_specs
where
+ -- packages that are already linked into GHCi
+ loaded = [ "concurrent", "posix", "text", "util" ]
+
preloadLib lib_spec
= do putStr ("Loading object " ++ showLS lib_spec ++ " ... ")
case lib_spec of
putStr ("failed (" ++ str ++ ")\n")
croak
- croak = throwDyn (OtherError "user specified .o/.so/.DLL could not be loaded.")
+ croak = throwDyn (CmdLineError "user specified .o/.so/.DLL could not be loaded.")
-linkPackage :: PackageConfig -> IO ()
+linkPackage :: Bool -> PackageConfig -> IO ()
-- ignore rts and gmp for now (ToDo; better?)
-linkPackage pkg
+linkPackage loaded_in_ghci pkg
| name pkg `elem` ["rts", "gmp"]
= return ()
| otherwise
let dirs = library_dirs pkg
let objs = hs_libraries pkg ++ extra_libraries pkg
classifieds <- mapM (locateOneObj dirs) objs
- let sos_first = filter isRight classifieds
- ++ filter (not.isRight) classifieds
+
+ -- Don't load the .so libs if this is a package GHCi is already
+ -- linked against, because we'll already have the .so linked in.
+ let (so_libs, obj_libs) = partition isRight classifieds
+ let sos_first | loaded_in_ghci = obj_libs
+ | otherwise = so_libs ++ obj_libs
+
mapM loadClassified sos_first
putStr "linking ... "
resolveObjs
if maybe_errmsg == nullPtr
then return ()
else do str <- peekCString maybe_errmsg
- throwDyn (OtherError ("can't find .o or .so/.DLL for: "
+ throwDyn (CmdLineError ("can't find .o or .so/.DLL for: "
++ dll_unadorned ++ " (" ++ str ++ ")" ))
locateOneObj :: [FilePath] -> String -> IO LibrarySpec
projects / ghc-hetmet.git / blobdiff