HDBC-odbc 2.4.0.1 → 2.5.0.0
raw patch · 20 files changed
+914/−809 lines, 20 filesdep +concurrent-extradep ~HDBCdep ~base
Dependencies added: concurrent-extra
Dependency ranges changed: HDBC, base
Files
- Database/HDBC/ODBC.hs +2/−2
- Database/HDBC/ODBC/Api/Errors.hs +57/−0
- Database/HDBC/ODBC/Api/Imports.hsc +157/−0
- Database/HDBC/ODBC/Api/Types.hsc +37/−0
- Database/HDBC/ODBC/Connection.hsc +51/−71
- Database/HDBC/ODBC/ConnectionImpl.hs +4/−2
- Database/HDBC/ODBC/Log.hs +15/−0
- Database/HDBC/ODBC/Statement.hsc +238/−283
- Database/HDBC/ODBC/TypeConv.hsc +1/−1
- Database/HDBC/ODBC/Types.hs +0/−24
- Database/HDBC/ODBC/Utils.hs +18/−0
- Database/HDBC/ODBC/Utils.hsc +0/−127
- Database/HDBC/ODBC/Wrappers.hs +179/−0
- HDBC-odbc.cabal +97/−87
- cbits/hdbc-odbc-helper.c +23/−0
- cbits/hdbc-odbc-helper.h +20/−0
- hdbc-odbc-helper.c +0/−162
- hdbc-odbc-helper.h +0/−35
- testsrc/TestSbasics.hs +8/−8
- testsrc/Testbasics.hs +7/−7
Database/HDBC/ODBC.hs view
@@ -14,10 +14,10 @@ module Database.HDBC.ODBC ( - connectODBC, Connection(), getQueryInfo + connectODBC, Connection(), getQueryInfo, setAutoCommit ) where import Database.HDBC.ODBC.Connection(connectODBC, Connection()) -import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo) +import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo, setAutoCommit)
+ Database/HDBC/ODBC/Api/Errors.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP, DoAndIfThenElse #-} +module Database.HDBC.ODBC.Api.Errors + ( checkError + , raiseError + , sqlSucceeded + ) where + +import Control.Monad (unless) +import Database.HDBC (SqlError (..), throwSqlError) +import Database.HDBC.ODBC.Api.Imports +import Database.HDBC.ODBC.Api.Types +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable + +checkError :: String -> AnyHandle -> SQLRETURN -> IO () +checkError msg o res = + unless (sqlSucceeded res) $ raiseError msg res o + +raiseError :: String -> SQLRETURN -> AnyHandle -> IO a +raiseError msg code cconn = do + info <- getDiag ht hp 1 + throwSqlError SqlError + { seState = show (map fst info) + , seNativeError = fromIntegral code + , seErrorMsg = msg ++ ": " ++ show (map snd info) + } + where + (ht, hp) = case cconn of + EnvHandle c -> (sQL_HANDLE_ENV, castPtr c) + DbcHandle c -> (sQL_HANDLE_DBC, castPtr c) + StmtHandle c -> (sQL_HANDLE_STMT, castPtr c) + +foreign import ccall safe "sqlSucceeded" + c_sqlSucceeded :: SQLRETURN -> CInt + +sqlSucceeded :: SQLRETURN -> Bool +sqlSucceeded x = c_sqlSucceeded x /= 0 + +getDiag :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> IO [(String, String)] +getDiag ht hp irow = + allocaBytes 6 $ \csstate -> + alloca $ \pnaterr -> + allocaBytes 1025 $ \csmsg -> + alloca $ \pmsglen -> do + ret <- c_sqlGetDiagRecW ht hp irow csstate pnaterr csmsg 1024 pmsglen + if sqlSucceeded ret + then do + state <- peekCWStringLen (csstate, 5) + nat <- peek pnaterr + msglen <- peek pmsglen + msgstr <- peekCWStringLen (csmsg, fromIntegral msglen) + next <- getDiag ht hp (irow + 1) + return $ (state, show nat ++ ": " ++ msgstr) : next + else + return []
+ Database/HDBC/ODBC/Api/Imports.hsc view
@@ -0,0 +1,157 @@+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} +module Database.HDBC.ODBC.Api.Imports + ( sQL_HANDLE_ENV + , sQL_HANDLE_DBC + , sQL_HANDLE_STMT + , sQL_CLOSE + , sQL_UNBIND + , sQL_RESET_PARAMS + , c_sqlAllocHandle + , c_sqlCancel + , c_sqlCloseCursor + , c_sqlDisconnect + , c_sqlFreeHandle + , c_sqlFreeStmt + , c_sqlGetDiagRecW + , c_sqlSetConnectAttr + , c_sqlGetConnectAttr + , sQL_ATTR_AUTOCOMMIT + , sQL_AUTOCOMMIT_ON + , sQL_AUTOCOMMIT_OFF + , sQL_IS_UINTEGER + ) where + +import Database.HDBC.ODBC.Api.Types +import Database.HDBC.ODBC.Log +import Foreign.C.String +import Foreign.Ptr +import Text.Printf + +#ifdef mingw32_HOST_OS +#include <windows.h> +#endif + +#include <sql.h> +#include <sqlext.h> +#include <sqlucode.h> + +#ifdef mingw32_HOST_OS +#let CALLCONV = "stdcall" +#else +#let CALLCONV = "ccall" +#endif + +sQL_HANDLE_ENV :: SQLSMALLINT +sQL_HANDLE_ENV = #{const SQL_HANDLE_ENV} + +sQL_HANDLE_STMT :: SQLSMALLINT +sQL_HANDLE_STMT = #{const SQL_HANDLE_STMT} + +sQL_HANDLE_DBC :: SQLSMALLINT +sQL_HANDLE_DBC = #{const SQL_HANDLE_DBC} + +foreign import #{CALLCONV} safe "sql.h SQLAllocHandle" + imp_sqlAllocHandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN + +c_sqlAllocHandle :: SQLSMALLINT -> SQLHANDLE -> Ptr SQLHANDLE -> IO SQLRETURN +c_sqlAllocHandle handleType inputHandle outputHandlePtr = do + result <- imp_sqlAllocHandle handleType inputHandle outputHandlePtr + hdbcTrace $ printf "SQLAllocHandle(%d, %s, %s) returned %d" handleType (show inputHandle) (show outputHandlePtr) result + return result + +foreign import #{CALLCONV} safe "sql.h SQLFreeHandle" + imp_sqlFreeHandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN + +c_sqlFreeHandle :: SQLSMALLINT -> SQLHANDLE -> IO SQLRETURN +c_sqlFreeHandle handleType handle = do + result <- imp_sqlFreeHandle handleType handle + hdbcTrace $ printf "SQLFreeHandle(%d, %s) returned %d" handleType (show handle) result + return result + +foreign import #{CALLCONV} safe "sql.h SQLCancel" + imp_sqlCancel :: SQLHSTMT -> IO SQLRETURN + +c_sqlCancel :: SQLHSTMT -> IO SQLRETURN +c_sqlCancel hStmt = do + result <- imp_sqlCancel hStmt + hdbcTrace $ printf "SQLCancel(%s) returned %d" (show hStmt) result + return result + +foreign import #{CALLCONV} safe "sql.h SQLCloseCursor" + imp_sqlCloseCursor :: SQLHSTMT -> IO SQLRETURN + +c_sqlCloseCursor :: SQLHSTMT -> IO SQLRETURN +c_sqlCloseCursor hStmt = do + result <- imp_sqlCloseCursor hStmt + hdbcTrace $ printf "SQLCloseCursor(%s) returned %d" (show hStmt) result + return result + +foreign import #{CALLCONV} safe "sql.h SQLDisconnect" + imp_sqlDisconnect :: SQLHDBC -> IO SQLRETURN + +c_sqlDisconnect hDbc = do + result <- imp_sqlDisconnect hDbc + hdbcTrace $ printf "SQLDisconnect(%s) returned %d" (show hDbc) result + return result + +foreign import #{CALLCONV} safe "sql.h SQLGetDiagRecW" + imp_sqlGetDiagRecW :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CWString + -> Ptr SQLINTEGER -> CWString -> SQLSMALLINT + -> Ptr SQLSMALLINT -> IO SQLRETURN + +c_sqlGetDiagRecW :: SQLSMALLINT -> Ptr () -> SQLSMALLINT -> CWString -> Ptr SQLINTEGER + -> CWString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN +c_sqlGetDiagRecW handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr = do + result <- imp_sqlGetDiagRecW handleType handle recNumber sqlState nativeErrorPtr messageText bufferLength textLengthPtr + hdbcTrace $ printf "SqlGetDiagRec(%d, %s, %d, %s, %s, %s, %d, %s) returned %d" + handleType (show handle) recNumber (show sqlState) (show nativeErrorPtr) (show messageText) bufferLength (show textLengthPtr) result + return result + +sQL_CLOSE :: SQLUSMALLINT +sQL_CLOSE = #{const SQL_CLOSE} + +sQL_UNBIND :: SQLUSMALLINT +sQL_UNBIND = #{const SQL_UNBIND} + +sQL_RESET_PARAMS :: SQLUSMALLINT +sQL_RESET_PARAMS = #{const SQL_RESET_PARAMS} + +foreign import #{CALLCONV} safe "sql.h SQLFreeStmt" + imp_sqlFreeStmt :: SQLHSTMT -> SQLUSMALLINT -> IO SQLRETURN + +c_sqlFreeStmt :: SQLHSTMT -> SQLUSMALLINT -> IO SQLRETURN +c_sqlFreeStmt stmt option = do + result <- imp_sqlFreeStmt stmt option + hdbcTrace $ printf "SqlFreeStmt(%s, %d) returned %d" (show stmt) option result + return result + +foreign import #{CALLCONV} safe "sql.h SQLSetConnectAttr" + imp_sqlSetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN + +c_sqlSetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> IO SQLRETURN +c_sqlSetConnectAttr conn attr valuePtr stringLength = do + result <- imp_sqlSetConnectAttr conn attr valuePtr stringLength + hdbcTrace $ printf "SQLSetConnectAttr (%s, %d, %s, %d) returned %d" (show conn) attr (show valuePtr) stringLength result + return result + +foreign import #{CALLCONV} safe "sql.h SQLGetConnectAttr" + imp_sqlGetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN + +c_sqlGetConnectAttr :: SQLHDBC -> SQLINTEGER -> SQLPOINTER -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN +c_sqlGetConnectAttr conn attr valuePtr bufferLength stringLengthPtr = do + result <- imp_sqlGetConnectAttr conn attr valuePtr bufferLength stringLengthPtr + hdbcTrace $ printf "SQLGetConnectAttr (%s, %d, %s, %d, %s) return %d" + (show conn) attr (show valuePtr) bufferLength (show stringLengthPtr) result + return result + +sQL_ATTR_AUTOCOMMIT :: SQLINTEGER +sQL_ATTR_AUTOCOMMIT = #{const SQL_ATTR_AUTOCOMMIT} + +sQL_AUTOCOMMIT_ON :: SQLUINTEGER +sQL_AUTOCOMMIT_ON = #{const SQL_AUTOCOMMIT_ON} + +sQL_AUTOCOMMIT_OFF :: SQLUINTEGER +sQL_AUTOCOMMIT_OFF = #{const SQL_AUTOCOMMIT_OFF} + +sQL_IS_UINTEGER :: SQLINTEGER +sQL_IS_UINTEGER = #{const SQL_IS_UINTEGER}
+ Database/HDBC/ODBC/Api/Types.hsc view
@@ -0,0 +1,37 @@+{-# LANGUAGE EmptyDataDecls #-} +module Database.HDBC.ODBC.Api.Types + ( SQLENV, SQLDBC, SQLSTMT + , SQLHENV, SQLHDBC, SQLHSTMT, SQLHANDLE + , AnyHandle (..) + , SQLRETURN, SQLSMALLINT, SQLINTEGER + , SQLUSMALLINT, SQLUINTEGER, SQLPOINTER + ) where + +import Data.Int (Int16, Int32) +import Data.Word (Word16, Word32) +import Foreign.Ptr + +#ifdef mingw32_HOST_OS +#include <windows.h> +#endif +#include <sql.h> + +data SQLENV +data SQLDBC +data SQLSTMT + +type SQLHENV = Ptr SQLENV +type SQLHDBC = Ptr SQLDBC +type SQLHSTMT = Ptr SQLSTMT +type SQLHANDLE = Ptr () + +data AnyHandle = EnvHandle SQLHENV + | DbcHandle SQLHDBC + | StmtHandle SQLHSTMT + +type SQLRETURN = #{type SQLRETURN} +type SQLSMALLINT = #{type SQLSMALLINT} +type SQLINTEGER = #{type SQLINTEGER} +type SQLUSMALLINT = #{type SQLUSMALLINT} +type SQLUINTEGER = #{type SQLUINTEGER} +type SQLPOINTER = Ptr ()
Database/HDBC/ODBC/Connection.hsc view
@@ -8,11 +8,14 @@ import Database.HDBC import Database.HDBC.DriverUtils import qualified Database.HDBC.ODBC.ConnectionImpl as Impl -import Database.HDBC.ODBC.Types +import Database.HDBC.ODBC.Api.Imports +import Database.HDBC.ODBC.Api.Errors +import Database.HDBC.ODBC.Api.Types import Database.HDBC.ODBC.Statement +import Database.HDBC.ODBC.Wrappers import Foreign.C.Types import Foreign.C.String -import Foreign.Marshal +import Foreign.Marshal hiding (void) import Foreign.Storable import Database.HDBC.ODBC.Utils import Foreign.ForeignPtr @@ -20,7 +23,7 @@ import Data.Word import Data.Int import Control.Concurrent.MVar -import Control.Monad (when) +import Control.Monad (when, void) import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 @@ -50,7 +53,7 @@ SqlErrors just like other HDBC backends. The seErrorMsg field is specified as a String in HDBC. ODBC specifies this data as a list of strings. Therefore, this driver uses show on the data from ODBC. For friendly display, -or handling of individual component messages in your code, you can use +or handling of individual component messages in your code, you can use read on the seErrorMsg field in a context that expects @[String]@. Important note for MySQL users: @@ -71,44 +74,31 @@ -} connectODBC :: String -> IO Impl.Connection -connectODBC args = B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> - alloca $ \(penvptr::Ptr (Ptr CEnv)) -> - alloca $ \(pdbcptr::Ptr (Ptr CConn)) -> - do -- Create the Environment Handle - rc1 <- sqlAllocHandle #{const SQL_HANDLE_ENV} - nullPtr -- {const SQL_NULL_HANDLE} - (castPtr penvptr) - envptr <- peek penvptr - - checkError "connectODBC/alloc env" (EnvHandle envptr) rc1 - sqlSetEnvAttr envptr #{const SQL_ATTR_ODBC_VERSION} - (getSqlOvOdbc3) 0 +connectODBC args = + B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> do + -- Create the Environment Handle + env <- sqlAllocEnv + withEnvOrDie env $ \hEnv -> + sqlSetEnvAttr hEnv #{const SQL_ATTR_ODBC_VERSION} (getSqlOvOdbc3) 0 - -- Create the DBC handle. - sqlAllocHandle #{const SQL_HANDLE_DBC} (castPtr envptr) - (castPtr pdbcptr) - >>= checkError "connectODBC/alloc dbc" - (EnvHandle envptr) - dbcptr <- peek pdbcptr - wrappeddbcptr <- wrapconn dbcptr envptr nullPtr - fdbcptr <- newForeignPtr sqlFreeHandleDbc_ptr wrappeddbcptr + -- Create the DBC handle. + dbc <- sqlAllocDbc env + -- Now connect. + withDbcOrDie dbc $ \hDbc -> + sqlDriverConnect hDbc nullPtr cs (fromIntegral cslen) + nullPtr 0 nullPtr #{const SQL_DRIVER_NOPROMPT} + >>= checkError "connectODBC/sqlDriverConnect" (DbcHandle hDbc) - -- Now connect. - sqlDriverConnect dbcptr nullPtr cs (fromIntegral cslen) - nullPtr 0 nullPtr - #{const SQL_DRIVER_NOPROMPT} - >>= checkError "connectODBC/sqlDriverConnect" - (DbcHandle dbcptr) - mkConn args fdbcptr + mkConn args dbc -- FIXME: environment vars may have changed, should use pgsql enquiries -- for clone. -mkConn :: String -> Conn -> IO Impl.Connection -mkConn args iconn = withConn iconn $ \cconn -> +mkConn :: String -> DbcWrapper -> IO Impl.Connection +mkConn args iconn = withDbcOrDie iconn $ \cconn -> alloca $ \plen -> alloca $ \psqlusmallint -> - allocaBytes 128 $ \pbuf -> - do + allocaBytes 128 $ \pbuf -> + do children <- newMVar [] sqlGetInfo cconn #{const SQL_DBMS_VER} (castPtr pbuf) 127 plen >>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn) @@ -136,10 +126,7 @@ txninfo <- ((peek psqlusmallint)::IO (#{type SQLUSMALLINT})) let txnsupport = txninfo /= #{const SQL_TC_NONE} - when txnsupport - (disableAutoCommit cconn - >>= checkError "sqlSetConnectAttr" (DbcHandle cconn) - ) + when txnsupport . void $ fSetAutoCommit cconn False return $ Impl.Connection { Impl.getQueryInfo = fGetQueryInfo iconn children, Impl.disconnect = fdisconnect iconn children, @@ -156,7 +143,8 @@ Impl.dbServerVer = serverver, Impl.dbTransactionSupport = txnsupport, Impl.getTables = fgettables iconn, - Impl.describeTable = fdescribetable iconn + Impl.describeTable = fdescribetable iconn, + Impl.setAutoCommit = \x -> withDbcOrDie iconn $ \conn -> fSetAutoCommit conn x } -------------------------------------------------- @@ -169,40 +157,40 @@ finish sth return res -fcommit iconn = withConn iconn $ \cconn -> +fcommit iconn = withDbcOrDie iconn $ \cconn -> sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_COMMIT} >>= checkError "sqlEndTran commit" (DbcHandle cconn) -frollback iconn = withConn iconn $ \cconn -> +frollback iconn = withDbcOrDie iconn $ \cconn -> sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_ROLLBACK} >>= checkError "sqlEndTran rollback" (DbcHandle cconn) -fdisconnect iconn mchildren = withRawConn iconn $ \rawconn -> - withConn iconn $ \llconn -> - do closeAllChildren mchildren - res <- sqlFreeHandleDbc_app rawconn - -- FIXME: will this checkError segfault? - checkError "disconnect" (DbcHandle $ llconn) res - -foreign import #{CALLCONV} safe "sql.h SQLAllocHandle" - sqlAllocHandle :: #{type SQLSMALLINT} -> Ptr () -> - Ptr () -> IO (#{type SQLRETURN}) - -foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc_extra" - wrapconn :: Ptr CConn -> Ptr CEnv -> Ptr WrappedCConn -> IO (Ptr WrappedCConn) +fdisconnect iconn mchildren = do + closeAllChildren mchildren + freeDbcIfNotAlready True iconn -foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleDbc_finalizer" - sqlFreeHandleDbc_ptr :: FunPtr (Ptr WrappedCConn -> IO ()) +fGetAutoCommit :: SQLHDBC -> IO Bool +fGetAutoCommit hdbc = do + value <- with (0 :: SQLUINTEGER) $ \acBuf -> do + c_sqlGetConnectAttr hdbc sQL_ATTR_AUTOCOMMIT (castPtr acBuf) sQL_IS_UINTEGER nullPtr + >>= checkError "sqlGetConnectAttr" (DbcHandle hdbc) + peek acBuf + return $ value /= sQL_AUTOCOMMIT_OFF -foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleDbc_app" - sqlFreeHandleDbc_app :: Ptr WrappedCConn -> IO (#{type SQLRETURN}) +fSetAutoCommit :: SQLHDBC -> Bool -> IO Bool +fSetAutoCommit hdbc newValue = do + oldValue <- fGetAutoCommit hdbc + let newValueRaw = if newValue then sQL_AUTOCOMMIT_ON else sQL_AUTOCOMMIT_OFF + c_sqlSetConnectAttr hdbc sQL_ATTR_AUTOCOMMIT (wordPtrToPtr $ fromIntegral newValueRaw) sQL_IS_UINTEGER + >>= checkError "sqlSetConnectAttr" (DbcHandle hdbc) + return oldValue foreign import #{CALLCONV} safe "sql.h SQLSetEnvAttr" - sqlSetEnvAttr :: Ptr CEnv -> #{type SQLINTEGER} -> + sqlSetEnvAttr :: SQLHENV -> #{type SQLINTEGER} -> Ptr () -> #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLDriverConnect" - sqlDriverConnect :: Ptr CConn -> Ptr () -> CString -> #{type SQLSMALLINT} + sqlDriverConnect :: SQLHDBC -> Ptr () -> CString -> #{type SQLSMALLINT} -> CString -> #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} -> #{type SQLUSMALLINT} -> IO #{type SQLRETURN} @@ -210,19 +198,11 @@ foreign import ccall safe "hdbc-odbc-helper.h getSqlOvOdbc3" getSqlOvOdbc3 :: Ptr () -foreign import ccall safe "hdbc-odbc-helper.h SQLSetConnectAttr" - sqlSetConnectAttr :: Ptr CConn -> #{type SQLINTEGER} - -> Ptr #{type SQLUINTEGER} -> #{type SQLINTEGER} - -> IO #{type SQLRETURN} - foreign import #{CALLCONV} safe "sql.h SQLEndTran" - sqlEndTran :: #{type SQLSMALLINT} -> Ptr CConn -> #{type SQLSMALLINT} + sqlEndTran :: #{type SQLSMALLINT} -> SQLHDBC -> #{type SQLSMALLINT} -> IO #{type SQLRETURN} -foreign import ccall safe "hdbc-odbc-helper.h disableAutoCommit" - disableAutoCommit :: Ptr CConn -> IO #{type SQLRETURN} - foreign import #{CALLCONV} safe "sql.h SQLGetInfo" - sqlGetInfo :: Ptr CConn -> #{type SQLUSMALLINT} -> Ptr () -> + sqlGetInfo :: SQLHDBC -> #{type SQLUSMALLINT} -> Ptr () -> #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN}
Database/HDBC/ODBC/ConnectionImpl.hs view
@@ -4,7 +4,7 @@ import qualified Database.HDBC.Types as Types import Database.HDBC.ColTypes as ColTypes -data Connection = +data Connection = Connection { getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]), disconnect :: IO (), @@ -20,7 +20,9 @@ dbServerVer :: String, dbTransactionSupport :: Bool, getTables :: IO [String], - describeTable :: String -> IO [(String, ColTypes.SqlColDesc)] + describeTable :: String -> IO [(String, ColTypes.SqlColDesc)], + -- | Changes AutoCommit mode of the given connection. Returns previous value. + setAutoCommit :: Bool -> IO Bool } instance Types.IConnection Connection where
+ Database/HDBC/ODBC/Log.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-} +module Database.HDBC.ODBC.Log + ( hdbcLog + , hdbcTrace + ) where + +import System.IO + +hdbcLog :: String -> IO () +hdbcLog _ = return () +-- hdbcLog m = hPutStrLn stderr ("\n" ++ m) + +hdbcTrace :: String -> IO () +hdbcTrace _ = return () +-- hdbcTrace m = hPutStrLn stderr ("\n" ++ m)
Database/HDBC/ODBC/Statement.hsc view
@@ -13,9 +13,13 @@ import Database.HDBC.Types import Database.HDBC import Database.HDBC.DriverUtils -import Database.HDBC.ODBC.Types +import Database.HDBC.ODBC.Api.Errors +import Database.HDBC.ODBC.Api.Imports +import Database.HDBC.ODBC.Api.Types import Database.HDBC.ODBC.Utils +import Database.HDBC.ODBC.Log import Database.HDBC.ODBC.TypeConv +import Database.HDBC.ODBC.Wrappers import Foreign.C.String (castCUCharToChar) import Foreign.C.Types @@ -40,9 +44,7 @@ import System.IO (hPutStrLn, stderr) import Debug.Trace -l :: String -> IO () -l _ = return () --- l m = hPutStrLn stderr ("\n" ++ m) +import qualified Data.Foldable as F #ifdef mingw32_HOST_OS #include <windows.h> @@ -56,182 +58,134 @@ #let CALLCONV = "ccall" #endif -fGetQueryInfo :: Conn -> ChildList -> String +fGetQueryInfo :: DbcWrapper -> ChildList -> String -> IO ([SqlColDesc], [(String, SqlColDesc)]) fGetQueryInfo iconn children query = - do l "in fGetQueryInfo" + do hdbcTrace "in fGetQueryInfo" sstate <- newSState iconn query addChild children (wrapStmt sstate) -- We get error if we forget this one. Not sure why. fakeExecute' sstate fakeExecute' :: SState -> IO ([SqlColDesc], [(String, SqlColDesc)]) -fakeExecute' sstate = withConn (dbo sstate) $ \cconn -> - withCStringLen (squery sstate) $ \(cquery, cqlen) -> - alloca $ \(psthptr::Ptr (Ptr CStmt)) -> - do l "in fexecute" - -- public_ffinish sstate - rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr - sthptr <- peek psthptr - wrappedsthptr <- withRawConn (dbo sstate) - (\rawconn -> wrapstmt sthptr rawconn) - fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr - checkError "execute allocHandle" (DbcHandle cconn) rc1 +fakeExecute' sstate = do + hdbcTrace "fakeExecute'" + withStmtOrDie (sstmt sstate) $ \hStmt -> + withCStringLen (squery sstate) $ \(cquery, cqlen) -> do + hdbcTrace "fakeExecute' got stmt handle" + sqlPrepare hStmt cquery (fromIntegral cqlen) >>= + checkError "fakeExecute' prepare" (StmtHandle hStmt) - sqlPrepare sthptr cquery (fromIntegral cqlen) >>= - checkError "execute prepare" (StmtHandle sthptr) + -- parmCount <- getNumParams sthptr + parmInfo <- fgetparminfo hStmt - -- parmCount <- getNumParams sthptr - parmInfo <- fgetparminfo sthptr - - -- rc <- getNumResultCols sthptr - colInfo <- fgetcolinfo sthptr - return (parmInfo, colInfo) + -- rc <- getNumResultCols sthptr + colInfo <- fgetcolinfo hStmt + return (parmInfo, colInfo) -- | The Stament State data SState = SState - { stomv :: MVar (Maybe Stmt) - , dbo :: Conn - , squery :: String - , colinfomv :: MVar [(String, SqlColDesc)] - , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})]) + { sstmt :: StmtWrapper + , squery :: String + , stmtPrepared :: MVar Bool + , colinfomv :: MVar [(String, SqlColDesc)] + , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})]) } -- FIXME: we currently do no prepare optimization whatsoever. -newSState :: Conn -> String -> IO SState -newSState indbo query = - do newstomv <- newMVar Nothing - newcolinfomv <- newMVar [] - newBindCols <- newMVar Nothing - return SState - { stomv = newstomv - , dbo = indbo - , squery = query - , colinfomv = newcolinfomv - , bindColsMV = newBindCols - } +newSState :: DbcWrapper -> String -> IO SState +newSState indbo query = SState + <$> sqlAllocStmt indbo + <*> pure query + <*> newMVar False + <*> newMVar [] + <*> newMVar Nothing wrapStmt :: SState -> Statement wrapStmt sstate = Statement { execute = fexecute sstate , executeRaw = return () , executeMany = fexecutemany sstate - , finish = public_ffinish sstate + , finish = ffinish sstate , fetchRow = ffetchrow sstate , originalQuery = (squery sstate) , getColumnNames = readMVar (colinfomv sstate) >>= (return . map fst) , describeResult = readMVar (colinfomv sstate) } -newSth :: Conn -> ChildList -> String -> IO Statement +newSth :: DbcWrapper -> ChildList -> String -> IO Statement newSth indbo mchildren query = - do l "in newSth" + do hdbcTrace "in newSth" sstate <- newSState indbo query let retval = wrapStmt sstate addChild mchildren retval return retval -makesth :: Conn -> [Char] -> IO (ForeignPtr WrappedCStmt) -makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) -> - withConn iconn $ \cconn -> - withCString "" $ \emptycs -> - do rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr - sthptr <- peek psthptr - wrappedsthptr <- withRawConn iconn - (\rawconn -> wrapstmt sthptr rawconn) - fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr - checkError (name ++ " allocHandle") (DbcHandle cconn) rc1 - return fsthptr - -wrapTheStmt :: Conn -> Stmt -> IO (Statement, SState) -wrapTheStmt iconn fsthptr = - do sstate <- newSState iconn "" - sstate <- newSState iconn "" - swapMVar (stomv sstate) (Just fsthptr) - let sth = wrapStmt sstate - return (sth, sstate) - -fgettables :: Conn -> IO [String] -fgettables iconn = - do fsthptr <- makesth iconn "fgettables" - l "fgettables: after makesth" - withStmt fsthptr (\sthptr -> - simpleSqlTables sthptr >>= - checkError "gettables simpleSqlTables" - (StmtHandle sthptr) - ) - l "fgettables: after withStmt" - (sth, sstate) <- wrapTheStmt iconn fsthptr - withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)) - l "fgettables: after wrapTheStmt" - results <- fetchAllRows' sth - l ("fgettables: results: " ++ (show results)) - return $ map (\x -> fromSql (x !! 2)) results +fgettables :: DbcWrapper -> IO [String] +fgettables iconn = do + hdbcTrace "fgettables" + sstate <- newSState iconn "" + withStmtOrDie (sstmt sstate) $ \hStmt -> do + hdbcTrace "fgettables got stmt handle" + simpleSqlTables hStmt >>= checkError "gettables simpleSqlTables" (StmtHandle hStmt) + fgetcolinfo hStmt >>= swapMVar (colinfomv sstate) + results <- fetchAllRows' $ wrapStmt sstate + return $ map (\x -> fromSql (x !! 2)) results -fdescribetable :: Conn -> String -> IO [(String, SqlColDesc)] -fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ - \(cs, csl) -> - do fsthptr <- makesth iconn "fdescribetable" - withStmt fsthptr (\sthptr -> - simpleSqlColumns sthptr cs (fromIntegral csl) >>= - checkError "fdescribetable simpleSqlColumns" - (StmtHandle sthptr) - ) - (sth, sstate) <- wrapTheStmt iconn fsthptr - withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)) - results <- fetchAllRows' sth - l (show results) - return $ map fromOTypeCol results +fdescribetable :: DbcWrapper -> String -> IO [(String, SqlColDesc)] +fdescribetable iconn tablename = do + hdbcTrace "fdescribetable" + B.useAsCStringLen (BUTF8.fromString tablename) $ \(cs, csl) -> do + sstate <- newSState iconn tablename + withStmtOrDie (sstmt sstate) $ \hStmt -> do + hdbcTrace "fdescribetable got stmt handle" + simpleSqlColumns hStmt cs (fromIntegral csl) >>= checkError "fdescribetable simpleSqlColumns" (StmtHandle hStmt) + fgetcolinfo hStmt >>= swapMVar (colinfomv sstate) + results <- fetchAllRows' $ wrapStmt sstate + hdbcTrace $ show results + return $ map fromOTypeCol results {- For now, we try to just handle things as simply as possible. FIXME lots of room for improvement here (types, etc). -} fexecute :: SState -> [SqlValue] -> IO Integer -fexecute sstate args = - withConn (dbo sstate) $ \cconn -> - B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) -> - alloca $ \(psthptr::Ptr (Ptr CStmt)) -> - do l $ "in fexecute: " ++ show (squery sstate) ++ show args - public_ffinish sstate - rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr - sthptr <- peek psthptr - wrappedsthptr <- withRawConn (dbo sstate) - (\rawconn -> wrapstmt sthptr rawconn) - fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr - checkError "execute allocHandle" (DbcHandle cconn) rc1 - - sqlPrepare sthptr cquery (fromIntegral cqlen) >>= - checkError "execute prepare" (StmtHandle sthptr) +fexecute sstate args = do + hdbcTrace $ "fexecute: " ++ show (squery sstate) ++ show args + (finish, result) <- withStmtOrDie (sstmt sstate) $ \hStmt -> do + hdbcTrace "fexecute got stmt handle" + -- Realloc the statement + modifyMVar_ (stmtPrepared sstate) $ \prep -> do + unless prep $ + B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) -> do + sqlPrepare hStmt cquery (fromIntegral cqlen) >>= checkError "execute prepare" (StmtHandle hStmt) + return True -- Statement is always prepared after this block completes. - bindArgs <- zipWithM (bindParam sthptr) args [1..] - l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args - r <- sqlExecute sthptr - mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs) + bindArgs <- zipWithM (bindParam hStmt) args [1..] + hdbcTrace $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args + r <- sqlExecute hStmt + mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs) - case r of - #{const SQL_NO_DATA} -> return () -- Update that did nothing - x -> checkError "execute execute" (StmtHandle sthptr) x + case r of + #{const SQL_NO_DATA} -> return () -- Update that did nothing + x -> checkError "execute execute" (StmtHandle hStmt) x - rc <- getNumResultCols sthptr + rc <- getNumResultCols hStmt - case rc of - 0 -> do rowcount <- getSqlRowCount sthptr - ffinish fsthptr - swapMVar (colinfomv sstate) [] - touchForeignPtr fsthptr - return (fromIntegral rowcount) - colcount -> do fgetcolinfo sthptr >>= swapMVar (colinfomv sstate) - swapMVar (stomv sstate) (Just fsthptr) - touchForeignPtr fsthptr - return 0 + case rc of + 0 -> do rowcount <- getSqlRowCount hStmt + return (True, fromIntegral rowcount) + colcount -> do fgetcolinfo hStmt >>= swapMVar (colinfomv sstate) + return (False, 0) + when finish $ ffinish sstate + return result -getNumResultCols :: Ptr CStmt -> IO #{type SQLSMALLINT} +getNumResultCols :: SQLHSTMT -> IO #{type SQLSMALLINT} getNumResultCols sthptr = alloca $ \pcount -> - do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" + do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount -- Bind a parameter column before execution. -bindParam :: Ptr CStmt -> SqlValue -> Word16 +bindParam :: SQLHSTMT -> SqlValue -> Word16 -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar)) bindParam sthptr arg icol = alloca $ \pdtype -> alloca $ \pcolsize -> @@ -247,19 +201,19 @@ So, make sure we either free of have foreignized everything before control passes out of this function. -} - do l $ "Binding col " ++ show icol ++ ": " ++ show arg + do hdbcTrace $ "Binding col " ++ show icol ++ ": " ++ show arg rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable - l $ "rc1 is " ++ show (isOK rc1) - coltype <- if isOK rc1 then Just <$> peek pdtype else return Nothing - colsize <- if isOK rc1 then Just <$> peek pcolsize else return Nothing - decdigits <- if isOK rc1 then Just <$> peek pdecdigits else return Nothing - l $ "Results: " ++ show (coltype, colsize, decdigits) + hdbcTrace $ "rc1 is " ++ show (sqlSucceeded rc1) + coltype <- if sqlSucceeded rc1 then Just <$> peek pdtype else return Nothing + colsize <- if sqlSucceeded rc1 then Just <$> peek pcolsize else return Nothing + decdigits <- if sqlSucceeded rc1 then Just <$> peek pdecdigits else return Nothing + hdbcTrace $ "Results: " ++ show (coltype, colsize, decdigits) case arg of SqlNull -> -- NULL parameter, bind it as such. - do l "Binding null" + do hdbcTrace "Binding null" rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT} - #{const SQL_C_CHAR} + #{const SQL_C_CHAR} (fromMaybe #{const SQL_CHAR} coltype) (fromMaybe 0 colsize) (fromMaybe 0 decdigits) @@ -270,29 +224,29 @@ x -> do -- Otherwise, we have to allocate RAM, make sure it's -- not freed now, and pass it along... boundValue <- bindSqlValue x - do pcslen <- malloc + do pcslen <- malloc poke pcslen . fromIntegral $ bvBufferSize boundValue rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT} - (bvValueType boundValue) + (bvValueType boundValue) (fromMaybe (bvDefaultColumnType boundValue) coltype) - (fromMaybe (bvDefaultColumnSize boundValue) colsize) + (fromMaybe (bvDefaultColumnSize boundValue) colsize) (fromMaybe (bvDefaultDecDigits boundValue) decdigits) (castPtr $ bvBuffer boundValue) - (bvBufferSize boundValue) + (bvBufferSize boundValue) pcslen - if isOK rc2 + if sqlSucceeded rc2 then do -- We bound it. Make foreignPtrs and return. return $ Just (pcslen, castPtr $ bvBuffer boundValue) else do -- Binding failed. Free the data and raise -- error. free pcslen free (bvBuffer boundValue) - checkError ("bindparameter " ++ show icol) + checkError ("bindparameter " ++ show icol) (StmtHandle sthptr) rc2 return Nothing -- will never get hit -getSqlRowCount :: Ptr CStmt -> IO Int32 +getSqlRowCount :: SQLHSTMT -> IO Int32 getSqlRowCount cstmt = alloca $ \prows -> do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt) peek prows @@ -300,17 +254,17 @@ data BoundValue = BoundValue -- | Type of the value in the buffer - { bvValueType :: #{type SQLSMALLINT} + { bvValueType :: !(#{type SQLSMALLINT}) -- | Type of the SQL value to use if ODBC driver doesn't report one - , bvDefaultColumnType :: #{type SQLSMALLINT} - , bvDefaultColumnSize :: #{type SQLULEN} - , bvDefaultDecDigits :: #{type SQLSMALLINT} - , bvBuffer :: Ptr () - , bvBufferSize :: #{type SQLLEN} + , bvDefaultColumnType :: !(#{type SQLSMALLINT}) + , bvDefaultColumnSize :: !(#{type SQLULEN}) + , bvDefaultDecDigits :: !(#{type SQLSMALLINT}) + , bvBuffer :: !(Ptr ()) + , bvBufferSize :: !(#{type SQLLEN}) } deriving (Show) -- | Marshals given SqlValue returning intended ValueType, default ColumnType, --- and a CStringLen with a buffer containing bound value. Pointer in the CStringLen +-- and a CStringLen with a buffer containing bound value. Pointer in the CStringLen -- structure must be freed by caller bindSqlValue :: SqlValue -> IO BoundValue bindSqlValue sqlValue = case sqlValue of @@ -330,8 +284,8 @@ , bvBuffer = castPtr wstrPtr , bvBufferSize = fromIntegral $ wstrLen * #{size wchar_t} } - l $ "bind SqlString " ++ s ++ ": " ++ show result - return result + hdbcTrace $ "bind SqlString " ++ s ++ ": " ++ show result + return $! result #else let utf8ByteString = BUTF8.fromString s B.unsafeUseAsCStringLen utf8ByteString $ \(unsafeStrPtr, strLen) -> do @@ -345,7 +299,7 @@ , bvBuffer = castPtr safeStrPtr , bvBufferSize = fromIntegral strLen } - l $ "bind SqlString " ++ s ++ ": " ++ show result + hdbcTrace $ "bind SqlString " ++ s ++ ": " ++ show result return result #endif SqlByteString bs -> B.unsafeUseAsCStringLen bs $ \(s,len) -> do @@ -359,46 +313,51 @@ , bvBuffer = castPtr res , bvBufferSize = fromIntegral len } - l $ "bind SqlByteString " ++ show bs ++ ": " ++ show result - return result + hdbcTrace $ "bind SqlByteString " ++ show bs ++ ": " ++ show result + return $! result -- | This is rather hacky, I just replicate the behaviour of a previous version x -> do - l $ "bind other " ++ show x + hdbcTrace $ "bind other " ++ show x bsResult <- bindSqlValue $ SqlByteString (fromSql x) let result = bsResult { bvValueType = #{const SQL_C_CHAR} , bvDefaultColumnType = #{const SQL_CHAR} } - l $ "bound other " ++ show x ++ ": " ++ show result - return result + hdbcTrace $ "bound other " ++ show x ++ ": " ++ show result + return $! result ffetchrow :: SState -> IO (Maybe [SqlValue]) -ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> do - l $ "ffetchrow" - case stmt of +ffetchrow sstate = do + result <- withMaybeStmt (sstmt sstate) $ \maybeStmt -> + case maybeStmt of + Nothing -> do + hdbcTrace "ffetchrow: no statement" + return Nothing + Just hStmt -> do + hdbcTrace "ffetchrow" + bindCols <- getBindCols sstate hStmt + hdbcTrace "ffetchrow: fetching" + rc <- sqlFetch hStmt + if rc == #{const SQL_NO_DATA} + then do + hdbcTrace "ffetchrow: no more rows" + return Nothing + else do + hdbcTrace "ffetchrow: fetching data" + checkError "sqlFetch" (StmtHandle hStmt) rc + sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO} + then mapM (bindColToSqlValue hStmt) bindCols + else raiseError "sqlGetData" rc (StmtHandle hStmt) + return $ Just sqlValues + case result of + Just x -> return $ Just x Nothing -> do - l "ffetchrow: no statement" - return (stmt, Nothing) - Just cmstmt -> withStmt cmstmt $ \cstmt -> do - bindCols <- getBindCols sstate cstmt - l "ffetchrow: fetching" - rc <- sqlFetch cstmt - if rc == #{const SQL_NO_DATA} - then do - l "ffetchrow: no more rows" - ffinish cmstmt - return (Nothing, Nothing) - else do - l "ffetchrow: fetching data" - checkError "sqlFetch" (StmtHandle cstmt) rc - sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO} - then mapM (bindColToSqlValue cstmt) bindCols - else raiseError "sqlGetData" rc (StmtHandle cstmt) - return (stmt, Just sqlValues) + ffinish sstate + return Nothing -getBindCols :: SState -> Ptr CStmt -> IO [(BindCol, Ptr #{type SQLLEN})] +getBindCols :: SState -> SQLHSTMT -> IO [(BindCol, Ptr #{type SQLLEN})] getBindCols sstate cstmt = do - l "getBindCols" + hdbcTrace "getBindCols" modifyMVar (bindColsMV sstate) $ \mBindCols -> case mBindCols of Nothing -> do @@ -411,15 +370,15 @@ -- This is only for String data. For binary fix should be very easy. Just check the column type and use buflen instead of buflen - 1 getLongColData cstmt bindCol = do let (BindColString buf bufLen col) = bindCol - l $ "buflen: " ++ show bufLen + hdbcTrace $ "buflen: " ++ show bufLen bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1)) - l $ "sql_no_total col " ++ show (BUTF8.toString bs) + hdbcTrace $ "sql_no_total col " ++ show (BUTF8.toString bs) bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs return $ SqlByteString bs2 getRestLongColData cstmt cBinding icol acc = do - l "getLongColData" + hdbcTrace "getLongColData" alloca $ \plen -> allocaBytes colBufSizeMaximum $ \buf -> do res <- sqlGetData cstmt (fromIntegral icol) cBinding @@ -432,7 +391,7 @@ else do let bufmax = fromIntegral $ colBufSizeMaximum - 1 bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len)) - l $ "sql_no_total col is: " ++ show (BUTF8.toString bs) + hdbcTrace $ "sql_no_total col is: " ++ show (BUTF8.toString bs) let newacc = B.append acc bs if len /= #{const SQL_NO_TOTAL} && len <= bufmax then return newacc @@ -453,7 +412,7 @@ #{const SQL_NULL_DATA} -> return SqlNull #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL" _ -> do bs <- B.packCStringLen (buf, fromIntegral len) - l $ "col is: " ++ show (BUTF8.toString bs) + hdbcTrace $ "col is: " ++ show (BUTF8.toString bs) return (SqlByteString bs) #{const SQL_SUCCESS_WITH_INFO} -> do len <- peek plen @@ -467,20 +426,25 @@ _ -> colBufSizeDefault - 1 -- strip off NUL bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf)) (B.packCStringLen (buf2, fromIntegral len2)) - l $ "col is: " ++ (BUTF8.toString bs) + hdbcTrace $ "col is: " ++ (BUTF8.toString bs) return (SqlByteString bs) _ -> raiseError "sqlGetData" res (StmtHandle cstmt) -- | ffetchrowBaseline is used for benchmarking fetches without the -- overhead of marshalling values. ffetchrowBaseline sstate = do - Just cmstmt <- readMVar (stomv sstate) - withStmt cmstmt $ \cstmt -> do - rc <- sqlFetch cstmt + hdbcTrace "ffetchrowBaseline" + result <- withStmtOrDie (sstmt sstate) $ \hStmt -> do + hdbcTrace "ffetchrowBaseline got stmt handle" + rc <- sqlFetch hStmt if rc == #{const SQL_NO_DATA} - then do ffinish cmstmt - return Nothing - else do return (Just []) + then return Nothing + else return (Just []) + case result of + Just x -> return $ Just x + Nothing -> do + ffinish sstate + return Nothing data ColBuf @@ -510,14 +474,14 @@ -- | BindColInterval -- typedef struct tagSQL_INTERVAL_STRUCT -- { --- SQLINTERVAL interval_type; +-- SQLINTERVAL interval_type; -- SQLSMALLINT interval_sign; -- union { -- SQL_YEAR_MONTH_STRUCT year_month; -- SQL_DAY_SECOND_STRUCT day_second; -- } intval; -- } SQL_INTERVAL_STRUCT; --- typedef enum +-- typedef enum -- { -- SQL_IS_YEAR = 1, -- SQL_IS_MONTH = 2, @@ -533,13 +497,13 @@ -- SQL_IS_HOUR_TO_SECOND = 12, -- SQL_IS_MINUTE_TO_SECOND = 13 -- } SQLINTERVAL; --- +-- -- typedef struct tagSQL_YEAR_MONTH -- { -- SQLUINTEGER year; --- SQLUINTEGER month; +-- SQLUINTEGER month; -- } SQL_YEAR_MONTH_STRUCT; --- +-- -- typedef struct tagSQL_DAY_SECOND -- { -- SQLUINTEGER day; @@ -627,7 +591,7 @@ -- #{type WORD} -- ^ Data2 -- #{type WORD} -- ^ Data3 -- [#{type BYTE}] -- ^ Data4[8] --- +-- -- instance Storable StructGUID where -- sizeOf _ = #{size SQLGUID} -- alignment _ = alignment (undefined :: CLong) @@ -668,9 +632,9 @@ -- http://msdn.microsoft.com/en-us/library/ms710118(v=vs.85).aspx -- This implementation makes use of Column-Wise binding. Further improvements -- might be had by using Row-Wise binding. -mkBindCol :: SState -> Ptr CStmt -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN}) +mkBindCol :: SState -> SQLHSTMT -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN}) mkBindCol sstate cstmt col = do - l "mkBindCol" + hdbcTrace "mkBindCol" colInfo <- readMVar (colinfomv sstate) let colDesc = (snd (colInfo !! ((fromIntegral col) -1))) case colType colDesc of @@ -715,7 +679,7 @@ -- The functions that follow do the marshalling from C into a Haskell type mkBindColString cstmt col mColSize = do - l "mkBindCol: BindColString" + hdbcTrace "mkBindCol: BindColString" let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize let bufLen = sizeOf (undefined :: CChar) * (colSize + 1) buf <- mallocBytes bufLen @@ -724,7 +688,7 @@ return (BindColString buf (fromIntegral bufLen) col, pStrLen) mkBindColStringEC cstmt col = mkBindColString cstmt col . fmap (* utf8EncodingMaximum) mkBindColWString cstmt col mColSize = do - l "mkBindCol: BindColWString" + hdbcTrace "mkBindCol: BindColWString" let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize let bufLen = sizeOf (undefined :: CWchar) * (colSize + 1) buf <- mallocBytes bufLen @@ -734,56 +698,56 @@ mkBindColWStringEC cstmt col = mkBindColString cstmt col . fmap extendFactor where extendFactor sz = sz * ((utf8EncodingMaximum + wcSize - 1) `quot` wcSize) mkBindColBit cstmt col mColSize = do - l "mkBindCol: BindColBit" + hdbcTrace "mkBindCol: BindColBit" let bufLen = sizeOf (undefined :: CChar) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBit buf, pStrLen) mkBindColTinyInt cstmt col mColSize = do - l "mkBindCol: BindColTinyInt" + hdbcTrace "mkBindCol: BindColTinyInt" let bufLen = sizeOf (undefined :: CUChar) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTinyInt buf, pStrLen) mkBindColShort cstmt col mColSize = do - l "mkBindCol: BindColShort" + hdbcTrace "mkBindCol: BindColShort" let bufLen = sizeOf (undefined :: CShort) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColShort buf, pStrLen) mkBindColLong cstmt col mColSize = do - l "mkBindCol: BindColSize" + hdbcTrace "mkBindCol: BindColSize" let bufLen = sizeOf (undefined :: CLong) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColLong buf, pStrLen) mkBindColBigInt cstmt col mColSize = do - l "mkBindCol: BindColBigInt" + hdbcTrace "mkBindCol: BindColBigInt" let bufLen = sizeOf (undefined :: CInt) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBigInt buf, pStrLen) mkBindColFloat cstmt col mColSize = do - l "mkBindCol: BindColFloat" + hdbcTrace "mkBindCol: BindColFloat" let bufLen = sizeOf (undefined :: CFloat) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColFloat buf, pStrLen) mkBindColDouble cstmt col mColSize = do - l "mkBindCol: BindColDouble" + hdbcTrace "mkBindCol: BindColDouble" let bufLen = sizeOf (undefined :: CDouble) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColDouble buf, pStrLen) mkBindColBinary cstmt col mColSize = do - l "mkBindCol: BindColBinary" + hdbcTrace "mkBindCol: BindColBinary" let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize let bufLen = sizeOf (undefined :: CUChar) * (colSize + 1) buf <- mallocBytes bufLen @@ -791,28 +755,28 @@ sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColBinary buf (fromIntegral bufLen) col, pStrLen) mkBindColDate cstmt col mColSize = do - l "mkBindCol: BindColDate" + hdbcTrace "mkBindCol: BindColDate" let bufLen = sizeOf (undefined :: StructDate) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColDate buf, pStrLen) mkBindColTime cstmt col mColSize = do - l "mkBindCol: BindColTime" + hdbcTrace "mkBindCol: BindColTime" let bufLen = sizeOf (undefined :: StructTime) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTime buf, pStrLen) mkBindColTimestamp cstmt col mColSize = do - l "mkBindCol: BindColTimestamp" + hdbcTrace "mkBindCol: BindColTimestamp" let bufLen = sizeOf (undefined :: StructTimestamp) buf <- malloc pStrLen <- malloc sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen return (BindColTimestamp buf, pStrLen) mkBindColGetData col = do - l "mkBindCol: BindColGetData" + hdbcTrace "mkBindCol: BindColGetData" return (BindColGetData col, nullPtr) freeBindCol :: BindCol -> IO () @@ -837,80 +801,80 @@ -- Also note that the strLen value of SQL_NTS denotes a null terminated string, -- but is only valid as input, so we don't make use of it here: -- http://msdn.microsoft.com/en-us/library/ms713532(v=VS.85).aspx -bindColToSqlValue :: Ptr CStmt -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue +bindColToSqlValue :: SQLHSTMT -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue bindColToSqlValue pcstmt (BindColGetData col, _) = do - l "bindColToSqlValue: BindColGetData" + hdbcTrace "bindColToSqlValue: BindColGetData" getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue pcstmt (bindCol, pStrLen) = do - l "bindColToSqlValue" + hdbcTrace "bindColToSqlValue" strLen <- peek pStrLen case strLen of #{const SQL_NULL_DATA} -> return SqlNull - #{const SQL_NO_TOTAL} -> getLongColData pcstmt bindCol + #{const SQL_NO_TOTAL} -> getLongColData pcstmt bindCol _ -> bindColToSqlValue' pcstmt bindCol strLen -- | This is a worker function for `bindcolToSqlValue`. Note that the case -- where the data is null should already be handled by this stage. -bindColToSqlValue' :: Ptr CStmt -> BindCol -> #{type SQLLEN} -> IO SqlValue +bindColToSqlValue' :: SQLHSTMT -> BindCol -> #{type SQLLEN} -> IO SqlValue bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (buf, fromIntegral strLen) - l $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen + hdbcTrace $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen return $ SqlByteString bs | otherwise = getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue' pcstmt (BindColWString buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (castPtr buf, fromIntegral strLen) - l $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen + hdbcTrace $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen return $ SqlByteString bs | otherwise = getColData pcstmt #{const SQL_CHAR} col bindColToSqlValue' _ (BindColBit buf) strLen = do bit <- peek buf - l $ "bindColToSqlValue BindColBit " ++ show bit + hdbcTrace $ "bindColToSqlValue BindColBit " ++ show bit return $ SqlChar (castCUCharToChar bit) bindColToSqlValue' _ (BindColTinyInt buf) strLen = do tinyInt <- peek buf - l $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt + hdbcTrace $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt return $ SqlChar (castCCharToChar tinyInt) bindColToSqlValue' _ (BindColShort buf) strLen = do short <- peek buf - l $ "bindColToSqlValue BindColShort" ++ show short + hdbcTrace $ "bindColToSqlValue BindColShort" ++ show short return $ SqlInt32 (fromIntegral short) bindColToSqlValue' _ (BindColLong buf) strLen = do long <- peek buf - l $ "bindColToSqlValue BindColLong " ++ show long + hdbcTrace $ "bindColToSqlValue BindColLong " ++ show long return $ SqlInt32 (fromIntegral long) bindColToSqlValue' _ (BindColBigInt buf) strLen = do bigInt <- peek buf - l $ "bindColToSqlValue BindColBigInt " ++ show bigInt + hdbcTrace $ "bindColToSqlValue BindColBigInt " ++ show bigInt return $ SqlInt64 (fromIntegral bigInt) bindColToSqlValue' _ (BindColFloat buf) strLen = do float <- peek buf - l $ "bindColToSqlValue BindColFloat " ++ show float + hdbcTrace $ "bindColToSqlValue BindColFloat " ++ show float return $ SqlDouble (realToFrac float) bindColToSqlValue' _ (BindColDouble buf) strLen = do double <- peek buf - l $ "bindColToSqlValue BindColDouble " ++ show double + hdbcTrace $ "bindColToSqlValue BindColDouble " ++ show double return $ SqlDouble (realToFrac double) bindColToSqlValue' pcstmt (BindColBinary buf bufLen col) strLen | bufLen >= strLen = do bs <- B.packCStringLen (castPtr buf, fromIntegral strLen) - l $ "bindColToSqlValue BindColBinary " ++ show bs + hdbcTrace $ "bindColToSqlValue BindColBinary " ++ show bs return $ SqlByteString bs | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col bindColToSqlValue' _ (BindColDate buf) strLen = do StructDate year month day <- peek buf - l $ "bindColToSqlValue BindColDate" + hdbcTrace $ "bindColToSqlValue BindColDate" return $ SqlLocalDate $ fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day) bindColToSqlValue' _ (BindColTime buf) strLen = do StructTime hour minute second <- peek buf - l $ "bindColToSqlValue BindColTime" + hdbcTrace $ "bindColToSqlValue BindColTime" return $ SqlLocalTimeOfDay $ TimeOfDay (fromIntegral hour) (fromIntegral minute) (fromIntegral second) bindColToSqlValue' _ (BindColTimestamp buf) strLen = do StructTimestamp year month day hour minute second nanosecond <- peek buf - l $ "bindColToSqlValue BindColTimestamp" + hdbcTrace $ "bindColToSqlValue BindColTimestamp" return $ SqlLocalTime $ LocalTime (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day)) (TimeOfDay (fromIntegral hour) (fromIntegral minute) @@ -918,7 +882,7 @@ bindColToSqlValue' _ (BindColGetData _) _ = error "bindColToSqlValue': unexpected BindColGetData!" -fgetcolinfo :: Ptr CStmt -> IO [(String, SqlColDesc)] +fgetcolinfo :: SQLHSTMT -> IO [(String, SqlColDesc)] fgetcolinfo cstmt = do ncols <- getNumResultCols cstmt mapM getname [1..ncols] @@ -927,7 +891,7 @@ alloca $ \datatypeptr -> alloca $ \colsizeptr -> alloca $ \nullableptr -> - do sqlDescribeCol cstmt icol cscolname 127 colnamelp + do sqlDescribeCol cstmt icol cscolname 127 colnamelp datatypeptr colsizeptr nullPtr nullableptr colnamelen <- peek colnamelp colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen) @@ -942,30 +906,31 @@ fexecutemany sstate arglist = mapM_ (fexecute sstate) arglist >> return () --- Finish and change state -public_ffinish :: SState -> IO () -public_ffinish sstate = do - l "public_ffinish" - modifyMVar_ (stomv sstate) freeMStmt - modifyMVar_ (bindColsMV sstate) freeBindCols - where - freeMStmt Nothing = return Nothing - freeMStmt (Just sth) = ffinish sth >> return Nothing - freeBindCols Nothing = return Nothing - freeBindCols (Just bindCols) = do - l "public_ffinish: freeing bindcols" - mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols +freeBoundCols :: SState -> IO () +freeBoundCols sstate = modifyMVar_ (bindColsMV sstate) $ \maybeBindCols -> do + F.mapM_ go maybeBindCols return Nothing - -ffinish :: Stmt -> IO () -ffinish stmt = withRawStmt stmt $ sqlFreeHandleSth_app + where + go bindCols = do + hdbcTrace "freeBoundCols" + mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols +ffinish :: SState -> IO () +ffinish sstate = do + hdbcTrace "ffinish" + withMaybeStmt (sstmt sstate) $ F.mapM_ $ \hStmt -> do + c_sqlFreeStmt hStmt sQL_CLOSE >>= checkError "fexecute c_sqlFreeStmt sQL_CLOSE" (StmtHandle hStmt) + c_sqlFreeStmt hStmt sQL_UNBIND >>= checkError "fexecute c_sqlFreeStmt sQL_UNBIND" (StmtHandle hStmt) + c_sqlFreeStmt hStmt sQL_RESET_PARAMS >>= checkError "fexecute c_sqlFreeStmt sQL_RESET_PARAMS" (StmtHandle hStmt) + freeBoundCols sstate -foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc" - wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt) +ffinalize :: SState -> IO () +ffinalize sstate = do + ffinish sstate + freeStmtIfNotAlready $ sstmt sstate foreign import #{CALLCONV} safe "sql.h SQLDescribeCol" - sqlDescribeCol :: Ptr CStmt + sqlDescribeCol :: SQLHSTMT -> #{type SQLSMALLINT} -- ^ Column number -> CString -- ^ Column name -> #{type SQLSMALLINT} -- ^ Buffer length @@ -977,7 +942,7 @@ -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLGetData" - sqlGetData :: Ptr CStmt -- ^ statement handle + sqlGetData :: SQLHSTMT -- ^ statement handle -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> CString -- ^ target value pointer (void * in C) @@ -986,7 +951,7 @@ -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLBindCol" - sqlBindCol :: Ptr CStmt -- ^ statement handle + sqlBindCol :: SQLHSTMT -- ^ statement handle -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> Ptr ColBuf -- ^ target value pointer (void * in C) @@ -994,32 +959,22 @@ -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr -> IO #{type SQLRETURN} -foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleSth_app" - sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO () - -foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer" - sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ()) - foreign import #{CALLCONV} safe "sql.h SQLPrepare" - sqlPrepare :: Ptr CStmt -> CString -> #{type SQLINTEGER} + sqlPrepare :: SQLHSTMT -> CString -> #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLExecute" - sqlExecute :: Ptr CStmt -> IO #{type SQLRETURN} - -foreign import #{CALLCONV} safe "sql.h SQLAllocHandle" - sqlAllocStmtHandle :: #{type SQLSMALLINT} -> Ptr CConn -> - Ptr (Ptr CStmt) -> IO #{type SQLRETURN} + sqlExecute :: SQLHSTMT -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLNumResultCols" - sqlNumResultCols :: Ptr CStmt -> Ptr #{type SQLSMALLINT} + sqlNumResultCols :: SQLHSTMT -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLRowCount" - sqlRowCount :: Ptr CStmt -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN} + sqlRowCount :: SQLHSTMT -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLBindParameter" - sqlBindParameter :: Ptr CStmt -- ^ Statement handle + sqlBindParameter :: SQLHSTMT -- ^ Statement handle -> #{type SQLUSMALLINT} -- ^ Parameter Number -> #{type SQLSMALLINT} -- ^ Input or output -> #{type SQLSMALLINT} -- ^ Value type @@ -1035,7 +990,7 @@ nullDataHDBC :: Ptr #{type SQLLEN} foreign import #{CALLCONV} safe "sql.h SQLDescribeParam" - sqlDescribeParam :: Ptr CStmt + sqlDescribeParam :: SQLHSTMT -> #{type SQLUSMALLINT} -- ^ parameter number -> Ptr #{type SQLSMALLINT} -- ^ data type ptr -> Ptr #{type SQLULEN} -- ^ parameter size ptr @@ -1044,16 +999,16 @@ -> IO #{type SQLRETURN} foreign import #{CALLCONV} safe "sql.h SQLFetch" - sqlFetch :: Ptr CStmt -> IO #{type SQLRETURN} + sqlFetch :: SQLHSTMT -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables" - simpleSqlTables :: Ptr CStmt -> IO #{type SQLRETURN} + simpleSqlTables :: SQLHSTMT -> IO #{type SQLRETURN} foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns" - simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> + simpleSqlColumns :: SQLHSTMT -> Ptr CChar -> #{type SQLSMALLINT} -> IO #{type SQLRETURN} -fgetparminfo :: Ptr CStmt -> IO [SqlColDesc] +fgetparminfo :: SQLHSTMT -> IO [SqlColDesc] fgetparminfo cstmt = do ncols <- getNumParams cstmt mapM getname [1..ncols] @@ -1063,7 +1018,7 @@ alloca $ \colsizeptr -> alloca $ \nullableptr -> do poke datatypeptr 127 -- to test if sqlDescribeParam actually writes something to the area - res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp + res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp datatypeptr colsizeptr nullPtr nullableptr putStrLn $ show res -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam. @@ -1073,12 +1028,12 @@ nullable <- peek nullableptr return $ snd $ fromOTypeInfo "" datatype colsize nullable -getNumParams :: Ptr CStmt -> IO Int16 +getNumParams :: SQLHSTMT -> IO Int16 getNumParams sthptr = alloca $ \pcount -> - do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" + do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount foreign import #{CALLCONV} safe "sql.h SQLNumParams" - sqlNumParams :: Ptr CStmt -> Ptr #{type SQLSMALLINT} + sqlNumParams :: SQLHSTMT -> Ptr #{type SQLSMALLINT} -> IO #{type SQLRETURN}
Database/HDBC/ODBC/TypeConv.hsc view
@@ -5,7 +5,7 @@ import Database.HDBC.Types import Database.HDBC import Database.HDBC.DriverUtils -import Database.HDBC.ODBC.Types +import Database.HDBC.ODBC.Api.Types import Database.HDBC.ODBC.Utils import Foreign.C.Types import Foreign.ForeignPtr
− Database/HDBC/ODBC/Types.hs
@@ -1,24 +0,0 @@-module Database.HDBC.ODBC.Types -where - -import Foreign.ForeignPtr -import Foreign - --- This may be wrong -- is SqlHandle always a pointer to something? --- but it works with hsql so I'm going to use it here until I hear of it --- breaking. ---newtype SqlHandle = Ptr () - -data CEnv = CEnv -type WrappedCEnv = Ptr CEnv -type Env = ForeignPtr WrappedCEnv - -data CConn = CConn -type WrappedCConn = Ptr CConn -type Conn = ForeignPtr WrappedCConn - -data CStmt = CStmt -type WrappedCStmt = Ptr CStmt -type Stmt = ForeignPtr WrappedCStmt - -
+ Database/HDBC/ODBC/Utils.hs view
@@ -0,0 +1,18 @@+{- -*- mode: haskell; -*- +-} +module Database.HDBC.ODBC.Utils where +import Foreign.Ptr +import Database.HDBC.ODBC.Api.Types +import Foreign.C.Types +import Control.Exception +import Foreign.Marshal.Array + +withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer + -> (Ptr b -> IO ()) -- ^ Function that frees generated data + -> [a] -- ^ List of input data + -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array + -> IO c -- ^ Return value +withAnyArr0 input2ptract freeact inp action = + bracket (mapM input2ptract inp) + (\clist -> mapM_ freeact clist) + (\clist -> withArray0 nullPtr clist action)
− Database/HDBC/ODBC/Utils.hsc
@@ -1,127 +0,0 @@-{- -*- mode: haskell; -*- --} - -module Database.HDBC.ODBC.Utils where -import Foreign.C.String -import Foreign.ForeignPtr -import Foreign.Ptr -import Data.Int -import Database.HDBC(throwSqlError) -import Database.HDBC.Types -import Database.HDBC.ODBC.Types -import Foreign.C.Types -import Control.Exception -import Foreign.Storable -import Foreign.Marshal.Array -import Foreign.Marshal.Alloc -import Data.Word -import qualified Data.ByteString as B -import qualified Data.ByteString.UTF8 as BUTF8 - -#ifdef mingw32_HOST_OS -#include <windows.h> -#endif -#include "hdbc-odbc-helper.h" - -#ifdef mingw32_HOST_OS -#let CALLCONV = "stdcall" -#else -#let CALLCONV = "ccall" -#endif - -data SqlHandleT = EnvHandle (Ptr CEnv) - | DbcHandle (Ptr CConn) - | StmtHandle (Ptr CStmt) - -checkError :: String -> SqlHandleT -> #{type SQLRETURN} -> IO () -checkError msg o res = - do let rc = sqlSucceeded res - if rc == 0 - then raiseError msg res o - else return () - -raiseError :: String -> #{type SQLRETURN} -> SqlHandleT -> IO a -raiseError msg code cconn = - do info <- getdiag ht hp 1 - throwSqlError $ SqlError {seState = show (map fst info), - seNativeError = fromIntegral code, - seErrorMsg = msg ++ ": " ++ - show (map snd info)} - where (ht, hp::(Ptr ())) = case cconn of - EnvHandle c -> (#{const SQL_HANDLE_ENV}, castPtr c) - DbcHandle c -> (#{const SQL_HANDLE_DBC}, castPtr c) - StmtHandle c -> (#{const SQL_HANDLE_STMT}, castPtr c) - getdiag ht hp irow = allocaBytes 6 $ \csstate -> - alloca $ \pnaterr -> - allocaBytes 1025 $ \csmsg -> - alloca $ \pmsglen -> - do ret <- sqlGetDiagRec ht hp irow csstate pnaterr - csmsg 1024 pmsglen - if sqlSucceeded ret == 0 - then return [] - else do state <- peekCStringLen (csstate, 5) - nat <- peek pnaterr - msglen <- peek pmsglen - msgbs <- B.packCStringLen (csmsg, - fromIntegral msglen) - let msg = BUTF8.toString msgbs - next <- getdiag ht hp (irow + 1) - return $ (state, - (show nat) ++ ": " ++ msg) : next - -{- This is a little hairy. - -We have a Conn object that is actually a finalizeonce wrapper around -the real object. We use withConn to dereference the foreign pointer, -and then extract the pointer to the real object from the finalizeonce struct. - -But, when we close the connection, we need the finalizeonce struct, so that's -done by withRawConn. - -Ditto for statements. -} - -withConn :: Conn -> (Ptr CConn -> IO b) -> IO b -withConn = genericUnwrap - -withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b -withRawConn = withForeignPtr - -withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b -withStmt = genericUnwrap - -withRawStmt :: Stmt -> (Ptr WrappedCStmt -> IO b) -> IO b -withRawStmt = withForeignPtr - -withEnv :: Env -> (Ptr CEnv -> IO b) -> IO b -withEnv = genericUnwrap - -withRawEnv :: Env -> (Ptr WrappedCEnv -> IO b) -> IO b -withRawEnv = withForeignPtr - -withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer - -> (Ptr b -> IO ()) -- ^ Function that frees generated data - -> [a] -- ^ List of input data - -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array - -> IO c -- ^ Return value -withAnyArr0 input2ptract freeact inp action = - bracket (mapM input2ptract inp) - (\clist -> mapM_ freeact clist) - (\clist -> withArray0 nullPtr clist action) - - -genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b -genericUnwrap fptr action = withForeignPtr fptr (\structptr -> - do objptr <- #{peek finalizeonce, encapobj} structptr - action objptr - ) -isOK :: #{type SQLRETURN} -> Bool -isOK r = sqlSucceeded r /= 0 - -foreign import ccall safe "sqlSucceeded" - sqlSucceeded :: #{type SQLRETURN} -> CInt - -foreign import #{CALLCONV} safe "sql.h SQLGetDiagRec" - sqlGetDiagRec :: #{type SQLSMALLINT} -> Ptr () -> - #{type SQLSMALLINT} -> CString -> Ptr (#{type SQLINTEGER}) - -> CString -> #{type SQLSMALLINT} - -> Ptr (#{type SQLSMALLINT}) -> IO #{type SQLRETURN}
+ Database/HDBC/ODBC/Wrappers.hs view
@@ -0,0 +1,179 @@+{-| Defines haskell wrappers over native ODBC objects to free + you from some memory (and threading) management. +-} +{-# LANGUAGE OverloadedStrings #-} +module Database.HDBC.ODBC.Wrappers + ( EnvWrapper (..) + , sqlAllocEnv + , withMaybeEnv + , withEnvOrDie + , freeEnvIfNotAlready + , DbcWrapper (..) + , sqlAllocDbc + , withMaybeDbc + , withDbcOrDie + , tryDisconnectAndFree + , freeDbcIfNotAlready + , StmtWrapper (..) + , sqlAllocStmt + , withMaybeStmt + , withStmtOrDie + , freeStmtIfNotAlready + ) where + +import Control.Monad (unless, void, when) +import Control.Concurrent.MVar +import Control.Concurrent.ReadWriteVar (RWVar) +import Database.HDBC (SqlError (..), throwSqlError) +import Database.HDBC.ODBC.Api.Errors +import Database.HDBC.ODBC.Api.Imports +import Database.HDBC.ODBC.Api.Types +import Database.HDBC.ODBC.Log +import Foreign.Marshal hiding (void) +import Foreign.Ptr +import Foreign.Storable +import System.Mem.Weak (addFinalizer) + +import qualified Control.Concurrent.ReadWriteVar as RWV +import qualified Data.Foldable as F + +data EnvWrapper = EnvWrapper + { envHandle :: MVar (Maybe SQLHENV) -- ^ If there is Nothing here, environment is already freed + } + +sqlAllocEnv :: IO EnvWrapper +sqlAllocEnv = do + hEnv <- alloca $ \(penvptr :: Ptr SQLHENV) -> do + retVal <- c_sqlAllocHandle sQL_HANDLE_ENV nullPtr (castPtr penvptr) + unless (sqlSucceeded retVal) $ throwSqlError SqlError + { seState = "" + , seNativeError = -1 + , seErrorMsg = "sqlAllocEnv/SqlAllocHandle: Failed to allocate ODBC Environment handle" + } + peek penvptr + + handleVar <- newMVar (Just hEnv) + let wrapper = EnvWrapper handleVar + + addFinalizer wrapper $ freeEnvIfNotAlready wrapper + return wrapper + +freeEnvIfNotAlready :: EnvWrapper -> IO () +freeEnvIfNotAlready w = modifyMVar_ (envHandle w) $ \maybeEnv -> do + F.forM_ maybeEnv $ \hEnv -> do + hdbcTrace $ "Freeing environment with handle " ++ show hEnv + void $ c_sqlFreeHandle sQL_HANDLE_ENV (castPtr hEnv) + return Nothing + +withMaybeEnv :: EnvWrapper -> (Maybe SQLHENV -> IO a) -> IO a +withMaybeEnv = withMVar . envHandle + +withEnvOrDie :: EnvWrapper -> (SQLHENV -> IO a) -> IO a +withEnvOrDie ew act = withMaybeEnv ew $ \maybeHandle -> + case maybeHandle of + Just h -> act h + Nothing -> do + hdbcTrace "Requested an ENV handle from disposed wrapper. Throwing." + throwSqlError SqlError + { seState = "" + , seNativeError = -1 + , seErrorMsg = "Tried to use a disposed ODBC Environment handle" + } + +data DbcWrapper = DbcWrapper + { connHandle :: RWVar (Maybe SQLHDBC) -- ^ If there is Nothing here, connection is already freed + , connEnv :: EnvWrapper + } + +-- This one implicitly allocates and initializes an environment. +sqlAllocDbc :: EnvWrapper -> IO DbcWrapper +sqlAllocDbc env = do + hDbc <- withEnvOrDie env $ \hEnv -> alloca $ \(pdbcptr :: Ptr SQLHDBC) -> do + retVal <- c_sqlAllocHandle sQL_HANDLE_DBC (castPtr hEnv) (castPtr pdbcptr) + checkError "sqlAllocConn/SQLAllocHandle" (EnvHandle hEnv) retVal + peek pdbcptr + + handleVar <- RWV.new $ Just hDbc + let wrapper = DbcWrapper handleVar env + + addFinalizer wrapper $ freeDbcIfNotAlready False wrapper + return wrapper + + +-- | Tries to perform disconnect and free resources used by connection. If SQLDisconnect call +-- fails, an exception gets thrown and connection resources aren't freed. +tryDisconnectAndFree :: DbcWrapper -> IO () +tryDisconnectAndFree = freeDbcIfNotAlready True + +freeDbcIfNotAlready :: Bool -> DbcWrapper -> IO () +freeDbcIfNotAlready checkDisconnect dbc = do + RWV.modify_ (connHandle dbc) $ \maybeHandle -> do + F.forM_ maybeHandle $ \hDbc -> do + hdbcTrace $ "Freeing connection with handle " ++ show hDbc + disconnectResult <- c_sqlDisconnect hDbc + when checkDisconnect $ checkError "freeDbcIfNotAlready/SQLDisconnect" (DbcHandle hDbc) disconnectResult + void $ c_sqlFreeHandle sQL_HANDLE_DBC (castPtr hDbc) + return Nothing + freeEnvIfNotAlready $ connEnv dbc + +withMaybeDbc :: DbcWrapper -> (Maybe SQLHDBC -> IO a) -> IO a +withMaybeDbc = RWV.with . connHandle + +withDbcOrDie :: DbcWrapper -> (SQLHDBC -> IO a) -> IO a +withDbcOrDie dw act = withMaybeDbc dw $ \maybeHandle -> + case maybeHandle of + Just h -> act h + Nothing -> do + hdbcTrace "Requested a DBC handle from a disposed wrapper. Throwing" + throwSqlError SqlError + { seState = "" + , seNativeError = -1 + , seErrorMsg = "Tried to use a disposed ODBC Connection handle" + } + +data StmtWrapper = StmtWrapper + { stmtHandle :: MVar (Maybe SQLHSTMT) -- ^ If there is Nothing here, statement is already finished + , stmtConn :: DbcWrapper + } + +sqlAllocStmt :: DbcWrapper -> IO StmtWrapper +sqlAllocStmt dbc = do + hStmt <- withDbcOrDie dbc $ \hDbc -> alloca $ \(psthptr :: Ptr SQLHSTMT) -> do + retVal <- c_sqlAllocHandle sQL_HANDLE_STMT (castPtr hDbc) (castPtr psthptr) + checkError "sqlAllocStmt/SQLAllocHandle" (DbcHandle hDbc) retVal + peek psthptr + + handleVar <- newMVar $ Just hStmt + let wrapper = StmtWrapper handleVar dbc + + addFinalizer wrapper $ freeStmtIfNotAlready wrapper + return wrapper + +freeStmtIfNotAlready :: StmtWrapper -> IO () +freeStmtIfNotAlready stmt = modifyMVar_ (stmtHandle stmt) $ \maybeHandle -> do + F.forM_ maybeHandle $ \hStmt -> do + hdbcTrace $ "Freeing statement with handle " ++ show hStmt + -- SQL Server might deadlock if closing handle to a statement in process of fetching + -- network data so we have to cancel it explicitly. We also need to protect ourselves + -- from trying to cancel or free a statement, which has its connection already finalized. + RWV.with (connHandle $ stmtConn stmt) $ \maybeConn -> + F.forM_ maybeConn $ \_ -> do + void $ c_sqlCancel hStmt + void $ c_sqlCloseCursor hStmt + void $ c_sqlFreeHandle sQL_HANDLE_STMT (castPtr hStmt) + return Nothing + +withMaybeStmt :: StmtWrapper -> (Maybe SQLHSTMT -> IO a) -> IO a +withMaybeStmt = withMVar . stmtHandle + +withStmtOrDie :: StmtWrapper -> (SQLHSTMT -> IO a) -> IO a +withStmtOrDie sw act = withMaybeStmt sw $ \maybeHandle -> + case maybeHandle of + Just h -> act h + Nothing -> do + hdbcTrace $ "Requested a STMT handle from a disposed wrapper. Throwing." + throwSqlError SqlError + { seState = "" + , seNativeError = -1 + , seErrorMsg = "Tried to use a disposed ODBC Statement handle" + }
HDBC-odbc.cabal view
@@ -1,107 +1,117 @@-Name: HDBC-odbc -Version: 2.4.0.1 -Cabal-Version: >=1.8 -Build-type: Simple -License: BSD3 -Maintainer: Anton Dessiatov <anton.dessiatov@gmail.com> - Nicolas Wu <nicolas.wu@gmail.com> -Author: John Goerzen -Copyright: Copyright (c) 2005-2011 John Goerzen -license-file: LICENSE -extra-source-files: LICENSE, hdbc-odbc-helper.h, - Makefile, - README.md, - testsrc/TestTime.hs - changelog.txt -homepage: https://github.com/hdbc/hdbc-odbc -Category: Database -synopsis: ODBC driver for HDBC -Description: This package provides an ODBC database backend for HDBC. - It is cross-platform and supports unixODBC on Unix/Linux/POSIX platforms - and Microsoft ODBC on Windows. It is also the preferred way to access - MySQL databases from Haskell. -Stability: Beta +name: HDBC-odbc +version: 2.5.0.0 +cabal-version: >=1.8 +build-type: Simple +license: BSD3 +maintainer: Anton Dessiatov <anton.dessiatov@gmail.com> +author: John Goerzen +copyright: Copyright (c) 2005-2014 John Goerzen, Nicolas Wu, Anton Dessiatov +license-file: LICENSE +extra-source-files: + LICENSE + , cbits/hdbc-odbc-helper.h + , Makefile + , README.md + , testsrc/TestTime.hs + , changelog.txt +homepage: https://github.com/hdbc/hdbc-odbc +category: Database +synopsis: ODBC driver for HDBC +description: + This package provides an ODBC database backend for HDBC. + It is cross-platform and supports unixODBC on Unix/Linux/POSIX platforms + and Microsoft ODBC on Windows. It is also the preferred way to access + MySQL databases from Haskell. +stability: Beta -Flag buildtests +flag buildtests description: Build the executable to run unit tests default: False -Flag buildstresstest +flag buildstresstest description: Build the stress testing executable default: False -Library - Exposed-Modules: Database.HDBC.ODBC - Other-Modules: Database.HDBC.ODBC.Connection, - Database.HDBC.ODBC.Statement, - Database.HDBC.ODBC.Types, - Database.HDBC.ODBC.Utils, - Database.HDBC.ODBC.TypeConv, - Database.HDBC.ODBC.ConnectionImpl - Extensions: - ExistentialQuantification, - ForeignFunctionInterface, - ScopedTypeVariables - Build-Depends: base >= 4.3.1.0 && < 5 - , mtl - , HDBC>=2.1.0 - , time>=1.2.0.3 - , utf8-string - , bytestring - C-Sources: hdbc-odbc-helper.c +library + exposed-modules: + Database.HDBC.ODBC + other-modules: + Database.HDBC.ODBC.Api.Errors + , Database.HDBC.ODBC.Api.Imports + , Database.HDBC.ODBC.Api.Types + , Database.HDBC.ODBC.Connection + , Database.HDBC.ODBC.ConnectionImpl + , Database.HDBC.ODBC.Log + , Database.HDBC.ODBC.Statement + , Database.HDBC.ODBC.TypeConv + , Database.HDBC.ODBC.Utils + , Database.HDBC.ODBC.Wrappers + extensions: + ExistentialQuantification + , ForeignFunctionInterface + , ScopedTypeVariables + build-depends: + base >= 4.3.1.0 && < 5 + , concurrent-extra >= 0.7.0.8 + , mtl + , HDBC>=2.1.0 + , time>=1.2.0.3 + , utf8-string + , bytestring + c-sources: + cbits/hdbc-odbc-helper.c + include-dirs: + cbits + if os(mingw32) || os(win32) - Extra-Libraries: odbc32 + extra-libraries: odbc32 else - Extra-Libraries: odbc - include-dirs: . - -- extra-lib-dirs: + extra-libraries: odbc, pthread -Executable runtests +executable runtests if flag(buildtests) - Buildable: True - Build-Depends: HUnit, QuickCheck, testpack, containers, old-time, - time, old-locale, convertible - else - Buildable: False - Main-Is: runtests.hs - Other-Modules: Database.HDBC.ODBC, - Database.HDBC.ODBC.Connection, - Database.HDBC.ODBC.Statement, - Database.HDBC.ODBC.Types, - Database.HDBC.ODBC.Utils, - Database.HDBC.ODBC.TypeConv, - Database.HDBC.ODBC.ConnectionImpl - SpecificDB, - SpecificDBTests, - TestMisc, - TestSbasics, - TestUtils, - Testbasics, - Tests - Hs-Source-Dirs: ., testsrc - C-Sources: hdbc-odbc-helper.c - if os(mingw32) || os(win32) - Extra-Libraries: odbc32 + buildable: True + build-depends: + base + , HUnit + , HDBC + , HDBC-odbc + , QuickCheck + , testpack + , containers + , old-time + , time + , old-locale + , convertible else - Extra-Libraries: odbc - include-dirs: . - GHC-Options: -O2 - Extensions: - ExistentialQuantification, - ForeignFunctionInterface, - PatternSignatures + buildable: False + main-is: runtests.hs + other-modules: + SpecificDB + , SpecificDBTests + , TestMisc + , TestSbasics + , TestUtils + , Testbasics + , Tests + hs-source-dirs: testsrc + ghc-options: -O2 + extensions: + ExistentialQuantification + , ForeignFunctionInterface + , ScopedTypeVariables -Executable stresstest +executable stresstest if flag(buildstresstest) - Buildable: True - Build-Depends: + buildable: True + build-depends: base , HDBC , HDBC-odbc , random , resource-pool else - Buildable: False - Main-Is: stresstest.hs - Hs-Source-Dirs: stresstest - GHC-Options: -threaded -rtsopts + buildable: False + main-is: stresstest.hs + hs-source-dirs: stresstest + ghc-options: -threaded -rtsopts
+ cbits/hdbc-odbc-helper.c view
@@ -0,0 +1,23 @@+#include "hdbc-odbc-helper.h" +#include <sqlext.h> +#include <stdio.h> +#include <stdlib.h> + +SQLLEN nullDataHDBC = SQL_NULL_DATA; + +int sqlSucceeded(SQLRETURN ret) { + return SQL_SUCCEEDED(ret); +} + +void *getSqlOvOdbc3(void) { + return (void *)SQL_OV_ODBC3; +} + +SQLRETURN simpleSqlTables(SQLHSTMT stmt) { + return SQLTables(stmt, NULL, 0, NULL, 0, "%", 1, "TABLE", 5); +} + +SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, + SQLSMALLINT tnlen) { + return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, "%", 1); +}
+ cbits/hdbc-odbc-helper.h view
@@ -0,0 +1,20 @@+#ifndef _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H +#define _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H + +#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) +#include <windows.h> +#include <winnt.h> +#endif + +#include <sql.h> + +int sqlSucceeded(SQLRETURN ret); + +SQLLEN nullDataHDBC; +void *getSqlOvOdbc3(void); + +SQLRETURN simpleSqlTables(SQLHSTMT stmt); +SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, + SQLSMALLINT tnlen); + +#endif /* _HDBC_ODBC_CBITS_HDBC_ODBC_HELPER_H */
− hdbc-odbc-helper.c
@@ -1,162 +0,0 @@-#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) -#define ON_WINDOWS -#include <windows.h> -#include <winnt.h> -#endif -#include <sql.h> -#include <sqlext.h> -#include <stdio.h> -#include <stdlib.h> -#include "hdbc-odbc-helper.h" - -SQLLEN nullDataHDBC = SQL_NULL_DATA; - -int sqlSucceeded(SQLRETURN ret) { - return SQL_SUCCEEDED(ret); -} - -#ifdef ON_WINDOWS -#define odbc_sync_val_compare_and_swap(ptr, oldval, newval) InterlockedCompareExchange((volatile LONG*)(ptr), (newval), (oldval)) -#define odbc_atomic_increment(ptr) InterlockedIncrement((volatile LONG*)(ptr)) -#define odbc_atomic_decrement(ptr) InterlockedDecrement((volatile LONG*)(ptr)) -#else -#define odbc_sync_val_compare_and_swap(ptr, oldval, newval) __sync_val_compare_and_swap((ptr), (oldval), (newval)) -#define odbc_atomic_increment(ptr) __sync_add_and_fetch((ptr), 1) -#define odbc_atomic_decrement(ptr) __sync_sub_and_fetch((ptr), 1) -#endif - -/* Things can't finalize more than once. -We'd like to let people call them from the app. -Yet we'd also like to be able to have a ForeignPtr finalize them. - -So, here's a little wrapper for things. */ - -void dbc_conditional_finalizer(finalizeonce *conn, int refCount); - -finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj) { - // parentobj might not get finalized during running this function - // from other thread because of the way it is called from Haskell - // side. - finalizeonce *newobj; - newobj = malloc(sizeof(finalizeonce)); - if (newobj == NULL) { - fprintf(stderr, "\nHDBC: could not allocate wrapper!\n"); - return NULL; - } - newobj->isfinalized = 0; - newobj -> refcount = 1; - newobj->encapobj = obj; - newobj->extrainfo = NULL; - newobj->parent = parentobj; - if (parentobj != NULL) { - odbc_atomic_increment(&parentobj->refcount); - } -#ifdef HDBC_DEBUG - fprintf(stderr, "\nWrapped %p at %p\n", obj, newobj); -#endif - return newobj; -} - -finalizeonce *wrapobjodbc_extra(void *obj, void *extra, finalizeonce *parentobj) { - finalizeonce *newobj = wrapobjodbc(obj, parentobj); - if (newobj != NULL) - newobj->extrainfo = extra; - return newobj; -} - -void sqlFreeHandleSth_app(finalizeonce *res) { -#ifdef HDBC_DEBUG - fprintf(stderr, "\nApp cleanup of sth %p requested: %d\n", - res->encapobj, res->isfinalized); -#endif - int isFinalized = odbc_sync_val_compare_and_swap(&res->isfinalized, 0, 1); - if (isFinalized) - return; - if (!res->encapobj) - return; - // Microsoft SQL Server driver might deadlock if calling SQLCloseCursor on a statement that is in the - // process of fetching data via network. So we cancel it first. - SQLCancel((SQLHSTMT) (res->encapobj)); - SQLCloseCursor((SQLHSTMT) (res->encapobj)); - SQLFreeHandle(SQL_HANDLE_STMT, (SQLHANDLE) (res->encapobj)); - res->encapobj = NULL; -} - -void sqlFreeHandleSth_finalizer(finalizeonce *res) { -#ifdef HDBC_DEBUG - fprintf(stderr, "\nFinalizer cleanup of sth %p requested: %d\n", - res->encapobj, res->isfinalized); -#endif - sqlFreeHandleSth_app(res); - - /* Not really important since this is never a parent */ - odbc_atomic_decrement(&res->refcount); - - int parentRefCount = odbc_atomic_decrement(&res->parent->refcount); - dbc_conditional_finalizer(res->parent, parentRefCount); - free(res); -} - -SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res) { - SQLRETURN retval; -#ifdef HDBC_DEBUG - fprintf(stderr, "\nApp cleanup of dbc %p requested: %d\n", - res->encapobj, res->isfinalized); -#endif - int isFinalized = odbc_sync_val_compare_and_swap(&res->isfinalized, 0, 1); - if (isFinalized) - return 0; - if (!res->encapobj) - return SQL_SUCCESS; - - retval = SQLDisconnect((SQLHDBC) (res->encapobj)); - if (SQL_SUCCEEDED(retval)) { - SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj)); - SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo)); - res->encapobj = NULL; - } - return retval; -} - -void sqlFreeHandleDbc_finalizer(finalizeonce *res) { -#ifdef HDBC_DEBUG - fprintf(stderr, "\nFinalizer cleanup of dbc %p requested: %d\n", - res->encapobj, res->isfinalized); -#endif - int refCount = odbc_atomic_decrement(&res->refcount); - dbc_conditional_finalizer(res, refCount); -} - -void dbc_conditional_finalizer(finalizeonce *res, int refcount) { - if (refcount < 1) { - /* Don't use sqlFreeHandleDbc_app here, because we want to clear it out - regardless of the success or failues of SQLDisconnect. */ - int isFinalized = odbc_sync_val_compare_and_swap(&res->isfinalized, 0, 1); - if (!isFinalized && res->encapobj) { - SQLDisconnect((SQLHDBC) (res->encapobj)); - SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj)); - SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo)); - res->encapobj = NULL; - } - free(res); - } -} - -void *getSqlOvOdbc3(void) { - return (void *)SQL_OV_ODBC3; -} - -SQLRETURN disableAutoCommit(SQLHDBC conn) { - return SQLSetConnectAttr(conn, SQL_ATTR_AUTOCOMMIT, - (SQLPOINTER) SQL_AUTOCOMMIT_OFF, - SQL_IS_UINTEGER); -} - -SQLRETURN simpleSqlTables(SQLHSTMT stmt) { - return SQLTables(stmt, NULL, 0, NULL, 0, "%", 1, "TABLE", 5); -} - -SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, - SQLSMALLINT tnlen) { - return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, "%", 1); -}
− hdbc-odbc-helper.h
@@ -1,35 +0,0 @@-#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) -#include <windows.h> -#include <winnt.h> -#endif -#include <sql.h> - -extern int sqlSucceeded(SQLRETURN ret); -extern SQLRETURN sqlFreeHandleEnv(SQLHANDLE hdl); - -typedef struct TAG_finalizeonce { - void *encapobj; - int refcount; - int isfinalized; - void *extrainfo; - struct TAG_finalizeonce *parent; -} finalizeonce; - -extern finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj); -extern finalizeonce *wrapobjodbc_extra(void *obj, void *extra, - finalizeonce *parentobj); - -extern SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res); -extern void sqlFreeHandleDbc_finalizer(finalizeonce *res); - -extern void sqlFreeHandleSth_app(finalizeonce *res); -extern void sqlFreeHandleSth_finalizer(finalizeonce *res); - -extern SQLLEN nullDataHDBC; -extern void *getSqlOvOdbc3(void); - -extern SQLRETURN disableAutoCommit(SQLHDBC conn); -extern SQLRETURN simpleSqlTables(SQLHSTMT stmt); -extern SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, - SQLSMALLINT tnlen); -
testsrc/TestSbasics.hs view
@@ -3,9 +3,9 @@ import Database.HDBC import TestUtils import System.IO -import Control.Exception hiding (catch) +import Control.Exception -openClosedb = sqlTestCase $ +openClosedb = sqlTestCase $ do dbh <- connectDB disconnect dbh @@ -28,7 +28,7 @@ sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"])) sFetchRow sth >>= (assertEqual "last row" Nothing) ) - + createTable = dbTestCase (\dbh -> do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] commit dbh @@ -60,8 +60,8 @@ commit dbh sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid" sExecute sth [Just "executeReplace"] - sFetchRow sth >>= (assertEqual "r1" - (Just $ map Just ["executeReplace", "1", "1234", + sFetchRow sth >>= (assertEqual "r1" + (Just $ map Just ["executeReplace", "1", "1234", "Foo"])) sFetchRow sth >>= (assertEqual "r2" (Just [Just "executeReplace", Just "2", Nothing, @@ -124,11 +124,11 @@ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]]) - + -- Let's try a rollback. catch (withTransaction dbh (\_ -> do sExecuteMany sth rows fail "Foo")) - (\_ -> return ()) + (\(_ :: SomeException) -> return ()) sExecute qrysth [] sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]]) @@ -138,7 +138,7 @@ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows)) ) where rows = map (\x -> [Just . show $ x]) [1..9] - + tests = TestList [ TestLabel "openClosedb" openClosedb,
testsrc/Testbasics.hs view
@@ -3,9 +3,9 @@ import Database.HDBC import TestUtils import System.IO -import Control.Exception hiding (catch) +import Control.Exception -openClosedb = sqlTestCase $ +openClosedb = sqlTestCase $ do dbh <- connectDB disconnect dbh @@ -29,7 +29,7 @@ assertEqual "nToSql compare" [[nToSql (2::Int)]] r assertEqual "string compare" [[SqlString "2"]] r ) - + createTable = dbTestCase (\dbh -> do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" [] commit dbh @@ -51,7 +51,7 @@ r <- fetchAllRows sth assertEqual "" [r1, r2] r ) - where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull] executeReplace = dbTestCase (\dbh -> @@ -136,11 +136,11 @@ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid" execute qrysth [] fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]]) - + -- Let's try a rollback. catch (withTransaction dbh (\_ -> do executeMany sth rows fail "Foo")) - (\_ -> return ()) + (\(_ :: SomeException) -> return ()) execute qrysth [] fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]]) @@ -150,7 +150,7 @@ fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows)) ) where rows = map (\x -> [iToSql x]) [1..9] - + tests = TestList [ TestLabel "openClosedb" openClosedb,