[commit: ghc] master: ghci: don't let ctags/etags overwrite source files (a689c8e)
git at git.haskell.org
git at git.haskell.org
Fri Nov 20 13:28:52 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/a689c8edb1639669cb8df58092b8b77a0a581717/ghc
>---------------------------------------------------------------
commit a689c8edb1639669cb8df58092b8b77a0a581717
Author: Austin Seipp <austin at well-typed.com>
Date: Fri Nov 20 07:26:42 2015 -0600
ghci: don't let ctags/etags overwrite source files
A ource file which was accidently passed as parameter into `:ctags` or `:etags`
can be overwritten by tag data. This patch updates documentation to avoid
confusion in commands usage and prevents `collateAndWriteTags` from modifying
existing source files.
Reviewed By: thomie, bgamari, austin
Differential Revision: https://phabricator.haskell.org/D1471
GHC Trac Issues: #10989
>---------------------------------------------------------------
a689c8edb1639669cb8df58092b8b77a0a581717
ghc/GhciTags.hs | 16 +++++++++++++---
ghc/InteractiveUI.hs | 6 +++---
testsuite/tests/ghci/scripts/T10989.script | 15 +++++++++++++++
testsuite/tests/ghci/scripts/T10989.stderr | 6 ++++++
.../T5315.stdout => ghci/scripts/T10989.stdout} | 1 +
testsuite/tests/ghci/scripts/all.T | 5 +++++
6 files changed, 43 insertions(+), 6 deletions(-)
diff --git a/ghc/GhciTags.hs b/ghc/GhciTags.hs
index b250637..fa94ea6 100644
--- a/ghc/GhciTags.hs
+++ b/ghc/GhciTags.hs
@@ -28,9 +28,11 @@ import MonadUtils
import Data.Function
import Data.Maybe
import Data.Ord
+import DriverPhases
import Panic
import Data.List
import Control.Monad
+import System.Directory
import System.IO
import System.IO.Error
@@ -131,23 +133,31 @@ tagInfo dflags unqual exported kind name loc
(showSDocForUser dflags unqual $ ftext (srcLocFile loc))
(srcLocLine loc) (srcLocCol loc) Nothing
+-- throw an exception when someone tries to overwrite existing source file (fix for #10989)
+writeTagsSafely :: FilePath -> String -> IO ()
+writeTagsSafely file str = do
+ dfe <- doesFileExist file
+ if dfe && isSourceFilename file
+ then throwGhcException (CmdLineError (file ++ " is existing source file. " ++
+ "Please specify another file name to store tags data"))
+ else writeFile file str
collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
-- ctags style with the Ex exresion being just the line number, Vim et al
collateAndWriteTags CTagsWithLineNumbers file tagInfos = do
let tags = unlines $ sort $ map showCTag tagInfos
- tryIO (writeFile file tags)
+ tryIO (writeTagsSafely file tags)
-- ctags style with the Ex exresion being a regex searching the line, Vim et al
collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al
tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos
let tags = unlines $ sort $ map showCTag $concat tagInfoGroups
- tryIO (writeFile file tags)
+ tryIO (writeTagsSafely file tags)
collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos
let tagGroups = map processGroup tagInfoGroups
- tryIO (writeFile file $ concat tagGroups)
+ tryIO (writeTagsSafely file $ concat tagGroups)
where
processGroup [] = throwGhcException (CmdLineError "empty tag file group??")
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index 21eff8f..8f861ee 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -244,13 +244,13 @@ defFullHelpText =
" :cd <dir> change directory to <dir>\n" ++
" :cmd <expr> run the commands returned by <expr>::IO String\n" ++
" :complete <dom> [<rng>] <s> list completions for partial input string\n" ++
- " :ctags[!] [<file>] create tags file for Vi (default: \"tags\")\n" ++
+ " :ctags[!] [<file>] create tags file <file> for Vi (default: \"tags\")\n" ++
" (!: use regex instead of line number)\n" ++
" :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++
" precedence, ::<cmd> is always a builtin command)\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
- " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
+ " :etags [<file>] create tags file <file> for Emacs (default: \"TAGS\")\n" ++
" :help, :? display this list of commands\n" ++
" :info[!] [<name> ...] display information about the given names\n" ++
" (!: do not filter instances)\n" ++
@@ -265,7 +265,7 @@ defFullHelpText =
" :reload[!] reload the current module set\n" ++
" (!: defer type errors)\n" ++
" :run function [<arguments> ...] run the function with the given arguments\n" ++
- " :script <filename> run the script <filename>\n" ++
+ " :script <file> run the script <file>\n" ++
" :type <expr> show the type of <expr>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :!<command> run the shell command <command>\n" ++
diff --git a/testsuite/tests/ghci/scripts/T10989.script b/testsuite/tests/ghci/scripts/T10989.script
new file mode 100644
index 0000000..d109e4e
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T10989.script
@@ -0,0 +1,15 @@
+writeFile "dummy.hs" "t = putStrLn \"Test\""
+writeFile "dummy.lhs" "> t = putStrLn \"Test\""
+:ctags dummy.hs
+:ctags dummy.lhs
+:ctags! dummy.hs
+:ctags! dummy.lhs
+:etags dummy.hs
+:etags dummy.lhs
+:ctags dummy.tags
+:ctags! dummy.tags
+:etags dummy.tags
+:l dummy.hs
+t
+:l dummy.lhs
+t
diff --git a/testsuite/tests/ghci/scripts/T10989.stderr b/testsuite/tests/ghci/scripts/T10989.stderr
new file mode 100644
index 0000000..97b0d90
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T10989.stderr
@@ -0,0 +1,6 @@
+dummy.hs is existing source file. Please specify another file name to store tags data
+dummy.lhs is existing source file. Please specify another file name to store tags data
+dummy.hs is existing source file. Please specify another file name to store tags data
+dummy.lhs is existing source file. Please specify another file name to store tags data
+dummy.hs is existing source file. Please specify another file name to store tags data
+dummy.lhs is existing source file. Please specify another file name to store tags data
diff --git a/testsuite/tests/simplCore/should_run/T5315.stdout b/testsuite/tests/ghci/scripts/T10989.stdout
similarity index 50%
copy from testsuite/tests/simplCore/should_run/T5315.stdout
copy to testsuite/tests/ghci/scripts/T10989.stdout
index 345e6ae..95306f6 100644
--- a/testsuite/tests/simplCore/should_run/T5315.stdout
+++ b/testsuite/tests/ghci/scripts/T10989.stdout
@@ -1 +1,2 @@
Test
+Test
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 283251c..1a664d1 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -221,3 +221,8 @@ test('T10466', normal, ghci_script, ['T10466.script'])
test('T10501', normal, ghci_script, ['T10501.script'])
test('T10508', normal, ghci_script, ['T10508.script'])
test('T10520', normal, ghci_script, ['T10520.script'])
+test('T10989',
+ [
+ extra_clean(['dummy.hs', 'dummy.lhs', 'dummy.tags'])
+ ],
+ ghci_script, ['T10989.script'])
More information about the ghc-commits
mailing list