diff --git a/Database/HDBC/ODBC.hs b/Database/HDBC/ODBC.hs --- a/Database/HDBC/ODBC.hs +++ b/Database/HDBC/ODBC.hs @@ -32,10 +32,10 @@ module Database.HDBC.ODBC ( - connectODBC, Connection() + connectODBC, Connection(), getQueryInfo ) where import Database.HDBC.ODBC.Connection(connectODBC, Connection()) - +import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo) diff --git a/Database/HDBC/ODBC/Connection.hsc b/Database/HDBC/ODBC/Connection.hsc --- a/Database/HDBC/ODBC/Connection.hsc +++ b/Database/HDBC/ODBC/Connection.hsc @@ -158,6 +158,7 @@ >>= checkError "sqlSetConnectAttr" (DbcHandle cconn) ) return $ Impl.Connection { + Impl.getQueryInfo = fGetQueryInfo iconn children, Impl.disconnect = fdisconnect iconn children, Impl.commit = fcommit iconn, Impl.rollback = frollback iconn, diff --git a/Database/HDBC/ODBC/ConnectionImpl.hs b/Database/HDBC/ODBC/ConnectionImpl.hs --- a/Database/HDBC/ODBC/ConnectionImpl.hs +++ b/Database/HDBC/ODBC/ConnectionImpl.hs @@ -24,6 +24,7 @@ data Connection = Connection { + getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]), disconnect :: IO (), commit :: IO (), rollback :: IO (), diff --git a/Database/HDBC/ODBC/Statement.hsc b/Database/HDBC/ODBC/Statement.hsc --- a/Database/HDBC/ODBC/Statement.hsc +++ b/Database/HDBC/ODBC/Statement.hsc @@ -57,7 +57,34 @@ #else #let CALLCONV = "ccall" #endif +fGetQueryInfo iconn children query = + do l "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 = 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 + + sqlPrepare sthptr cquery (fromIntegral cqlen) >>= + checkError "execute prepare" (StmtHandle sthptr) + + -- parmCount <- getNumParams sthptr + parmInfo <- fgetparminfo sthptr + + -- rc <- getNumResultCols sthptr + colInfo <- fgetcolinfo sthptr + return (parmInfo, colInfo) + data SState = SState { stomv :: MVar (Maybe Stmt), dbo :: Conn, @@ -109,18 +136,22 @@ sstate <- newSState iconn "" swapMVar (stomv sstate) (Just fsthptr) let sth = wrapStmt sstate - return sth + return (sth, sstate) fgettables iconn = do fsthptr <- makesth iconn "fgettables" + l "fgettables: after makesth" withStmt fsthptr (\sthptr -> simpleSqlTables sthptr >>= checkError "gettables simpleSqlTables" (StmtHandle sthptr) ) - sth <- wrapTheStmt iconn fsthptr + 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 (show results) + l ("fgettables: results: " ++ (show results)) return $ map (\x -> fromSql (x !! 2)) results fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ @@ -131,7 +162,8 @@ checkError "fdescribetable simpleSqlColumns" (StmtHandle sthptr) ) - sth <- wrapTheStmt iconn fsthptr + (sth, sstate) <- wrapTheStmt iconn fsthptr + withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)) results <- fetchAllRows' sth l (show results) return $ map fromOTypeCol results @@ -142,7 +174,7 @@ B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) -> alloca $ \(psthptr::Ptr (Ptr CStmt)) -> - do l "in fexecute" + do l $ "in fexecute: " ++ show (squery sstate) ++ show args public_ffinish sstate rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr sthptr <- peek psthptr @@ -156,11 +188,12 @@ argsToFree <- zipWithM (bindCol sthptr) args [1..] + l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args r <- sqlExecute sthptr -- Our bound columns must be valid through this point, -- but we don't care after here. - mapM (\(x, y) -> touchForeignPtr x >> touchForeignPtr y) + mapM_ (\(x, y) -> touchForeignPtr x >> touchForeignPtr y) (concat argsToFree) case r of @@ -201,8 +234,10 @@ So, make sure we either free of have foreignized everything before control passes out of this function. -} - do rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits + do l $ "Binding col " ++ show icol ++ ": " ++ show arg + rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable + l $ "rc1 is " ++ show (isOK rc1) when (not (isOK rc1)) $ -- Some drivers don't support that call do poke pdtype #{const SQL_CHAR} poke pcolsize 0 @@ -210,13 +245,15 @@ coltype <- peek pdtype colsize <- peek pcolsize decdigits <- peek pdecdigits + l $ "Results: " ++ show (coltype, colsize, decdigits) case arg of SqlNull -> -- NULL parameter, bind it as such. - do rc2 <- sqlBindParameter sthptr (fromIntegral icol) + do l "Binding null" + rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT} #{const SQL_C_CHAR} coltype colsize decdigits - nullPtr 0 nullData - checkError ("bindparameter " ++ show icol) + nullPtr 0 nullDataHDBC + checkError ("bindparameter NULL " ++ show icol) (StmtHandle sthptr) rc2 return [] x -> do -- Otherwise, we have to allocate RAM, make sure it's @@ -276,12 +313,14 @@ else do l "getting stuff" checkError "sqlFetch" (StmtHandle cstmt) rc ncols <- getNumResultCols cstmt + l $ "ncols: " ++ show ncols res <- mapM (getCol cstmt ) [1..ncols] return (stmt, Just res) where getCol cstmt icol = do let defaultLen = 128 colinfo <- readMVar (colinfomv sstate) + l $ "getCol: colinfo is " ++ show colinfo ++ ", icol " ++ show icol let cBinding = case colType (snd (colinfo !! ((fromIntegral icol) - 1))) of SqlBinaryT -> #{const SQL_C_BINARY} SqlVarBinaryT -> #{const SQL_C_BINARY} @@ -361,7 +400,7 @@ -> #{type SQLSMALLINT} -- ^ Buffer length -> Ptr (#{type SQLSMALLINT}) -- ^ name length ptr -> Ptr (#{type SQLSMALLINT}) -- ^ data type ptr - -> Ptr (#{type SQLUINTEGER}) -- ^ column size ptr + -> Ptr (#{type SQLULEN}) -- ^ column size ptr -> Ptr (#{type SQLSMALLINT}) -- ^ decimal digits ptr -> Ptr (#{type SQLSMALLINT}) -- ^ nullable ptr -> IO #{type SQLRETURN} @@ -371,8 +410,8 @@ -> #{type SQLUSMALLINT} -- ^ Column number -> #{type SQLSMALLINT} -- ^ target type -> CString -- ^ target value pointer (void * in C) - -> #{type SQLINTEGER} -- ^ buffer len - -> Ptr (#{type SQLINTEGER}) + -> #{type SQLLEN} -- ^ buffer len + -> Ptr (#{type SQLLEN}) -> IO #{type SQLRETURN} foreign import ccall unsafe "hdbc-odbc-helper.h sqlFreeHandleSth_app" @@ -405,21 +444,21 @@ -> #{type SQLSMALLINT} -- ^ Input or output -> #{type SQLSMALLINT} -- ^ Value type -> #{type SQLSMALLINT} -- ^ Parameter type - -> #{type SQLUINTEGER} -- ^ column size + -> #{type SQLULEN} -- ^ column size -> #{type SQLSMALLINT} -- ^ decimal digits -> CString -- ^ Parameter value pointer - -> #{type SQLINTEGER} -- ^ buffer length - -> Ptr #{type SQLINTEGER} -- ^ strlen_or_indptr + -> #{type SQLLEN} -- ^ buffer length + -> Ptr #{type SQLLEN} -- ^ strlen_or_indptr -> IO #{type SQLRETURN} -foreign import ccall unsafe "hdbc-odbc-helper.h &nullData" - nullData :: Ptr #{type SQLINTEGER} +foreign import ccall unsafe "hdbc-odbc-helper.h &nullDataHDBC" + nullDataHDBC :: Ptr #{type SQLLEN} foreign import #{CALLCONV} unsafe "sql.h SQLDescribeParam" sqlDescribeParam :: Ptr CStmt -> #{type SQLUSMALLINT} -- ^ parameter number -> Ptr #{type SQLSMALLINT} -- ^ data type ptr - -> Ptr #{type SQLUINTEGER} -- ^ parameter size ptr + -> Ptr #{type SQLULEN} -- ^ parameter size ptr -> Ptr #{type SQLSMALLINT} -- ^ dec digits ptr -> Ptr #{type SQLSMALLINT} -- ^ nullable ptr -> IO #{type SQLRETURN} @@ -433,3 +472,31 @@ foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlColumns" simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> #{type SQLSMALLINT} -> IO #{type SQLRETURN} + +fgetparminfo cstmt = + do ncols <- getNumParams cstmt + mapM getname [1..ncols] + where getname icol = -- alloca $ \colnamelp -> + -- allocaBytes 128 $ \cscolname -> + alloca $ \datatypeptr -> + 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 + datatypeptr colsizeptr nullPtr nullableptr + putStrLn $ show res + -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam. + -- Not supporting SQLDescribeParam is quite allright according to the ODBC standard. + datatype <- peek datatypeptr + colsize <- peek colsizeptr + nullable <- peek nullableptr + return $ snd $ fromOTypeInfo "" datatype colsize nullable + +getNumParams sthptr = alloca $ \pcount -> + do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" + (StmtHandle sthptr) + peek pcount + +foreign import ccall unsafe "sql.h SQLNumParams" + sqlNumParams :: Ptr CStmt -> Ptr #{type SQLSMALLINT} + -> IO #{type SQLRETURN} diff --git a/Database/HDBC/ODBC/TypeConv.hsc b/Database/HDBC/ODBC/TypeConv.hsc --- a/Database/HDBC/ODBC/TypeConv.hsc +++ b/Database/HDBC/ODBC/TypeConv.hsc @@ -40,7 +40,7 @@ import Data.Maybe l _ = return () ---l m = hPutStrLn stderr ("\n" ++ m) +-- l m = hPutStrLn stderr ("\n" ++ m) #ifdef mingw32_HOST_OS #include @@ -51,7 +51,7 @@ fromOTypeInfo :: String -- ^ Column name -> #{type SQLSMALLINT} -- ^ Data type - -> #{type SQLUINTEGER} -- ^ Column size + -> #{type SQLULEN} -- ^ Column size -> #{type SQLSMALLINT} -- ^ Is it nullable -> (String, SqlColDesc) fromOTypeInfo colname datatype colsize nullable = diff --git a/HDBC-odbc.cabal b/HDBC-odbc.cabal --- a/HDBC-odbc.cabal +++ b/HDBC-odbc.cabal @@ -1,5 +1,5 @@ Name: HDBC-odbc -Version: 2.2.3.0 +Version: 2.2.3.1 Cabal-Version: >=1.2.3 Build-type: Simple License: LGPL diff --git a/hdbc-odbc-helper.c b/hdbc-odbc-helper.c --- a/hdbc-odbc-helper.c +++ b/hdbc-odbc-helper.c @@ -8,7 +8,7 @@ #include #include "hdbc-odbc-helper.h" -SQLINTEGER nullData = SQL_NULL_DATA; +SQLLEN nullDataHDBC = SQL_NULL_DATA; int sqlSucceeded(SQLRETURN ret) { return SQL_SUCCEEDED(ret); diff --git a/hdbc-odbc-helper.h b/hdbc-odbc-helper.h --- a/hdbc-odbc-helper.h +++ b/hdbc-odbc-helper.h @@ -25,7 +25,7 @@ extern void sqlFreeHandleSth_app(finalizeonce *res); extern void sqlFreeHandleSth_finalizer(finalizeonce *res); -extern SQLINTEGER nullData; +extern SQLLEN nullDataHDBC; extern void *getSqlOvOdbc3(void); extern SQLRETURN disableAutoCommit(SQLHDBC conn); diff --git a/testsrc/TestMisc.hs b/testsrc/TestMisc.hs --- a/testsrc/TestMisc.hs +++ b/testsrc/TestMisc.hs @@ -163,7 +163,8 @@ [SqlInt32 101, SqlString "bar\x00A3", SqlNull], [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]] -tests = TestList [TestLabel "getColumnNames" testgetColumnNames, +tests = TestList [ + TestLabel "getColumnNames" testgetColumnNames, TestLabel "describeResult" testdescribeResult, TestLabel "describeTable" testdescribeTable, TestLabel "quickQuery" testquickQuery, diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs --- a/testsrc/Tests.hs +++ b/testsrc/Tests.hs @@ -31,4 +31,5 @@ TestLabel "SqlValue basics" Testbasics.tests, TestLabel "SpecificDB" SpecificDBTests.tests, TestLabel "Misc tests" TestMisc.tests, - TestLabel "Time tests" TestTime.tests] + TestLabel "Time tests" TestTime.tests + ]