クリップボードへの転送 in Haskell DouKaku?

クリップボード(や同等の機能)へテキストを転送するプログラムをお願いします。また可能でしたらクリップボードのデータを取り出すプログラムもお願いします。

システムに依存する内容ですが、応用範囲が広いと思いましたので出題させてもらいました。

Windows用です。

import Graphics.Win32.GDI.Clip
import Foreign.Ptr
import Foreign.C.String

main = do { openClipboard nullPtr
          ; b <- isClipboardFormatAvailable cF_TEXT
          ; if b
            then do { p <- getClipboardData cF_TEXT
                    ; s <- peekCString (castPtr p)
                    ; putStrLn s
                    }
            else return ()
          ; closeClipboard
          }

こちらは、クリップボードへテキストを乗っけるコードです…標準入力とファイルに対応しています…

System.Win32.Mem.globalUnlockってエラーハンドリングにバグがあるようなのでc_GlobalUnlockを使っています…

module Main where

import Control.Monad
import Foreign.Ptr
import Foreign.Storable
import Graphics.Win32.GDI.Types
import Graphics.Win32.GDI.Clip
import Data.Word
import System
import System.IO
import System.Win32.Types
import System.Win32.Mem

when_ f m = when f (m >> return ())

withGlobalAlloc :: GlobalAllocFlags -> DWORD -> (HGLOBAL -> IO (HGLOBAL, a) ) -> IO a
withGlobalAlloc fl cb f = do
    h <- globalAlloc fl cb
    (h', ret) <- f h
    when_ (h' /= nullHANDLE) $ globalFree h
    return ret
    
withGlobalLock :: HGLOBAL -> (Addr -> IO a) -> IO a
withGlobalLock h f = do
    addr <- globalLock h
    ret <- f addr
    c_GlobalUnlock h
    return ret
    
withClipboard :: HWND -> (IO b) -> IO b
withClipboard hwnd fn = do
    openClipboard hwnd
    ret <- fn
    closeClipboard
    return ret
    
publishToClipboard :: HGLOBAL -> IO (HGLOBAL, ())
publishToClipboard h = withClipboard nullHANDLE (setData h)
    where
        setData h = do
            h' <- catch (c_SetClipboardData cF_TEXT h) (\_ -> return nullHANDLE)
            return (if h' == nullHANDLE then h else nullHANDLE, ())
            
copyStr :: String -> Addr -> IO ()
copyStr str pv = zipWithM_ (pokeByteOff pch) [0..] $ str
    where
        pch = castPtr pv :: Ptr Word8

setTextToClipboard str =  withGlobalAlloc gMEM_MOVEABLE (fromIntegral $ length str) $ _setTextToClipboard str
    where
        _setTextToClipboard :: String -> HGLOBAL -> IO (HGLOBAL, ())
        _setTextToClipboard str h = do
            withGlobalLock h (copyStr str)
            publishToClipboard h

main = do
    args <- liftM (take 1) $ getArgs >>= mapM (\path -> openFile path ReadMode)
    str <- hGetContents $ head $ args ++ [stdin]
    setTextToClipboard str

DouKaku?

クリップボードへの転送

Posted feedbacks - Haskell

Index

Feed

Other

Link

Pathtraq