diff options
| -rw-r--r-- | compiler/main/DynFlags.hs | 2 | ||||
| -rw-r--r-- | ghc/InteractiveUI.hs | 80 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/Makefile | 10 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/T10408A.script | 1 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/T10408A.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/T10408B.script | 1 | ||||
| -rw-r--r-- | testsuite/tests/ghci/scripts/T10408B.stdout | 2 | ||||
| -rwxr-xr-x | testsuite/tests/ghci/scripts/all.T | 5 |
8 files changed, 63 insertions, 40 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 6ebd04cca8..26f89c3a15 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -840,6 +840,8 @@ data DynFlags = DynFlags { flushErr :: FlushErr, haddockOptions :: Maybe String, + + -- | GHCi scripts specified by -ghci-script, in reverse order ghciScripts :: [String], -- Output style options diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index c1283b5ac2..77f65eb9c9 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -463,7 +463,7 @@ runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () runGHCi paths maybe_exprs = do dflags <- getDynFlags let - read_dot_files = not (gopt Opt_IgnoreDotGhci dflags) + ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags current_dir = return (Just ".ghci") @@ -481,45 +481,35 @@ runGHCi paths maybe_exprs = do canonicalizePath' fp = liftM Just (canonicalizePath fp) `catchIO` \_ -> return Nothing - sourceConfigFile :: (FilePath, Bool) -> GHCi () - sourceConfigFile (file, check_perms) = do + sourceConfigFile :: FilePath -> GHCi () + sourceConfigFile file = do exists <- liftIO $ doesFileExist file when exists $ do - perms_ok <- - if not check_perms - then return True - else do - dir_ok <- liftIO $ checkPerms (getDirectory file) - file_ok <- liftIO $ checkPerms file - return (dir_ok && file_ok) - when perms_ok $ do - either_hdl <- liftIO $ tryIO (openFile file ReadMode) - case either_hdl of - Left _e -> return () - -- NOTE: this assumes that runInputT won't affect the terminal; - -- can we assume this will always be the case? - -- This would be a good place for runFileInputT. - Right hdl -> - do runInputTWithPrefs defaultPrefs defaultSettings $ - runCommands $ fileLoop hdl - liftIO (hClose hdl `catchIO` \_ -> return ()) - where - getDirectory f = case takeDirectory f of "" -> "."; d -> d + either_hdl <- liftIO $ tryIO (openFile file ReadMode) + case either_hdl of + Left _e -> return () + -- NOTE: this assumes that runInputT won't affect the terminal; + -- can we assume this will always be the case? + -- This would be a good place for runFileInputT. + Right hdl -> + do runInputTWithPrefs defaultPrefs defaultSettings $ + runCommands $ fileLoop hdl + liftIO (hClose hdl `catchIO` \_ -> return ()) + -- setGHCContextFromGHCiState - when (read_dot_files) $ do - mcfgs0 <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ] - let mcfgs1 = zip mcfgs0 (repeat True) - ++ zip (ghciScripts dflags) (repeat False) - -- False says "don't check permissions". We don't - -- require that a script explicitly added by - -- -ghci-script is owned by the current user. (#6017) - mcfgs <- liftIO $ mapM (\(f, b) -> (,b) <$> canonicalizePath' f) mcfgs1 - mapM_ sourceConfigFile $ nub $ [ (f,b) | (Just f, b) <- mcfgs ] - -- nub, because we don't want to read .ghci twice if the - -- CWD is $HOME. + dot_cfgs <- if ignore_dot_ghci then return [] else do + dot_files <- catMaybes <$> sequence [ current_dir, app_user_dir, home_dir ] + liftIO $ filterM checkDirAndFilePerms dot_files + let arg_cfgs = reverse $ ghciScripts dflags + -- -ghci-script are collected in reverse order + mcfgs <- liftIO $ mapM canonicalizePath' $ dot_cfgs ++ arg_cfgs + -- We don't require that a script explicitly added by -ghci-script + -- is owned by the current user. (#6017) + mapM_ sourceConfigFile $ nub $ catMaybes mcfgs + -- nub, because we don't want to read .ghci twice if the CWD is $HOME. -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop @@ -540,7 +530,7 @@ runGHCi paths maybe_exprs = do let show_prompt = verbosity dflags > 0 || is_tty -- reset line number - getGHCiState >>= \st -> setGHCiState st{line_number=1} + modifyGHCiState $ \st -> st{line_number=1} case maybe_exprs of Nothing -> @@ -599,13 +589,23 @@ nextInputLine show_prompt is_tty -- don't need to check .. and ../.. etc. because "." always refers to -- the same directory while a process is running. -checkPerms :: String -> IO Bool +checkDirAndFilePerms :: FilePath -> IO Bool +checkDirAndFilePerms file = do + dir_ok <- checkPerms $ getDirectory file + file_ok <- checkPerms file + return (dir_ok && file_ok) + where + getDirectory f = case takeDirectory f of + "" -> "." + d -> d + +checkPerms :: FilePath -> IO Bool #ifdef mingw32_HOST_OS checkPerms _ = return True #else -checkPerms name = +checkPerms file = handleIO (\_ -> return False) $ do - st <- getFileStatus name + st <- getFileStatus file me <- getRealUserID let mode = System.Posix.fileMode st ok = (fileOwner st == me || fileOwner st == 0) && @@ -613,9 +613,9 @@ checkPerms name = otherWriteMode /= mode `intersectFileModes` otherWriteMode unless ok $ -- #8248: Improving warning to include a possible fix. - putStrLn $ "*** WARNING: " ++ name ++ + putStrLn $ "*** WARNING: " ++ file ++ " is writable by someone else, IGNORING!" ++ - "\nSuggested fix: execute 'chmod 644 " ++ name ++ "'" + "\nSuggested fix: execute 'chmod 644 " ++ file ++ "'" return ok #endif diff --git a/testsuite/tests/ghci/scripts/Makefile b/testsuite/tests/ghci/scripts/Makefile index 1ccd62f3b1..f70c0624c1 100644 --- a/testsuite/tests/ghci/scripts/Makefile +++ b/testsuite/tests/ghci/scripts/Makefile @@ -47,3 +47,13 @@ T9367: .PHONY: T9762_prep T9762_prep: '$(TEST_HC)' $(TEST_HC_OPTS) -O -fhpc -dynamic T9762B.hs + +.PHONY: T10408A +T10408A: + '$(TEST_HC)' $(TEST_HC_OPTS) --interactive -v0 \ + -ghci-script T10408A.script -ghci-script T10408B.script < /dev/null + +.PHONY: T10408B +T10408B: + '$(TEST_HC)' $(TEST_HC_OPTS) --interactive -v0 -ignore-dot-ghci \ + -ghci-script T10408A.script -ghci-script T10408B.script < /dev/null diff --git a/testsuite/tests/ghci/scripts/T10408A.script b/testsuite/tests/ghci/scripts/T10408A.script new file mode 100644 index 0000000000..a4e648be62 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T10408A.script @@ -0,0 +1 @@ +print "T10408A" diff --git a/testsuite/tests/ghci/scripts/T10408A.stdout b/testsuite/tests/ghci/scripts/T10408A.stdout new file mode 100644 index 0000000000..b13d0a49f8 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T10408A.stdout @@ -0,0 +1,2 @@ +"T10408A" +"T10408B" diff --git a/testsuite/tests/ghci/scripts/T10408B.script b/testsuite/tests/ghci/scripts/T10408B.script new file mode 100644 index 0000000000..cdf1bf5e0a --- /dev/null +++ b/testsuite/tests/ghci/scripts/T10408B.script @@ -0,0 +1 @@ +print "T10408B" diff --git a/testsuite/tests/ghci/scripts/T10408B.stdout b/testsuite/tests/ghci/scripts/T10408B.stdout new file mode 100644 index 0000000000..b13d0a49f8 --- /dev/null +++ b/testsuite/tests/ghci/scripts/T10408B.stdout @@ -0,0 +1,2 @@ +"T10408A" +"T10408B" diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index e25c7ec7e9..1582344063 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -211,3 +211,8 @@ test('T10322', when(opsys('darwin'), expect_broken(10322)), ghci_script, ['T10322.script']) test('T10321', normal, ghci_script, ['T10321.script']) + +test('T10408A', normal, run_command, + ['$MAKE -s --no-print-directory T10408A']) +test('T10408B', normal, run_command, + ['$MAKE -s --no-print-directory T10408B']) |