Hclip 2.0.0.1 → 3.0.0.0
raw patch · 3 files changed
+302/−253 lines, 3 filesdep +Hclipdep +tastydep +tasty-hunit
Dependencies added: Hclip, tasty, tasty-hunit
Files
- Hclip.cabal +63/−81
- System/Hclip.hs +194/−172
- tests/Tasty.hs +45/−0
Hclip.cabal view
@@ -1,81 +1,63 @@--- Initial Hclip.cabal generated by cabal init. For further documentation,--- see http://haskell.org/cabal/users-guide/---- The name of the package.-name: Hclip---- The package version. See the Haskell package versioning policy (PVP) --- for standards guiding when and how versions should be incremented.--- http://www.haskell.org/haskellwiki/Package_versioning_policy--- PVP summary: +-+------- breaking API changes--- | | +----- non-breaking API additions--- | | | +--- code changes with no API change-version: 2.0.0.1---- A short (one-line) description of the package.-synopsis: A small cross-platform library for reading and modifying the system clipboard.---- A longer description of the package.--- description: ---- URL for the project homepage or repository.-homepage: https://github.com/jetho/Hclip---- The license under which the package is released.-license: BSD3---- The file containing the license text.-license-file: LICENSE---- The package author(s).-author: Jens Thomas---- An email address to which users can send suggestions, bug reports, and --- patches.-maintainer: jetho@gmx.de---- A copyright notice.--- copyright: --category: System--Description:- A small cross-platform library for reading and modifying the system clipboard.- .- Hclip works on Windows, Mac OS X and Linux (but see the requirements below!).- .- Requirements:- .- * Windows: No additional requirements.- .- * Mac OS X: Requires the pbcopy and pbpaste commands, which ship with Mac OS X.- .- * Linux: Requires xclip or xsel installed.- -build-type: Simple---- Constraint on the version of Cabal needed to build this package.-cabal-version: >=1.8---library- -- Modules exported by the library.- exposed-modules: System.Hclip- Extensions: CPP, DeriveDataTypeable- - -- Modules included in this library but not exported.- -- other-modules: - - -- Other library packages from which modules are imported.- build-depends: base >= 3 && < 5, - process, - mtl, - strict - - if os(windows)- Build-depends: Win32---source-repository head- type: git- location: git://github.com/jetho/Hclip.git+ +name: Hclip + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 3.0.0.0 + +synopsis: A small cross-platform library for reading and modifying the system clipboard. + +homepage: https://github.com/jetho/Hclip + +license: BSD3 + +license-file: LICENSE + +author: Jens Thomas + +maintainer: jetho@gmx.de + +category: System + +description: + A small cross-platform library for reading and modifying the system clipboard. + . + Hclip works on Windows, Mac OS X and Linux (but see the requirements below!). + . + Requirements: + . + * Windows: No additional requirements. + . + * Mac OS X: Requires the pbcopy and pbpaste commands, which ship with Mac OS X. + . + * Linux: Requires xclip or xsel installed. + +build-type: Simple + +cabal-version: >=1.10 + + +library + exposed-modules: System.Hclip + other-extensions: CPP, DeriveDataTypeable, GADTs + default-language: Haskell2010 + build-depends: base >= 3 && < 5, process, mtl, strict + if os(windows) + build-depends: Win32 + +Test-suite Tasty + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tasty.hs + build-depends: base >= 3 && < 5, tasty, tasty-hunit, Hclip + + +source-repository head + type: git + location: git://github.com/jetho/Hclip.git +
System/Hclip.hs view
@@ -1,172 +1,194 @@--{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}------------------------------------------------------------------------- |--- Module : System.Hclip--- Copyright : (c) Jens Thomas--- License : BSD3------ Maintainer: Jens Thomas <jetho@gmx.de>--- Stability : experimental--- Portability: ------ A small cross-platform library for reading and modifying the system clipboard. --- -----------------------------------------------------------------------module System.Hclip (- getClipboard, - setClipboard, - modifyClipboard,- ClipboardException(..)- ) where--import System.Process (runInteractiveCommand, readProcessWithExitCode, waitForProcess)-import System.Info (os)-import System.IO (Handle, hPutStr, hClose)-import Data.Monoid -import Control.Exception (Exception, throwIO, bracket, bracket_)-import System.IO.Strict (hGetContents) -- see http://hackage.haskell.org/package/strict-import System.Exit (ExitCode(..))-import Control.Monad ((>=>), liftM)-import Data.List (intercalate, genericLength)-import Data.Typeable (Typeable)---- | for Windows support-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-import System.Win32.Mem (globalAlloc, globalLock, globalUnlock, copyMemory, gHND)-import Graphics.Win32.GDI.Clip (openClipboard, closeClipboard, emptyClipboard, getClipboardData, - setClipboardData, ClipboardFormat, isClipboardFormatAvailable, cF_TEXT)-import Foreign.C (withCAString, peekCAString)-import Foreign.Ptr (castPtr, nullPtr)-#endif----- | Clipboard Actions-data Command = GetClipboard - | SetClipboard String ----- | Supported Operating Systems-data Platform = Linux- | Darwin- | Windows- deriving (Show)----- | Exceptions-data ClipboardException = UnsupportedOS String- | NoTextualData- | MissingCommands [String]- deriving (Typeable)- -instance Exception ClipboardException--instance Show ClipboardException where- show (UnsupportedOS os) = "Unsupported Operating System: " ++ os- show NoTextualData = "Clipboard doesn't contain textual data."- show (MissingCommands cmds) = "Hclip requires " ++ apps ++ " installed."- where apps = intercalate " or " cmds----- | Read clipboard contents.-getClipboard :: IO String -getClipboard = dispatchCommand GetClipboard----- | Set clipboard contents.-setClipboard :: String -> IO String-setClipboard = dispatchCommand . SetClipboard----- | Apply function to clipboard and return its new contents.-modifyClipboard :: (String -> String) -> IO String-modifyClipboard = flip liftM getClipboard >=> setClipboard----- | Select the supported operating system.-dispatchCommand :: Command -> IO String-dispatchCommand = case os of- "linux" -> clipboard Linux- "darwin" -> clipboard Darwin-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)- "mingw32" -> clipboard Windows -#endif- unknownOS -> const . throwIO $ UnsupportedOS unknownOS----- | MAC OS: use pbcopy and pbpaste -clipboard Darwin command = withExternalCommand extCmd command- where extCmd = case command of- GetClipboard -> "pbpaste"- SetClipboard _ -> "pbcopy"----- | Linux: use xsel or xclip-clipboard Linux command = do- prog <- chooseFirstCommand ["xsel", "xclip"]- withExternalCommand (decode prog command) command- where- decode "xsel" GetClipboard = "xsel -o"- decode "xsel" (SetClipboard _) = "xsel -i"- decode "xclip" GetClipboard = "xclip -selection c -o"- decode "xclip" (SetClipboard _) = "xclip -selection c"- ---- | Windows: use WinAPI-#if defined(mingw32_HOST_OS) || defined(__MINGW32__)-clipboard Windows GetClipboard = - bracket_ (openClipboard nullPtr) closeClipboard $ do- isText <- isClipboardFormatAvailable cF_TEXT- if isText- then do - h <- getClipboardData cF_TEXT- bracket (globalLock h) globalUnlock $ peekCAString . castPtr- else throwIO NoTextualData--clipboard Windows (SetClipboard s) = - withCAString s $ \cstr -> do- mem <- globalAlloc gHND memSize- bracket (globalLock mem) globalUnlock $ \space -> do- copyMemory space (castPtr cstr) memSize- bracket_ (openClipboard nullPtr) closeClipboard $ do- emptyClipboard- setClipboardData cF_TEXT space- return s- where- memSize = genericLength s + 1-#endif----- | Run external command for accessing the system clipboard.-withExternalCommand :: String -> Command -> IO String-withExternalCommand prog command = - bracket (runInteractiveCommand prog)- (\(inp, outp, stderr, pid) -> mapM_ hClose [inp, outp, stderr] >> waitForProcess pid)- (\(inp, outp, _, _) -> action command (inp, outp))- where- action GetClipboard = hGetContents . stdout- action (SetClipboard text) = (flip hPutStr text >=> const (return text)) . stdin- stdin = fst- stdout = snd----- | Search for installed programs and return the first match.-chooseFirstCommand :: [String] -> IO String-chooseFirstCommand cmds = do- results <- mapM whichCommand cmds- maybe (throwIO $ MissingCommands cmds)- return- (getFirst . mconcat $ map First results)----- | Check if cmd is installed using the which command.-whichCommand :: String -> IO (Maybe String)-whichCommand cmd = do- (exitCode,_,_) <- readProcessWithExitCode "which" [cmd] ""- case exitCode of- ExitSuccess -> return $ Just cmd- ExitFailure _ -> return Nothing-+ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-------------------------------------------------------------------- +-- | +-- Module : System.Hclip +-- Copyright : (c) Jens Thomas +-- License : BSD3 +-- +-- Maintainer: Jens Thomas <jetho@gmx.de> +-- Stability : experimental +-- Portability: +-- +-- A small cross-platform library for reading and modifying the system clipboard. +-- +-------------------------------------------------------------------- + +module System.Hclip ( + getClipboard, + setClipboard, + modifyClipboard, + modifyClipboard_, + clearClipboard, + ClipboardException(..) + ) where + + +import System.Info (os) +import System.Process (runInteractiveCommand, readProcessWithExitCode, waitForProcess) +import System.IO (Handle, hPutStr, hClose) +import Data.Monoid +import System.IO.Strict (hGetContents) -- see http://hackage.haskell.org/package/strict +import System.Exit (ExitCode(..)) +import Data.List (intercalate) +import Control.Exception (Exception, throw, throwIO, bracket, bracket_) +import Data.Typeable (Typeable) +import Control.Applicative ((<$>)) +import Control.Monad ((>=>), liftM) + +-- | for Windows support +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +import System.Win32.Mem (globalAlloc, globalLock, globalUnlock, copyMemory, gHND) +import Graphics.Win32.GDI.Clip (openClipboard, closeClipboard, emptyClipboard, getClipboardData, + setClipboardData, ClipboardFormat, isClipboardFormatAvailable, cF_TEXT) +import Foreign.C (withCAString, peekCAString) +import Foreign.Ptr (castPtr, nullPtr) +#endif + + +type StdIn = Handle +type StdOut = Handle +type IOAction a = (StdIn, StdOut) -> IO a + + +-- | Clipboard Commands +data Command a where + GetClipboard :: Command (IO String) + SetClipboard :: String -> Command (IO ()) + + +-- | Supported Platforms +data Platform = Linux + | Darwin + | Windows + + +-- | Exceptions +data ClipboardException = UnsupportedOS String + | NoTextualData + | MissingCommands [String] + deriving (Typeable) + +instance Exception ClipboardException + +instance Show ClipboardException where + show (UnsupportedOS s) = "Unsupported Operating System: " ++ s + show NoTextualData = "Clipboard doesn't contain textual data." + show (MissingCommands cmds) = "Hclip requires " ++ apps ++ " installed." + where apps = intercalate " or " cmds + + +-- | Read clipboard contents. +getClipboard :: IO String +getClipboard = dispatch GetClipboard + +-- | Set clipboard contents. +setClipboard :: String -> IO () +setClipboard = dispatch . SetClipboard + +-- | Apply function to clipboard and return its new contents. +modifyClipboard :: (String -> String) -> IO String +modifyClipboard f = do + modified <- f <$> getClipboard + setClipboard modified + return modified + +-- | Apply function to clipboard. +modifyClipboard_ :: (String -> String) -> IO () +modifyClipboard_ = flip liftM getClipboard >=> setClipboard + +-- | Delete Clipboard contents. +clearClipboard :: IO () +clearClipboard = setClipboard "" + + +-- | Dispatch on the type of the Operating System. +dispatch cmd = execute (resolveOS os) cmd + where + resolveOS "linux" = Linux + resolveOS "darwin" = Darwin +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) + resolveOS "mingw32" = Windows +#endif + resolveOS unknownOS = throw . UnsupportedOS $ unknownOS + + +-- | Platform-specific execution. +execute :: Platform -> Command a -> a + +execute Linux cmd@GetClipboard = resolveLinuxApp cmd >>= flip withExternalApp readOutHandle +execute Linux cmd@(SetClipboard s) = resolveLinuxApp cmd >>= flip withExternalApp (writeInHandle s) + +execute Darwin GetClipboard = withExternalApp "pbpaste" readOutHandle +execute Darwin (SetClipboard s) = withExternalApp "pbcopy" $ writeInHandle s + +-- | Windows: use WinAPI +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +execute Windows GetClipboard = + bracket_ (openClipboard nullPtr) closeClipboard $ do + isText <- isClipboardFormatAvailable cF_TEXT + if isText + then do + h <- getClipboardData cF_TEXT + bracket (globalLock h) globalUnlock $ peekCAString . castPtr + else throwIO NoTextualData + +execute Windows (SetClipboard s) = + withCAString s $ \cstr -> do + mem <- globalAlloc gHND memSize + bracket (globalLock mem) globalUnlock $ \space -> do + copyMemory space (castPtr cstr) memSize + bracket_ (openClipboard nullPtr) closeClipboard $ do + emptyClipboard + setClipboardData cF_TEXT space + return () + where + memSize = genericLength s + 1 +#endif + + +-- | Determine the correct Linux command. +resolveLinuxApp :: Command a -> IO String +resolveLinuxApp cmd = decode cmd <$> chooseFirstApp ["xsel", "xclip"] + where + decode GetClipboard "xsel" = "xsel -o" + decode (SetClipboard _) "xsel" = "xsel -i" + decode GetClipboard "xclip" = "xclip -selection c -o" + decode (SetClipboard _) "xclip" = "xclip -selection c" + +-- | Run external app and apply action to the file handles. +withExternalApp :: String -> IOAction a -> IO a +withExternalApp app action = + bracket (runInteractiveCommand app) + (\(inp, outp, stderr, pid) -> mapM_ hClose [inp, outp, stderr] >> waitForProcess pid) + (\(inp, outp, _, _) -> action (inp, outp)) + +-- | Search for installed programs and return the first match. +chooseFirstApp :: [String] -> IO String +chooseFirstApp apps = do + results <- mapM whichCommand apps + maybe (throwIO $ MissingCommands apps) + return + (getFirst . mconcat $ map First results) + +-- | Check if cmd is installed by using the which command. +whichCommand :: String -> IO (Maybe String) +whichCommand cmd = do + (exitCode,_,_) <- readProcessWithExitCode "which" [cmd] "" + case exitCode of + ExitSuccess -> return $ Just cmd + ExitFailure _ -> return Nothing + +readOutHandle :: IOAction String +readOutHandle = hGetContents . stdout + +writeInHandle :: String -> IOAction () +writeInHandle s = flip hPutStr s . stdin + +stdin, stdout :: (StdIn, StdOut) -> Handle +stdin = fst +stdout = snd +
+ tests/Tasty.hs view
@@ -0,0 +1,45 @@+import Test.Tasty +import Test.Tasty.HUnit + +import System.Hclip + + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [unitTests] + + +unitTests = testGroup "Unit tests" + [ testCase "Clear Clipboard" $ do + setClipboard "Haskell" + clearClipboard + contents <- getClipboard + contents @?= "" + + , testCase "Set Clipboard" $ do + clearClipboard + setClipboard "Haskell" + contents <- getClipboard + contents @?= "Haskell" + + , testCase "Get Clipboard" $ do + setClipboard "Haskell" + contents <- getClipboard + contents @?= "Haskell" + + , testCase "Modify Clipboard" $ do + let f = reverse + s = "Haskell" + setClipboard s + modifyClipboard_ f + contents <- getClipboard + contents @?= (f s) + + , testCase "Modify Clipboard and return new contents" $ do + let f = reverse + s = "Haskell" + setClipboard s + contents <- modifyClipboard f + contents @?= f s + ]