[Pkg-haskell-commits] r1069 - in /packages/haskell-hsql-sqlite3: ./ branches/ branches/upstream/ branches/upstream/current/ branches/upstream/current/Database/ branches/upstream/current/Database/HSQL/
arjan at users.alioth.debian.org
arjan at users.alioth.debian.org
Mon Feb 4 06:28:11 UTC 2008
Author: arjan
Date: Mon Feb 4 06:28:11 2008
New Revision: 1069
URL: http://svn.debian.org/wsvn/pkg-haskell/?sc=1&rev=1069
Log:
[svn-inject] Installing original source of haskell-hsql-sqlite3
Added:
packages/haskell-hsql-sqlite3/
packages/haskell-hsql-sqlite3/branches/
packages/haskell-hsql-sqlite3/branches/upstream/
packages/haskell-hsql-sqlite3/branches/upstream/current/
packages/haskell-hsql-sqlite3/branches/upstream/current/Database/
packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/
packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/SQLite3.hsc (with props)
packages/haskell-hsql-sqlite3/branches/upstream/current/Setup.lhs (with props)
packages/haskell-hsql-sqlite3/branches/upstream/current/hsql-sqlite3.cabal (with props)
Added: packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/SQLite3.hsc
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/SQLite3.hsc?rev=1069&op=file
==============================================================================
--- packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/SQLite3.hsc (added)
+++ packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/SQLite3.hsc Mon Feb 4 06:28:11 2008
@@ -1,0 +1,155 @@
+-----------------------------------------------------------------------------------------
+{-| Module : Database.HSQL.SQLite3
+ Copyright : (c) Krasimir Angelov 2005
+ License : BSD-style
+
+ Maintainer : kr.angelov at 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)
Propchange: packages/haskell-hsql-sqlite3/branches/upstream/current/Database/HSQL/SQLite3.hsc
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-sqlite3/branches/upstream/current/Setup.lhs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-sqlite3/branches/upstream/current/Setup.lhs?rev=1069&op=file
==============================================================================
--- packages/haskell-hsql-sqlite3/branches/upstream/current/Setup.lhs (added)
+++ packages/haskell-hsql-sqlite3/branches/upstream/current/Setup.lhs Mon Feb 4 06:28:11 2008
@@ -1,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}
Propchange: packages/haskell-hsql-sqlite3/branches/upstream/current/Setup.lhs
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-sqlite3/branches/upstream/current/hsql-sqlite3.cabal
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-sqlite3/branches/upstream/current/hsql-sqlite3.cabal?rev=1069&op=file
==============================================================================
--- packages/haskell-hsql-sqlite3/branches/upstream/current/hsql-sqlite3.cabal (added)
+++ packages/haskell-hsql-sqlite3/branches/upstream/current/hsql-sqlite3.cabal Mon Feb 4 06:28:11 2008
@@ -1,0 +1,9 @@
+name: hsql-sqlite3
+version: 1.7
+license: BSD3
+author: Krasimir Angelov <kr.angelov at gmail.com>
+category: Database
+description: SQLite3 driver for HSQL.
+exposed-modules: Database.HSQL.SQLite3
+build-depends: base, hsql
+extensions: ForeignFunctionInterface, CPP
Propchange: packages/haskell-hsql-sqlite3/branches/upstream/current/hsql-sqlite3.cabal
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-haskell-commits
mailing list