hsql-sqlite3 (empty) → 1.1

raw patch · 3 files changed

+255/−0 lines, 3 filesdep +basedep +hsqlbuild-type:Customsetup-changed

Dependencies added: base, hsql

Files

• Database/HSQL/SQLite3.hsc +155/−0
• Setup.lhs +91/−0
• hsql-sqlite3.cabal +9/−0

@@ -0,0 +1,155 @@+-----------------------------------------------------------------------------------------+{-| Module      :  Database.HSQL.SQLite3+    Copyright   :  (c) Krasimir Angelov 2005+    License     :  BSD-style++    Maintainer  :  kr.angelov@gmail.com+    Stability   :  provisional+    Portability :  portable++    The module provides interface to SQLite3+-}+-----------------------------------------------------------------------------------------++module Database.HSQL.SQLite3(connect, module Database.HSQL) where++import Database.HSQL+import Database.HSQL.Types+import Foreign+import Foreign.C+import System.IO+import Control.Monad(when)+import Control.Exception(throwDyn)+import Control.Concurrent.MVar++#include <fcntl.h>+#include <sqlite3.h>++type SQLite3 = Ptr ()++foreign import ccall sqlite3_open :: CString -> (Ptr SQLite3) -> IO Int+foreign import ccall sqlite3_errmsg :: SQLite3 -> IO CString+foreign import ccall sqlite3_close :: SQLite3 -> IO ()+foreign import ccall sqlite3_exec :: SQLite3 -> CString -> FunPtr () -> Ptr () -> Ptr CString -> IO CInt+foreign import ccall sqlite3_get_table ::   SQLite3 -> CString -> Ptr (Ptr CString) -> Ptr CInt -> Ptr CInt -> Ptr CString -> IO CInt+foreign import ccall sqlite3_free_table :: Ptr CString -> IO ()+foreign import ccall sqlite3_free :: CString -> IO ()++foreign import ccall "strlen" strlen :: CString -> IO CInt++-----------------------------------------------------------------------------------------+-- routines for handling exceptions+-----------------------------------------------------------------------------------------++handleSqlResult :: CInt -> Ptr CString -> IO ()+handleSqlResult res ppMsg+	| res == (#const SQLITE_OK) = return ()+	| otherwise = do+		pMsg <- peek ppMsg+		msg <- peekCString pMsg+		sqlite3_free pMsg+		throwDyn (SqlError "E" (fromIntegral res) msg)++-----------------------------------------------------------------------------------------+-- Connect+-----------------------------------------------------------------------------------------++connect :: FilePath -> IOMode -> IO Connection+connect fpath mode =+	alloca $ \psqlite ->+	  withCString fpath $ \pFPath -> do+		res <- sqlite3_open pFPath psqlite+		sqlite <- peek psqlite+		when (res /= (#const SQLITE_OK)) $ do+			pMsg <- sqlite3_errmsg sqlite+			msg <- peekCString pMsg+			throwDyn (SqlError+			            { seState = "C"+			            , seNativeError = 0+			            , seErrorMsg = msg+			            })+		refFalse <- newMVar False+		let connection = Connection+			{ connDisconnect = sqlite3_close sqlite+			, connClosed     = refFalse+			, connExecute    = execute sqlite+			, connQuery      = query connection sqlite+			, connTables     = tables connection sqlite+			, connDescribe   = describe connection sqlite+			, connBeginTransaction = execute sqlite "BEGIN TRANSACTION"+			, connCommitTransaction = execute sqlite "COMMIT TRANSACTION"+			, connRollbackTransaction = execute sqlite "ROLLBACK TRANSACTION"+			}+		return connection+	where+		oflags1 = case mode of+	    	  ReadMode      -> (#const O_RDONLY)+	    	  WriteMode     -> (#const O_WRONLY)+	    	  ReadWriteMode -> (#const O_RDWR)+	    	  AppendMode    -> (#const O_APPEND)++		execute :: SQLite3 -> String -> IO ()+		execute sqlite query =+			withCString query $ \pQuery -> do+			alloca $ \ppMsg -> do+				res <- sqlite3_exec sqlite pQuery nullFunPtr nullPtr ppMsg+				handleSqlResult res ppMsg++		query :: Connection -> SQLite3 -> String -> IO Statement+		query connection sqlite query = do+			withCString query $ \pQuery -> do+			alloca $ \ppResult -> do+			alloca $ \pnRow -> do+			alloca $ \pnColumn -> do+			alloca $ \ppMsg -> do+				res <- sqlite3_get_table sqlite pQuery ppResult pnRow pnColumn ppMsg+				handleSqlResult res ppMsg+				pResult <- peek ppResult+				rows    <- fmap fromIntegral (peek pnRow)+				columns <- fmap fromIntegral (peek pnColumn)+				defs <- getFieldDefs pResult 0 columns+				refFalse <- newMVar False+				refIndex <- newMVar 0+				return (Statement+				              { stmtConn   = connection+				              , stmtClose  = sqlite3_free_table pResult+				              , stmtFetch  = fetch refIndex rows+				              , stmtGetCol = getColValue pResult refIndex columns rows+				              , stmtFields = defs+				              , stmtClosed = refFalse+				              })+			where+				getFieldDefs :: Ptr CString -> Int -> Int -> IO [FieldDef]+				getFieldDefs pResult index count+					| index >= count = return []+					| otherwise         = do+						name <- peekElemOff pResult index >>= peekCString+						defs <- getFieldDefs pResult (index+1) count+						return ((name,SqlText,True):defs)++		tables :: Connection -> SQLite3 -> IO [String]+		tables connection sqlite = do+			stmt <- query connection sqlite "select tbl_name from sqlite_master"+			collectRows (\stmt -> getFieldValue stmt "tbl_name") stmt++		describe :: Connection -> SQLite3 -> String -> IO [FieldDef]+		describe connection sqlite table = do+			stmt <- query connection sqlite ("pragma table_info("++table++")")+			collectRows getRow stmt+			where+				getRow stmt = do+					name <- getFieldValue stmt "name"+					notnull <- getFieldValue stmt "notnull"+					return (name, SqlText, notnull=="0")++		fetch tupleIndex countTuples =+			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples))++		getColValue pResult refIndex columns rows colNumber fieldDef f = do+			index <- readMVar refIndex+			when (index > rows) (throwDyn SqlNoData)+			pStr <- peekElemOff pResult (columns*index+colNumber)+			if pStr == nullPtr+			  then f fieldDef pStr 0+			  else do strLen <- strlen pStr+				  f fieldDef pStr (fromIntegral strLen)

@@ -0,0 +1,91 @@+#!/usr/bin/runghc++\begin{code}+import Distribution.PackageDescription+import Distribution.Setup+import Distribution.Simple+import Distribution.Simple.LocalBuildInfo+import Distribution.Simple.Utils(rawSystemVerbose)+import System.Info+import System.Exit+import System.Directory+import System.Process(runInteractiveProcess, waitForProcess)+import System.IO(hClose, hGetContents, hPutStr, stderr)+import Control.Monad(when)+import Control.Exception(try)++main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf}+  where+    preConf ::  [String] -> ConfigFlags -> IO HookedBuildInfo+    preConf args flags = do+      try (removeFile "SQLite3.buildinfo")+      return emptyHookedBuildInfo+    postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode+    postConf args flags _ localbuildinfo = do+      mb_bi <- pkgConfigBuildInfo (configVerbose flags) "sqlite3"+      let bi = case mb_bi of+                 Just bi -> bi+                 Nothing -> emptyBuildInfo{extraLibs=["sqlite3"]}+      writeHookedBuildInfo "SQLite3.buildinfo" (Just bi,[])+      return ExitSuccess+\end{code}++The following code is derived from Distribution.Simple.Configure+\begin{code}+findProgram+    :: String              -- ^ program name+    -> Maybe FilePath      -- ^ optional explicit path+    -> IO (Maybe FilePath)+findProgram name Nothing = do+  mb_path <- findExecutable name+  case mb_path of+    Nothing   -> message ("No " ++ name ++ " found")+    Just path -> message ("Using " ++ name ++ ": " ++ path)+  return mb_path+findProgram name (Just path) = do+  message ("Using " ++ name ++ ": " ++ path)+  return (Just path)++rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String+rawSystemGrabOutput verbose path args = do+  when (verbose > 0) $+        putStrLn (path ++ concatMap (' ':) args)+  (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing+  exitCode <- waitForProcess pid+  if exitCode /= ExitSuccess+    then do errMsg <- hGetContents err+            hPutStr stderr errMsg+            exitWith exitCode+    else return ()+  hClose inp+  hClose err+  hGetContents out++message :: String -> IO ()+message s = putStrLn $ "configure: " ++ s+\end{code}++Populate BuildInfo using pkg-config tool.+\begin{code}+pkgConfigBuildInfo :: Int -> String -> IO (Maybe BuildInfo)+pkgConfigBuildInfo verbose pkgName = do+  mb_pkg_config_path <- findProgram "pkg-config" Nothing+  case mb_pkg_config_path of+    Just pkg_config_path -> do+       message ("configuring "++pkgName++" package using pkg-config") +       res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--libs-only-l"]+       let libs = map (tail.tail) (words res)+       res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--libs-only-L"]+       let lib_dirs = map (tail.tail) (words res)+       res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--libs-only-other"]+       let ld_opts = words res+       res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--cflags-only-I"]+       let inc_dirs = map (tail.tail) (words res)+       res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--cflags-only-other"]+       let cc_opts = words res+       let bi = emptyBuildInfo{extraLibs=libs, extraLibDirs=lib_dirs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts}+       return (Just bi)+    Nothing -> do+       message ("The package will be built using default settings for "++pkgName)+       return Nothing+\end{code}

@@ -0,0 +1,9 @@+name:		 hsql-sqlite3+version:	 1.1+license:	 BSD3+author:		 Krasimir Angelov <kr.angelov@gmail.com>+category:	 Database+description: 	 SQLite3 driver for HSQL.+exposed-modules: Database.HSQL.SQLite3+build-depends: 	 base, hsql+extensions:      ForeignFunctionInterface, CPP