diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ Usage ----- -Cgrep 6.4.22 Usage: cgrep [OPTION] [PATTERN] files... +Cgrep 6.5.0 Usage: cgrep [OPTION] [PATTERN] files... cgrep [OPTIONS] [ITEM] diff --git a/cgrep.cabal b/cgrep.cabal --- a/cgrep.cabal +++ b/cgrep.cabal @@ -1,6 +1,6 @@ Name: cgrep Description: Cgrep: a context-aware grep for source codes -Version: 6.4.22 +Version: 6.5.0 Synopsis: Command line tool Homepage: http://awgn.github.io/cgrep/ License: GPL-2 @@ -44,6 +44,7 @@ regex-posix >=0.90, either >= 4.0, mtl >= 2.0, - unix-compat >= 0.4 + unix-compat >= 0.4, + async >= 2.0 Ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N Default-language: Haskell2010 diff --git a/src/CGrep/CGrep.hs b/src/CGrep/CGrep.hs --- a/src/CGrep/CGrep.hs +++ b/src/CGrep/CGrep.hs @@ -64,7 +64,7 @@ } = i || k || d || h || n || s || c || o -cgrepDispatch :: Options -> FilePath -> CgrepFunction +cgrepDispatch :: Options -> FilePath -> SearchFunction cgrepDispatch opt f | not (regex opt) && not (hasTokenizerOpt opt) && not (semantic opt) && edit_dist opt = Levenshtein.search | not (regex opt) && not (hasTokenizerOpt opt) && not (semantic opt) = BoyerMoore.search diff --git a/src/CGrep/Common.hs b/src/CGrep/Common.hs --- a/src/CGrep/Common.hs +++ b/src/CGrep/Common.hs @@ -16,9 +16,9 @@ -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -- -module CGrep.Common (CgrepFunction, Text8, - getFileName, - getText, +module CGrep.Common (SearchFunction, Text8, + getTargetName, + getTargetContents, quickSearch, expandMultiline, ignoreCase, @@ -35,7 +35,7 @@ import Util -type CgrepFunction = Options -> [Text8] -> Maybe FilePath -> IO [Output] +type SearchFunction = Options -> [Text8] -> FilePath -> IO [Output] trim :: String -> String @@ -46,13 +46,14 @@ trim8 = (C.dropWhile isSpace . C.reverse) . C.dropWhile isSpace . C.reverse -getFileName :: Maybe FilePath -> String -getFileName Nothing = "" -getFileName (Just name) = name +getTargetName :: FilePath -> String +getTargetName [] = "" +getTargetName name = name -getText :: Maybe FilePath -> IO Text8 -getText = maybe C.getContents C.readFile +getTargetContents :: FilePath -> IO Text8 +getTargetContents [] = C.getContents +getTargetContents xs = C.readFile xs quickSearch :: Options -> [Text8] -> Text8 -> Maybe Bool diff --git a/src/CGrep/Strategy/BoyerMoore.hs b/src/CGrep/Strategy/BoyerMoore.hs --- a/src/CGrep/Strategy/BoyerMoore.hs +++ b/src/CGrep/Strategy/BoyerMoore.hs @@ -37,12 +37,12 @@ import Control.Arrow as A -search :: CgrepFunction +search :: Options -> [Text8] -> FilePath -> IO [Output] search opt ps f = do - let filename = getFileName f + let filename = getTargetName f - text <- getText f + text <- getTargetContents f -- transform text diff --git a/src/CGrep/Strategy/Cpp/Semantic.hs b/src/CGrep/Strategy/Cpp/Semantic.hs --- a/src/CGrep/Strategy/Cpp/Semantic.hs +++ b/src/CGrep/Strategy/Cpp/Semantic.hs @@ -37,12 +37,12 @@ import Util -search :: CgrepFunction +search :: Options -> [Text8] -> FilePath -> IO [Output] search opt ps f = do - let filename = getFileName f + let filename = getTargetName f - text <- getText f + text <- getTargetContents f -- transform text diff --git a/src/CGrep/Strategy/Cpp/Tokenizer.hs b/src/CGrep/Strategy/Cpp/Tokenizer.hs --- a/src/CGrep/Strategy/Cpp/Tokenizer.hs +++ b/src/CGrep/Strategy/Cpp/Tokenizer.hs @@ -33,12 +33,13 @@ import Options import Debug -search :: CgrepFunction + +search :: Options -> [Text8] -> FilePath -> IO [Output] search opt ps f = do - let filename = getFileName f + let filename = getTargetName f - text <- getText f + text <- getTargetContents f -- transform text diff --git a/src/CGrep/Strategy/Generic/Semantic.hs b/src/CGrep/Strategy/Generic/Semantic.hs --- a/src/CGrep/Strategy/Generic/Semantic.hs +++ b/src/CGrep/Strategy/Generic/Semantic.hs @@ -37,12 +37,13 @@ import Debug import Util -search :: CgrepFunction + +search :: Options -> [Text8] -> FilePath -> IO [Output] search opt ps f = do - let filename = getFileName f + let filename = getTargetName f - text <- getText f + text <- getTargetContents f -- transform text diff --git a/src/CGrep/Strategy/Levenshtein.hs b/src/CGrep/Strategy/Levenshtein.hs --- a/src/CGrep/Strategy/Levenshtein.hs +++ b/src/CGrep/Strategy/Levenshtein.hs @@ -30,12 +30,13 @@ import Options import Debug -search :: CgrepFunction + +search :: Options -> [Text8] -> FilePath -> IO [Output] search opt ps f = do - let filename = getFileName f + let filename = getTargetName f - text <- getText f + text <- getTargetContents f -- transform text diff --git a/src/CGrep/Strategy/Regex.hs b/src/CGrep/Strategy/Regex.hs --- a/src/CGrep/Strategy/Regex.hs +++ b/src/CGrep/Strategy/Regex.hs @@ -34,12 +34,12 @@ import Debug -search :: CgrepFunction +search :: Options -> [Text8] -> FilePath -> IO [Output] search opt ps f = do - let filename = getFileName f + let filename = getTargetName f - text <- getText f + text <- getTargetContents f -- transform text diff --git a/src/CmdOptions.hs b/src/CmdOptions.hs --- a/src/CmdOptions.hs +++ b/src/CmdOptions.hs @@ -25,17 +25,17 @@ options :: Mode (CmdArgs Options) options = cmdArgsMode $ Options - { file = "" &= typ "FILE" &= help "Read PATTERNs from file (one per line)" &= groupname "Pattern" + { file = "" &= typ "FILE" &= groupname "Pattern" &= help "Read PATTERNs from file (one per line)" , word_match = False &= help "Force word matching" &=explicit &= name "word" &= name "w" , prefix_match = False &= help "Force prefix matching" &=explicit &= name "prefix" &= name "p" , suffix_match = False &= help "Force suffix matching" &=explicit &= name "suffix" &= name "s" , edit_dist = False &= help "Use edit distance" &=explicit &= name "edit" &= name "e" , regex = False &= help "Use regex matching" &= explicit &= name "G" &=name "regex" , ignore_case = False &= help "Ignore case distinctions" - , code = False &= help "Enable search in source code" &= explicit &= name "c" &= name "code" &= groupname "\nContext filters (generic)" + , code = False &= groupname "\nContext filters (generic)" &= help "Enable search in source code" &= explicit &= name "c" &= name "code" , comment = False &= help "Enable search in comments" &= explicit &= name "m" &= name "comment" , literal = False &= help "Enable search in string literals" &= explicit &= name "l" &= name "literal" - , identifier = False &= help "Identifiers" &= explicit &= name "identifier" &= groupname "\nC/C++ language" + , identifier = False &= groupname "\nC/C++ language" &= help "Identifiers" &= explicit &= name "identifier" , keyword = False &= help "Keywords" &= explicit &= name "keyword" , directive = False &= help "Preprocessing directives" &= explicit &= name "directive" , header = False &= help "Headers names" &= explicit &= name "header" @@ -44,14 +44,13 @@ , char = False &= help "Literal chars" &= explicit &= name "char" , oper = False &= help "Operators" &= explicit &= name "oper" , semantic = False &= groupname "\nSemantic (generic)" &= help "\"code\" pattern: _, _1, _2... (identifiers), $, $1, $2... (optionals), ANY, KEY, STR, CHR, LIT, NUM, HEX, OCT, OR. -> e.g. \"_1(_1 && \\$)\" search for move constructors, \"struct OR class _ { OR : OR <\" search for a class declaration" &= explicit &= name "S" &= name "semantic" - , no_filename = False &= help "Suppress the file name prefix on output" &= explicit &= name "h" &= name "no-filename" &= groupname "\nOutput control" + , no_filename = False &= groupname "\nOutput control"&= help "Suppress the file name prefix on output" &= explicit &= name "h" &= name "no-filename" , no_linenumber= False &= help "Suppress the line number on output lines" &= explicit &= name "N" &= name "no-line-umber" , lang = [] &= help "Specify languages. ie: Cpp, +Haskell, -Makefile" , lang_maps = False &= help "Lists the language mappings" , force_language = Nothing &= help "Force the language" &= explicit &= name "force-language" , max_count = maxBound &= help "Stop search in files after INT matches" &= explicit &= name "max-count" , count = False &= help "Print only a count of matching lines per file" &= explicit &= name "count" - , jobs = 1 &= help "Number of jobs" , multiline = 1 &= help "Enable multi-line matching" , recursive = False &= help "Enable recursive search (don't follow symlinks)" &= explicit &= name "recursive" &= name "r" , deference_recursive = False &= help "Recursive, follow symlinks" &= explicit &= name "deference-recursive" &= name "R" @@ -62,10 +61,14 @@ #ifdef ENABLE_HINT , hint = Nothing &= typ "STRING" &= help "Haskell interpreter output. Var: file, row, line, tokens.\ne.g. \"file ++ show (tokens)\"" &= explicit &= name "hint" #endif - , json = False &= help "Format output as json object" &= explicit &= name "json" - , xml = False &= help "Format output as xml document" &= explicit &= name "xml" - , debug = 0 &= help "Debug level: 1, 2 or 3" &= groupname "\nMiscellaneous" - , no_turbo = False &= help "Disable turbo mode" - , others = [] &= args + , json = False &= help "Format output as json object" &= explicit &= name "json" + , xml = False &= help "Format output as xml document" &= explicit &= name "xml" + , jobs = 1 &= groupname "\nParallel" &= help "Number of jobs" + , cores = 0 &= help "Set number of physical processor used" + , chunk = 16 &= help "Set per-job chunk length" + , asynch = False &= help "Process chunk of files asynchronously" + , debug = 0 &= groupname "\nMiscellaneous" &= help "Debug level: 1, 2 or 3" + , no_turbo = False &= help "Disable turbo mode" + , others = [] &= args } &= summary ("Cgrep " ++ version ++ ". Usage: cgrep [OPTION] [PATTERN] files...") &= program "cgrep" diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -31,7 +31,7 @@ cgreprc = "cgreprc" version :: String -version = "6.4.22" +version = "6.5.0" data Config = Config diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -19,14 +19,16 @@ module Main where import Data.List -import qualified Data.Set as Set +import Data.List.Split import Data.Maybe import Data.Char import Data.Data() import Data.Function +import qualified Data.Set as Set import Control.Exception as E import Control.Concurrent +import Control.Concurrent.Async import Control.Monad.STM import Control.Concurrent.STM.TChan @@ -59,23 +61,33 @@ -- push file names in Chan... -withRecursiveContents :: Options -> FilePath -> [Lang] -> [String] -> Set.Set FilePath -> (FilePath -> IO ()) -> IO () +withRecursiveContents :: Options -> FilePath -> [Lang] -> [String] -> Set.Set FilePath -> ([FilePath] -> IO ()) -> IO () withRecursiveContents opts dir langs prunedir visited action = do isDir <- doesDirectoryExist dir if isDir then do - names <- liftM (filter (`notElem` [".", ".."])) $ getDirectoryContents dir - forM_ names $ \n -> E.catch (do - let path = dir n - filename = takeFileName path - fstatus <- getFileStatus path + xs <- getDirectoryContents dir + (dirs,files) <- partitionM doesDirectoryExist [dir x | x <- xs, x `notElem` [".", ".."]] + -- process files + let files' = flip mapMaybe files + (\n -> let filename = takeFileName n + in if isNothing $ getFileLang opts filename >>= (\f -> f `elemIndex` langs <|> toMaybe 0 (null langs)) + then Nothing + else Just n) + + unless (null files') $ + let chunks = chunksOf (Options.chunk opts) files' in + forM_ chunks $ \b -> action b + + -- process dirs + -- + forM_ dirs $ \path -> do + let filename = takeFileName path lstatus <- getSymbolicLinkStatus path - if isDirectory fstatus && (deference_recursive opts || not (isSymbolicLink lstatus)) - then unless (filename `elem` prunedir) $ do -- this is a good directory (unless already visited)! - cpath <- canonicalizePath path - unless (cpath `Set.member` visited) $ withRecursiveContents opts path langs prunedir (Set.insert cpath visited) action - else unless (isNothing $ getFileLang opts filename >>= (\f -> f `elemIndex` langs <|> toMaybe 0 (null langs))) $ action path - ) (\e -> let msg = show (e :: SomeException) in hPutStrLn stderr ("Cgrep: " ++ msg)) - else action dir + when ( deference_recursive opts || not (isSymbolicLink lstatus)) $ + unless (filename `elem` prunedir) $ do -- this is a good directory (unless already visited)! + cpath <- canonicalizePath path + unless (cpath `Set.member` visited) $ withRecursiveContents opts path langs prunedir (Set.insert cpath visited) action + else action [dir] -- read patterns from file @@ -107,16 +119,16 @@ forM_ [1 .. jobs opts] $ \_ -> forkIO $ void $ runEitherT $ forever $ do - f <- lift $ atomically $ readTChan in_chan - lift $ E.catch (case f of - Nothing -> atomically $ writeTChan out_chan [] - Just x -> do - out <- let op = sanitizeOptions x opts in - liftM (take (max_count opts)) $ cgrepDispatch op x op patterns $ guard (x /= "") >> f - unless (null out) $ atomically $ writeTChan out_chan out + fs <- lift $ atomically $ readTChan in_chan + lift $ E.catch (case fs of + [] -> atomically $ writeTChan out_chan [] + xs -> void ((if asynch opts then flip mapConcurrently + else forM) xs $ \x -> do + out <- let op = sanitizeOptions x opts in (liftM (take (max_count opts)) $ cgrepDispatch op x op patterns x) + unless (null out) $ atomically $ writeTChan out_chan out) ) - (\e -> let msg = show (e :: SomeException) in hPutStrLn stderr (showFile opts (fromMaybe "" f) ++ ": exception: " ++ if length msg > 80 then take 80 msg ++ "..." else msg)) - when (isNothing f) $ left () + (\e -> let msg = show (e :: SomeException) in hPutStrLn stderr (showFile opts (getTargetName (head fs)) ++ ": exception: " ++ if length msg > 80 then take 80 msg ++ "..." else msg)) + when (null fs) $ left () -- push the files to grep for... @@ -124,12 +136,12 @@ _ <- forkIO $ do if recursive opts || deference_recursive opts - then forM_ (if null paths then ["."] else paths) $ \p -> withRecursiveContents opts p langs (configPruneDirs conf) (Set.singleton p) (atomically . writeTChan in_chan . Just) - else forM_ (if null paths && not isTermIn then [""] else paths) (atomically . writeTChan in_chan . Just) + then forM_ (if null paths then ["."] else paths) $ \p -> withRecursiveContents opts p langs (configPruneDirs conf) (Set.singleton p) (atomically . writeTChan in_chan) + else forM_ (if null paths && not isTermIn then [""] else paths) (atomically . writeTChan in_chan . (:[])) -- enqueue EOF messages: - replicateM_ (jobs opts) ((atomically . writeTChan in_chan) Nothing) + replicateM_ (jobs opts) ((atomically . writeTChan in_chan) []) -- dump output until workers are done @@ -216,6 +228,10 @@ putStrLevel1 (debug opts) $ "files : " ++ show paths putStrLevel1 (debug opts) $ "isTermIn : " ++ show isTermIn putStrLevel1 (debug opts) $ "isTermOut : " ++ show isTermOut + + -- specify number of cores + + when (cores opts /= 0) $ setNumCapabilities (cores opts) parallelSearch conf opts paths patterns' langs (isTermIn, isTermOut) diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -53,7 +53,6 @@ , lang_maps :: Bool , force_language :: Maybe String -- General: - , jobs :: Int , multiline :: Int , recursive :: Bool , deference_recursive :: Bool @@ -68,6 +67,12 @@ , format :: Maybe String , json :: Bool , xml :: Bool + -- Parallel: + , jobs :: Int + , cores :: Int + , chunk :: Int + , asynch :: Bool + -- Misc: , debug :: Int , no_turbo :: Bool , others :: [String] diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -25,6 +25,16 @@ import Data.Maybe import Data.Char +import Control.Monad + +-- from hlint :-) + +partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a]) +partitionM f [] = return ([], []) +partitionM f (x:xs) = do + res <- f x + (as,bs) <- partitionM f xs + return ([x | res]++as, [x | not res]++bs) toMaybe :: a -> Bool -> Maybe a