Hclip (empty) → 0.1.0.0

raw patch · 4 files changed

+268/−0 lines, 4 filesdep +Win32dep +basedep +mtlsetup-changed

Dependencies added: Win32, base, mtl, process, strict

Files

• Hclip.cabal +81/−0
• LICENSE +30/−0
• Setup.hs +2/−0
• System/Hclip.hs +155/−0

@@ -0,0 +1,81 @@+-- 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:             0.1.0.0++-- 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+  +  -- 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

@@ -0,0 +1,30 @@+Copyright (c) 2013, Jens Thomas++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Jens Thomas nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,155 @@++{-# LANGUAGE CPP #-}++--------------------------------------------------------------------+-- |+-- 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+  ) where++import System.Process (runInteractiveCommand, readProcessWithExitCode) +import System.Info (os)+import System.IO (Handle, hPutStr, hClose)+import Data.Monoid +import Control.Exception (bracket, bracket_)+import System.IO.Strict (hGetContents) -- see http://hackage.haskell.org/package/strict+import System.Exit +import Control.Monad.Error+import Data.List (intercalate, genericLength)++-- | 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 ErrorWithIO = ErrorT String IO++-- | Clipboard Actions+data Command = GetClipboard | SetClipboard String ++-- | Supported Operating Systems+data Linux = Linux deriving (Show)+data Darwin = Darwin deriving (Show)+data Windows = Windows deriving (Show)+++-- | type class for supported operating systems+class SupportedOS a where+  clipboard :: a -> Command -> IO (Either String String)++-- | read clipboard contents+getClipboard :: IO (Either String String)+getClipboard = dispatchCommand GetClipboard++-- | set clipboard contents+setClipboard :: String -> IO (Either String String)+setClipboard = dispatchCommand . SetClipboard++-- | apply function to clipboard and return the new contents+modifyClipboard :: (String -> String) -> IO (Either String String)+modifyClipboard = flip (liftM . liftM) getClipboard >=> either (return . Left) setClipboard++-- | select the supported operating system+dispatchCommand :: Command -> IO (Either String String)+dispatchCommand = case os of+  "linux" -> clipboard Linux+  "darwin" -> clipboard Darwin+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+  "mingw32" -> clipboard Windows +#endif+  unknownOS -> const $ return . Left $ "Unsupported OS: " ++ unknownOS++-- | MAC OS: use pbcopy and pbpaste    +instance SupportedOS Darwin where+  clipboard Darwin GetClipboard = runErrorT $ withExternalCommand "pbcopy" GetClipboard    +  clipboard Darwin c@(SetClipboard s) = runErrorT $ withExternalCommand "pbpaste" c++-- | Linux: use xsel or xclip+instance SupportedOS Linux where+  clipboard Linux command = runErrorT $ 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__)+instance SupportedOS Windows where+  clipboard Windows GetClipboard = +    bracket_ (openClipboard nullPtr) closeClipboard $ do+      isText <- isClipboardFormatAvailable cF_TEXT+      if isText+        then do +          h <- getClipboardData cF_TEXT+          bracket (globalLock h) globalUnlock $ liftM Right . peekCAString . castPtr+        else return $ Left "Clipboard doesn't contain textual data"++  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 $ Right s+    where+      memSize = genericLength s + 1+#endif+++-- | run external command for accessing the system clipboard+withExternalCommand :: String -> Command -> ErrorWithIO String+withExternalCommand prog command = +  liftIO $ bracket (runInteractiveCommand prog)+                   (\(inp,outp,stderr,_) -> mapM_ hClose [inp,outp,stderr])+                   (\(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] -> ErrorWithIO String+chooseFirstCommand cmds = do+  results <- liftIO $ mapM whichCommand cmds+  maybe (throwError $ "HClip requires " ++ apps ++ " installed.")+        return+        (getFirst . mconcat $ map First results)+  where apps = intercalate " or " cmds+++-- | use the which-command to check if cmd is installed+whichCommand :: String -> IO (Maybe String)+whichCommand cmd = do+  (exitCode,_,_) <- readProcessWithExitCode "which" [cmd] ""+  case exitCode of+    ExitSuccess -> return $ Just cmd+    ExitFailure _ -> return Nothing+