diff options
| -rw-r--r-- | RegUtils.hs | 44 |
1 files changed, 21 insertions, 23 deletions
diff --git a/RegUtils.hs b/RegUtils.hs index ba997a1..eccb6ad 100644 --- a/RegUtils.hs +++ b/RegUtils.hs @@ -16,6 +16,7 @@ import Foreign.ForeignPtr ( withForeignPtr ) import Foreign.Marshal.Alloc ( alloca, allocaBytes ) import Foreign.Ptr ( castPtr, plusPtr ) import Foreign.Storable ( peek, poke, sizeOf ) +import Graphics.Win32.Window ( sendMessage ) import System.IO.Error ( mkIOError, doesNotExistErrorType ) import System.Win32.Types import System.Win32.Registry @@ -23,25 +24,25 @@ import System.Win32.Registry getType :: HKEY -> String -> String -> IO (Maybe RegValueType) getType key subKeyPath valueName = bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> - withForeignPtr key $ \keyPtr -> - withTString valueName $ \valueNamePtr -> - alloca $ \typePtr -> do - ret <- c_RegQueryValueEx keyPtr valueNamePtr nullPtr typePtr nullPtr nullPtr + withForeignPtr key $ \p_key -> + withTString valueName $ \p_valueName -> + alloca $ \p_type -> do + ret <- c_RegQueryValueEx p_key p_valueName nullPtr p_type nullPtr nullPtr case ret of 0x0 -> do - type' <- peek typePtr - return $ Just type' + type_ <- peek p_type + return $ Just type_ 0x2 -> return Nothing _ -> failWith "RegQueryValueEx" ret getString :: HKEY -> String -> String -> IO String getString key subKeyPath valueName = bracket (regOpenKey key subKeyPath) regCloseKey $ \key -> - withForeignPtr key $ \keyPtr -> - withTString valueName $ \valueNamePtr -> + withForeignPtr key $ \p_key -> + withTString valueName $ \p_valueName -> alloca $ \dataSizePtr -> do poke dataSizePtr 0 - ret <- c_RegQueryValueEx keyPtr valueNamePtr nullPtr nullPtr nullPtr dataSizePtr + ret <- c_RegQueryValueEx p_key p_valueName nullPtr nullPtr nullPtr dataSizePtr case ret of 0x0 -> do dataSize <- peek dataSizePtr @@ -50,7 +51,7 @@ getString key subKeyPath valueName = allocaBytes (fromIntegral newDataSize) $ \dataPtr -> do poke (castPtr $ plusPtr dataPtr $ fromIntegral dataSize) '\0' failUnlessSuccess "RegQueryValueEx" $ - c_RegQueryValueEx keyPtr valueNamePtr nullPtr nullPtr dataPtr dataSizePtr + c_RegQueryValueEx p_key p_valueName nullPtr nullPtr dataPtr dataSizePtr peekTString $ castPtr dataPtr 0x2 -> ioError $ mkIOError doesNotExistErrorType "RegQueryValueEx" Nothing $ Just (subKeyPath ++ "\\" ++ valueName) _ -> failWith "RegQueryValueEx" ret @@ -58,31 +59,28 @@ getString key subKeyPath valueName = setString :: HKEY -> String -> String -> String -> IO () setString key subKeyPath valueName valueValue = bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey -> - withTString valueValue $ \ptr -> do - type' <- getType key subKeyPath valueName - regSetValueEx subKey valueName (fromMaybe rEG_SZ type') ptr $ (length valueValue + 1) * sizeOf (undefined :: TCHAR) + withTString valueValue $ \p_valueValue -> do + type_ <- getType key subKeyPath valueName + regSetValueEx subKey valueName (fromMaybe rEG_SZ type_) p_valueValue $ (length valueValue + 1) * sizeOf (undefined :: TCHAR) notifyEnvironmentUpdate -foreign import ccall "BroadcastSystemMessageW" - c_BroadcastSystemMessage :: DWORD -> LPDWORD -> UINT -> WPARAM -> LPARAM -> IO LONG - notifyEnvironmentUpdate :: IO () notifyEnvironmentUpdate = - withTString "Environment" $ \lparamPtr -> do - let wparam = fromIntegral $ castPtrToUINTPtr nullPtr - let lparam = fromIntegral $ castPtrToUINTPtr lparamPtr - c_BroadcastSystemMessage bSF_POSTMESSAGE nullPtr wM_SETTINGCHANGE wparam lparam + withTString "Environment" $ \p_lparam -> do + let wparam = 0 + let lparam = fromIntegral $ castPtrToUINTPtr p_lparam + let hwnd = castUINTPtrToPtr 0xffff + sendMessage hwnd wM_SETTINGCHANGE wparam lparam return () where - bSF_POSTMESSAGE = 0x10 wM_SETTINGCHANGE = 0x1A delValue :: HKEY -> String -> String -> IO () delValue key subKeyPath valueName = bracket (regOpenKey key subKeyPath) regCloseKey $ \subKey -> withForeignPtr subKey $ \subKeyPtr -> - withTString valueName $ \valueNamePtr -> do - ret <- c_RegDeleteValue subKeyPtr valueNamePtr + withTString valueName $ \p_valueName -> do + ret <- c_RegDeleteValue subKeyPtr p_valueName notifyEnvironmentUpdate case ret of 0x0 -> return () |