diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +# 0.2.0.0 + +* The key-entering algoritm is much more advanced now. + # 0.1.0.0 First release. Only Linux support is available so far. diff --git a/fake-type.cabal b/fake-type.cabal --- a/fake-type.cabal +++ b/fake-type.cabal @@ -1,5 +1,5 @@ name: fake-type -version: 0.1.0.0 +version: 0.2.0.0 synopsis: A crossplatform library to simulate keyboard input description: A crossplatform library to simulate keyboard input (so far it works only on Linux, but I'll add Windows and OS X soon). @@ -25,9 +25,10 @@ exposed-modules: FakeType -- other-modules: -- other-extensions: - build-depends: base >= 4.7 && < 5 + build-depends: X11 + , base >= 4.7 && < 5 , base-prelude == 0.1.* - , X11 + , split == 0.2.* extra-libraries: "Xtst" ghc-options: -Wall -fno-warn-unused-do-bind hs-source-dirs: lib diff --git a/lib/FakeType.hs b/lib/FakeType.hs --- a/lib/FakeType.hs +++ b/lib/FakeType.hs @@ -9,6 +9,7 @@ module FakeType ( sendString, + sendStringWithDelay, ) where @@ -18,6 +19,7 @@ import Foreign import Foreign.C.Types import Graphics.X11 +import Data.List.Split (chunksOf) foreign import ccall unsafe "HsXlib.h XGetKeyboardMapping" @@ -92,55 +94,66 @@ (advancePtr symArray (symIndex key 0 mapping)) amount -getSymbol - :: KeyCode -- ^ Key - -> Int -- ^ Position (usually 0..3) - -> Mapping - -> IO KeySym -getSymbol key pos mapping = - peekElemOff (symArray mapping) (symIndex key pos mapping) - -changeSymbol - :: Display - -> KeyCode -- ^ Key - -> Int -- ^ Position (usually 0..3) - -> KeySym -- ^ Symbol - -> Mapping - -> IO () -changeSymbol display key pos sym mapping = do - pokeElemOff (symArray mapping) (symIndex key pos mapping) sym - changeKeyboardMapping display (Just (key, 1)) mapping - flush display - -findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) -findM _ [] = return Nothing -findM p (x:xs) = do - r <- p x - if r then return (Just x) else findM p xs +charSym :: Char -> KeySym +charSym char = stringToKeysym ('U' : showHex (fromEnum char) "") --- Find a key that has an empty default position (so that we'd be able to --- simulate a keypress without having to use any key modifiers). If there's --- no empty key, throw an exception. -findFreeKey :: Mapping -> IO KeyCode -findFreeKey mapping@Mapping{..} = do - let isEmptyKey key = (== noSymbol) <$> getSymbol key 0 mapping - mbFreeKey <- findM isEmptyKey (take (fromIntegral keyCount) [minKey..]) - case mbFreeKey of - Nothing -> error "findFreeKey: couldn't find a free key" - Just k -> return k +-- Find unused keys (so that we'd be able to simulate a keypress without +-- having to use any key modifiers). An important thing is that the keys have +-- to be completely unused – keys -that have Alt or Super assigned to them- +-- will behave weirdly if you try to use them (even tho they don't have any +-- symbols in default positions). +findFreeKeys :: Mapping -> IO [KeyCode] +findFreeKeys mapping@Mapping{..} = do + let isEmptyKey key = do + -- Get a pointer to the part of symArray that corresponds to the key. + let keyPtr = advancePtr symArray (symIndex key 0 mapping) + -- Get the symbols (there's symPerKey of them). + syms <- peekArray (fromIntegral symPerKey) keyPtr + -- Check that they all are noSymbol. + return (all (== noSymbol) syms) + filterM isEmptyKey (take (fromIntegral keyCount) [minKey..]) sendString :: String -> IO () -sendString string = do - display <- openDisplay ":0.0" - mapping <- getKeyboardMapping display Nothing - freeKey <- findFreeKey mapping - sync display False - forM_ string $ \char -> do - let sym = stringToKeysym ('U' : showHex (fromEnum char) "") - changeSymbol display freeKey 0 sym mapping - xFakeKeyEvent display freeKey True 0 - xFakeKeyEvent display freeKey False 0 - sync display False - threadDelay 12000 - changeSymbol display freeKey 0 noSymbol mapping - closeDisplay display +sendString = sendStringWithDelay 20 8 20 + +sendStringWithDelay + :: Int -- ^ Delay after changing the layout (in ms) + -> Int -- ^ Delay after pressing\/releasing a key + -> Int -- ^ Delay after entering a batch of symbols + -> String + -> IO () +sendStringWithDelay mappingDelay pressDelay batchDelay string = + bracket (openDisplay ":0.0") closeDisplay $ \display -> do + mapping <- getKeyboardMapping display Nothing + freeKeys <- findFreeKeys mapping + when (null freeKeys) $ + error "sendStringWithDelay: couldn't find a free key" + let syncAndFlush = sync display False >> flush display + -- This function assigns given symbols to freeKeys. + let assignSyms syms = do + for_ (zip syms freeKeys) $ \(sym, key) -> do + let keyPtr = advancePtr (symArray mapping) (symIndex key 0 mapping) + pokeArray keyPtr (replicate (fromIntegral (symPerKey mapping)) sym) + changeKeyboardMapping display Nothing mapping + syncAndFlush + threadDelay (mappingDelay * 1000) + -- To enter a chunk of characters, we first assign all characters to free + -- keys and then press those keys; it's done like this because + -- changeKeyboardMapping is pretty slow and doing it for *each* key + -- results in glitches when typing. + let typeChunk chunk = do + let len = length chunk + assignSyms (map charSym chunk) + for_ (take len freeKeys) $ \key -> do + xFakeKeyEvent display key True 0 + syncAndFlush + threadDelay (pressDelay * 1000) + xFakeKeyEvent display key False 0 + syncAndFlush + threadDelay (pressDelay * 1000) + threadDelay (batchDelay * 1000) + -- Okay, let's enter all chunks. We also have to make the keys free again + -- after entering the chunks. + let chunks = chunksOf (length freeKeys) string + mapM_ typeChunk chunks `finally` + assignSyms (repeat noSymbol)