ghci: don't let ctags/etags overwrite source files
authorAustin Seipp <austin@well-typed.com>
Fri, 20 Nov 2015 13:26:42 +0000 (07:26 -0600)
committerAustin Seipp <austin@well-typed.com>
Fri, 20 Nov 2015 13:27:05 +0000 (07:27 -0600)
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

ghc/GhciTags.hs
ghc/InteractiveUI.hs
testsuite/tests/ghci/scripts/T10989.script [new file with mode: 0644]
testsuite/tests/ghci/scripts/T10989.stderr [new file with mode: 0644]
testsuite/tests/ghci/scripts/T10989.stdout [new file with mode: 0644]
testsuite/tests/ghci/scripts/all.T

index b250637..fa94ea6 100644 (file)
@@ -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??")
index 21eff8f..8f861ee 100644 (file)
@@ -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 (file)
index 0000000..d109e4e
--- /dev/null
@@ -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 (file)
index 0000000..97b0d90
--- /dev/null
@@ -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/ghci/scripts/T10989.stdout b/testsuite/tests/ghci/scripts/T10989.stdout
new file mode 100644 (file)
index 0000000..95306f6
--- /dev/null
@@ -0,0 +1,2 @@
+Test
+Test
index 283251c..1a664d1 100755 (executable)
@@ -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'])