Escape control characters when adding user data to messages

src/ShellCheck/ASTLib.hs

@@ -29,6 +29,7 @@ import Data.Functor.Identity
 import Data.List
 import Data.Maybe
 import qualified Data.Map as Map
+import Numeric (showHex)
 
 arguments (T_SimpleCommand _ _ (cmd:args)) = args
 
@@ -367,6 +368,37 @@ getLiteralStringExt more = g
 -- Is this token a string literal?
 isLiteral t = isJust $ getLiteralString t
 
+-- Escape user data for messages.
+-- Messages generally avoid repeating user data, but sometimes it's helpful.
+e4m = escapeForMessage
+escapeForMessage :: String -> String
+escapeForMessage str = concatMap f str
+  where
+    f '\\' = "\\\\"
+    f '\n' = "\\n"
+    f '\r' = "\\r"
+    f '\t' = "\\t"
+    f '\x1B' = "\\e"
+    f c =
+        if shouldEscape c
+        then
+            if ord c < 256
+            then "\\x" ++ (pad0 2 $ toHex c)
+            else "\\U" ++ (pad0 4 $ toHex c)
+        else [c]
+
+    shouldEscape c =
+        (not $ isPrint c)
+        || (not (isAscii c) && not (isLetter c))
+
+    pad0 :: Int -> String -> String
+    pad0 n s =
+        let l = length s in
+            if l < n
+            then (replicate (n-l) '0') ++ s
+            else s
+    toHex :: Char -> String
+    toHex c = map toUpper $ showHex (ord c) ""
 
 -- Turn a NormalWord like foo="bar $baz" into a series of constituent elements like [foo=,bar ,$baz]
 getWordParts (T_NormalWord _ l)   = concatMap getWordParts l

src/ShellCheck/Analytics.hs

@@ -1759,7 +1759,7 @@ checkSshHereDoc _ (T_Redirecting _ redirs cmd)
     hasVariables = mkRegex "[`$]"
     checkHereDoc (T_FdRedirect _ _ (T_HereDoc id _ Unquoted token tokens))
         | not (all isConstant tokens) =
-        warn id 2087 $ "Quote '" ++ token ++ "' to make here document expansions happen on the server side rather than on the client."
+        warn id 2087 $ "Quote '" ++ (e4m token) ++ "' to make here document expansions happen on the server side rather than on the client."
     checkHereDoc _ = return ()
 checkSshHereDoc _ _ = return ()
 
@@ -2694,7 +2694,7 @@ checkUnpassedInFunctions params root =
 
     suggestParams (name, _, thing) =
         info (getId thing) 2119 $
-            "Use " ++ name ++ " \"$@\" if function's $1 should mean script's $1."
+            "Use " ++ (e4m name) ++ " \"$@\" if function's $1 should mean script's $1."
     warnForDeclaration func name =
         warn (getId func) 2120 $
             name ++ " references arguments, but none are ever passed."

src/ShellCheck/Checks/Commands.hs

@@ -900,7 +900,7 @@ checkWhileGetoptsCase = CommandCheck (Exactly "getopts") f
             notRequested = Map.difference handledMap requestedMap
 
     warnUnhandled optId caseId str =
-        warn caseId 2213 $ "getopts specified -" ++ str ++ ", but it's not handled by this 'case'."
+        warn caseId 2213 $ "getopts specified -" ++ (e4m str) ++ ", but it's not handled by this 'case'."
 
     warnRedundant (Just str, expr)
         | str `notElem` ["*", ":", "?"] =

src/ShellCheck/Parser.hs

@@ -1904,14 +1904,14 @@ readPendingHereDocs = do
     debugHereDoc tokenId endToken doc
         | endToken `isInfixOf` doc =
             let lookAt line = when (endToken `isInfixOf` line) $
-                      parseProblemAtId tokenId ErrorC 1042 ("Close matches include '" ++ line ++ "' (!= '" ++ endToken ++ "').")
+                      parseProblemAtId tokenId ErrorC 1042 ("Close matches include '" ++ (e4m line) ++ "' (!= '" ++ (e4m endToken) ++ "').")
             in do
-                  parseProblemAtId tokenId ErrorC 1041 ("Found '" ++ endToken ++ "' further down, but not on a separate line.")
+                  parseProblemAtId tokenId ErrorC 1041 ("Found '" ++ (e4m endToken) ++ "' further down, but not on a separate line.")
                   mapM_ lookAt (lines doc)
         | map toLower endToken `isInfixOf` map toLower doc =
-            parseProblemAtId tokenId ErrorC 1043 ("Found " ++ endToken ++ " further down, but with wrong casing.")
+            parseProblemAtId tokenId ErrorC 1043 ("Found " ++ (e4m endToken) ++ " further down, but with wrong casing.")
         | otherwise =
-            parseProblemAtId tokenId ErrorC 1044 ("Couldn't find end token `" ++ endToken ++ "' in the here document.")
+            parseProblemAtId tokenId ErrorC 1044 ("Couldn't find end token `" ++ (e4m endToken) ++ "' in the here document.")
 
 
 readFilename = readNormalWord
@@ -3168,7 +3168,7 @@ readConfigFile filename = do
         let line = "line " ++ (show . sourceLine $ errorPos err)
             suggestion = getStringFromParsec $ errorMessages err
         in
-            "Failed to process " ++ filename ++ ", " ++ line ++ ": "
+            "Failed to process " ++ (e4m filename) ++ ", " ++ line ++ ": "
                 ++ suggestion
 
 prop_readConfigKVs1 = isOk readConfigKVs "disable=1234"