module Database.HDBC.ODBC.Statement (
fGetQueryInfo,
newSth,
fgettables,
fdescribetable
) where
import Database.HDBC.Types
import Database.HDBC
import Database.HDBC.DriverUtils
import Database.HDBC.ODBC.Types
import Database.HDBC.ODBC.Utils
import Database.HDBC.ODBC.TypeConv
import Foreign.C.String (castCUCharToChar)
import Foreign.C.Types
import Foreign.ForeignPtr
import Foreign.Ptr
import Control.Concurrent.MVar
import Foreign.C.String
import Foreign.Marshal
import Foreign.Storable
import Control.Monad
import Data.Word
import Data.Time.Calendar (fromGregorian)
import Data.Time.LocalTime (TimeOfDay(TimeOfDay), LocalTime(LocalTime))
import Data.Int
import Data.Maybe (catMaybes, fromMaybe)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BUTF8
import qualified Data.ByteString.Unsafe as B
import Unsafe.Coerce (unsafeCoerce)
import System.IO (hPutStrLn, stderr)
import Debug.Trace
l :: String -> IO ()
l _ = return ()
fGetQueryInfo :: Conn -> ChildList -> String
-> IO ([SqlColDesc], [(String, SqlColDesc)])
fGetQueryInfo iconn children query =
do l "in fGetQueryInfo"
sstate <- newSState iconn query
addChild children (wrapStmt sstate)
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"
rc1 <- sqlAllocStmtHandle 3 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)
parmInfo <- fgetparminfo sthptr
colInfo <- fgetcolinfo sthptr
return (parmInfo, colInfo)
data SState = SState
{ stomv :: MVar (Maybe Stmt)
, dbo :: Conn
, squery :: String
, colinfomv :: MVar [(String, SqlColDesc)]
, bindColsMV :: MVar (Maybe [(BindCol, Ptr Int64)])
}
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
}
wrapStmt :: SState -> Statement
wrapStmt sstate = Statement
{ execute = fexecute sstate
, executeRaw = return ()
, executeMany = fexecutemany sstate
, finish = public_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 indbo mchildren query =
do l "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 3 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
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
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 3 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)
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)
case r of
100 -> return ()
x -> checkError "execute execute" (StmtHandle sthptr) x
rc <- getNumResultCols sthptr
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
getNumResultCols :: Ptr CStmt -> IO Int16
getNumResultCols sthptr = alloca $ \pcount ->
do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols"
(StmtHandle sthptr)
peek pcount
bindParam :: Ptr CStmt -> SqlValue -> Word16
-> IO (Maybe (Ptr Int64, Ptr CChar))
bindParam sthptr arg icol = alloca $ \pdtype ->
alloca $ \pcolsize ->
alloca $ \pdecdigits ->
alloca $ \pnullable ->
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)) $
do poke pdtype 1
poke pcolsize 0
poke pdecdigits 0
coltype <- peek pdtype
colsize <- peek pcolsize
decdigits <- peek pdecdigits
l $ "Results: " ++ show (coltype, colsize, decdigits)
case arg of
SqlNull ->
do l "Binding null"
rc2 <- sqlBindParameter sthptr (fromIntegral icol)
1
1 coltype colsize decdigits
nullPtr 0 nullDataHDBC
checkError ("bindparameter NULL " ++ show icol)
(StmtHandle sthptr) rc2
return Nothing
x -> do
(csptr, cslen) <- cstrUtf8BString (fromSql x)
do pcslen <- malloc
poke pcslen (fromIntegral cslen)
rc2 <- sqlBindParameter sthptr (fromIntegral icol)
1
1 coltype
(if isOK rc1 then colsize else fromIntegral cslen + 1) decdigits
csptr (fromIntegral cslen + 1) pcslen
if isOK rc2
then do
return $ Just (pcslen, csptr)
else do
free pcslen
free csptr
checkError ("bindparameter " ++ show icol)
(StmtHandle sthptr) rc2
return Nothing
getSqlRowCount :: Ptr CStmt -> IO Int32
getSqlRowCount cstmt = alloca $ \prows ->
do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt)
peek prows
cstrUtf8BString :: B.ByteString -> IO CStringLen
cstrUtf8BString bs = do
B.unsafeUseAsCStringLen bs $ \(s,len) -> do
res <- mallocBytes (len+1)
copyBytes res s len
poke (plusPtr res len) (0::CChar)
return (res, len)
ffetchrow :: SState -> IO (Maybe [SqlValue])
ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> do
l $ "ffetchrow"
case stmt of
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 == 100
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 == 0 || rc == 1
then mapM (bindColToSqlValue cstmt) bindCols
else raiseError "sqlGetData" rc (StmtHandle cstmt)
return (stmt, Just sqlValues)
getBindCols :: SState -> Ptr CStmt -> IO [(BindCol, Ptr Int64)]
getBindCols sstate cstmt = do
l "getBindCols"
modifyMVar (bindColsMV sstate) $ \mBindCols ->
case mBindCols of
Nothing -> do
cols <- getNumResultCols cstmt
pBindCols <- mapM (mkBindCol sstate cstmt) [1 .. cols]
return (Just pBindCols, pBindCols)
Just bindCols -> do
return (mBindCols, bindCols)
getLongColData cstmt bindCol = do
let (BindColString buf bufLen col) = bindCol
l $ "buflen: " ++ show bufLen
bs <- B.packCStringLen (buf, fromIntegral (bufLen 1))
l $ "sql_no_total col " ++ show (BUTF8.toString bs)
bs2 <- getRestLongColData cstmt 1 col bs
return $ SqlByteString bs2
getRestLongColData cstmt cBinding icol acc = do
l "getLongColData"
alloca $ \plen ->
allocaBytes colBufSizeMaximum $ \buf ->
do res <- sqlGetData cstmt (fromIntegral icol) cBinding
buf (fromIntegral colBufSizeMaximum) plen
if res == 0 || res == 1
then do
len <- peek plen
if len == 100
then return acc
else do
let bufmax = fromIntegral $ colBufSizeMaximum 1
bs <- B.packCStringLen (buf, fromIntegral (if len == 4 || len > bufmax then bufmax else len))
l $ "sql_no_total col is: " ++ show (BUTF8.toString bs)
let newacc = B.append acc bs
if len /= 4 && len <= bufmax
then return newacc
else getRestLongColData cstmt cBinding icol newacc
else raiseError "sqlGetData" res (StmtHandle cstmt)
getColData cstmt cBinding icol = do
alloca $ \plen ->
allocaBytes colBufSizeDefault $ \buf ->
do res <- sqlGetData cstmt (fromIntegral icol) cBinding
buf (fromIntegral colBufSizeDefault) plen
case res of
0 ->
do len <- peek plen
case len of
1 -> return SqlNull
4 -> fail $ "Unexpected SQL_NO_TOTAL"
_ -> do bs <- B.packCStringLen (buf, fromIntegral len)
l $ "col is: " ++ show (BUTF8.toString bs)
return (SqlByteString bs)
1 ->
do len <- peek plen
allocaBytes (fromIntegral len + 1) $ \buf2 ->
do sqlGetData cstmt (fromIntegral icol) cBinding
buf2 (fromIntegral len + 1) plen
>>= checkError "sqlGetData" (StmtHandle cstmt)
len2 <- peek plen
let firstbuf = case cBinding of
2 -> colBufSizeDefault
_ -> colBufSizeDefault 1
bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf))
(B.packCStringLen (buf2, fromIntegral len2))
l $ "col is: " ++ (BUTF8.toString bs)
return (SqlByteString bs)
_ -> raiseError "sqlGetData" res (StmtHandle cstmt)
ffetchrowBaseline sstate = do
Just cmstmt <- readMVar (stomv sstate)
withStmt cmstmt $ \cstmt -> do
rc <- sqlFetch cstmt
if rc == 100
then do ffinish cmstmt
return Nothing
else do return (Just [])
data ColBuf
data BindCol
= BindColString (Ptr CChar) Int64 Word16
| BindColWString (Ptr CWchar) Int64 Word16
| BindColBit (Ptr CUChar)
| BindColTinyInt (Ptr CChar)
| BindColShort (Ptr CShort)
| BindColLong (Ptr CLong)
| BindColBigInt (Ptr Int64)
| BindColFloat (Ptr CFloat)
| BindColDouble (Ptr CDouble)
| BindColBinary (Ptr CUChar) Int64 Word16
| BindColDate (Ptr StructDate)
| BindColTime (Ptr StructTime)
| BindColTimestamp (Ptr StructTimestamp)
| BindColGetData Word16
data StructDate = StructDate
Int16
Word16
Word16
deriving Show
instance Storable StructDate where
sizeOf _ = (6)
alignment _ = alignment (undefined :: CLong)
poke p (StructDate year month day) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p year
(\hsc_ptr -> pokeByteOff hsc_ptr 2) p month
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p day
peek p = return StructDate
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 0) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 2) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 4) p)
data StructTime = StructTime
Word16
Word16
Word16
instance Storable StructTime where
sizeOf _ = (6)
alignment _ = alignment (undefined :: CLong)
poke p (StructTime hour minute second) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p hour
(\hsc_ptr -> pokeByteOff hsc_ptr 2) p minute
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p second
peek p = return StructTime
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 0) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 2) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 4) p)
data StructTimestamp = StructTimestamp
Int16
Word16
Word16
Word16
Word16
Word16
Word32
instance Storable StructTimestamp where
sizeOf _ = (16)
alignment _ = alignment (undefined :: CLong)
poke p (StructTimestamp year month day hour minute second fraction) = do
(\hsc_ptr -> pokeByteOff hsc_ptr 0) p year
(\hsc_ptr -> pokeByteOff hsc_ptr 2) p month
(\hsc_ptr -> pokeByteOff hsc_ptr 4) p day
(\hsc_ptr -> pokeByteOff hsc_ptr 6) p hour
(\hsc_ptr -> pokeByteOff hsc_ptr 8) p minute
(\hsc_ptr -> pokeByteOff hsc_ptr 10) p second
(\hsc_ptr -> pokeByteOff hsc_ptr 12) p fraction
peek p = return StructTimestamp
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 0) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 2) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 4) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 6) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 8) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 10) p)
`ap` ((\hsc_ptr -> peekByteOff hsc_ptr 12) p)
mkBindCol :: SState -> Ptr CStmt -> Int16 -> IO (BindCol, Ptr Int64)
mkBindCol sstate cstmt col = do
l "mkBindCol"
colInfo <- readMVar (colinfomv sstate)
let colDesc = (snd (colInfo !! ((fromIntegral col) 1)))
case colType colDesc of
SqlCharT -> mkBindColString cstmt col' (colSize colDesc)
SqlVarCharT -> mkBindColString cstmt col' (colSize colDesc)
SqlLongVarCharT -> mkBindColString cstmt col' (colSize colDesc)
SqlWCharT -> mkBindColWString cstmt col' (colSize colDesc)
SqlWVarCharT -> mkBindColWString cstmt col' (colSize colDesc)
SqlWLongVarCharT -> mkBindColWString cstmt col' (colSize colDesc)
SqlDecimalT -> mkBindColString cstmt col' (colSize colDesc)
SqlNumericT -> mkBindColString cstmt col' (colSize colDesc)
SqlBitT -> mkBindColBit cstmt col' (colSize colDesc)
SqlTinyIntT -> mkBindColTinyInt cstmt col' (colSize colDesc)
SqlSmallIntT -> mkBindColShort cstmt col' (colSize colDesc)
SqlIntegerT -> mkBindColLong cstmt col' (colSize colDesc)
SqlBigIntT -> mkBindColBigInt cstmt col' (colSize colDesc)
SqlRealT -> mkBindColFloat cstmt col' (colSize colDesc)
SqlFloatT -> mkBindColDouble cstmt col' (colSize colDesc)
SqlDoubleT -> mkBindColDouble cstmt col' (colSize colDesc)
SqlBinaryT -> mkBindColBinary cstmt col' (colSize colDesc)
SqlVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc)
SqlLongVarBinaryT -> mkBindColBinary cstmt col' (colSize colDesc)
SqlDateT -> mkBindColDate cstmt col' (colSize colDesc)
SqlTimeT -> mkBindColTime cstmt col' (colSize colDesc)
SqlTimestampT -> mkBindColTimestamp cstmt col' (colSize colDesc)
_ -> mkBindColGetData col'
where
col' = fromIntegral col
colBufSizeDefault = 1024
colBufSizeMaximum = 4096
mkBindColString cstmt col mColSize = do
l "mkBindCol: BindColString"
let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize
let bufLen = sizeOf (undefined :: CChar) * (colSize + 1)
buf <- mallocBytes bufLen
pStrLen <- malloc
sqlBindCol cstmt col (1) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColString buf (fromIntegral bufLen) col, pStrLen)
mkBindColWString cstmt col mColSize = do
l "mkBindCol: BindColWString"
let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize
let bufLen = sizeOf (undefined :: CWchar) * (colSize + 1)
buf <- mallocBytes bufLen
pStrLen <- malloc
sqlBindCol cstmt col (1) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColWString buf (fromIntegral bufLen) col, pStrLen)
mkBindColBit cstmt col mColSize = do
l "mkBindCol: BindColBit"
let bufLen = sizeOf (undefined :: CChar)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (7) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColBit buf, pStrLen)
mkBindColTinyInt cstmt col mColSize = do
l "mkBindCol: BindColTinyInt"
let bufLen = sizeOf (undefined :: CUChar)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (26) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColTinyInt buf, pStrLen)
mkBindColShort cstmt col mColSize = do
l "mkBindCol: BindColShort"
let bufLen = sizeOf (undefined :: CShort)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (15) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColShort buf, pStrLen)
mkBindColLong cstmt col mColSize = do
l "mkBindCol: BindColSize"
let bufLen = sizeOf (undefined :: CLong)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (16) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColLong buf, pStrLen)
mkBindColBigInt cstmt col mColSize = do
l "mkBindCol: BindColBigInt"
let bufLen = sizeOf (undefined :: CInt)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (25) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColBigInt buf, pStrLen)
mkBindColFloat cstmt col mColSize = do
l "mkBindCol: BindColFloat"
let bufLen = sizeOf (undefined :: CFloat)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (7) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColFloat buf, pStrLen)
mkBindColDouble cstmt col mColSize = do
l "mkBindCol: BindColDouble"
let bufLen = sizeOf (undefined :: CDouble)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (8) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColDouble buf, pStrLen)
mkBindColBinary cstmt col mColSize = do
l "mkBindCol: BindColBinary"
let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize
let bufLen = sizeOf (undefined :: CUChar) * (colSize + 1)
buf <- mallocBytes bufLen
pStrLen <- malloc
sqlBindCol cstmt col (2) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColBinary buf (fromIntegral bufLen) col, pStrLen)
mkBindColDate cstmt col mColSize = do
l "mkBindCol: BindColDate"
let bufLen = sizeOf (undefined :: StructDate)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (91) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColDate buf, pStrLen)
mkBindColTime cstmt col mColSize = do
l "mkBindCol: BindColTime"
let bufLen = sizeOf (undefined :: StructTime)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (92) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColTime buf, pStrLen)
mkBindColTimestamp cstmt col mColSize = do
l "mkBindCol: BindColTimestamp"
let bufLen = sizeOf (undefined :: StructTimestamp)
buf <- malloc
pStrLen <- malloc
sqlBindCol cstmt col (93) (castPtr buf) (fromIntegral bufLen) pStrLen
return (BindColTimestamp buf, pStrLen)
mkBindColGetData col = do
l "mkBindCol: BindColGetData"
return (BindColGetData col, nullPtr)
freeBindCol :: BindCol -> IO ()
freeBindCol (BindColString buf _ _) = free buf
freeBindCol (BindColWString buf _ _) = free buf
freeBindCol (BindColBit buf) = free buf
freeBindCol (BindColTinyInt buf) = free buf
freeBindCol (BindColShort buf) = free buf
freeBindCol (BindColLong buf) = free buf
freeBindCol (BindColBigInt buf) = free buf
freeBindCol (BindColFloat buf) = free buf
freeBindCol (BindColDouble buf) = free buf
freeBindCol (BindColBinary buf _ _) = free buf
freeBindCol (BindColDate buf) = free buf
freeBindCol (BindColTime buf) = free buf
freeBindCol (BindColTimestamp buf) = free buf
freeBindCol (BindColGetData _ ) = return ()
bindColToSqlValue :: Ptr CStmt -> (BindCol, Ptr Int64) -> IO SqlValue
bindColToSqlValue pcstmt (BindColGetData col, _) = do
l "bindColToSqlValue: BindColGetData"
getColData pcstmt 1 col
bindColToSqlValue pcstmt (bindCol, pStrLen) = do
l "bindColToSqlValue"
strLen <- peek pStrLen
case strLen of
1 -> return SqlNull
4 -> getLongColData pcstmt bindCol
_ -> bindColToSqlValue' pcstmt bindCol strLen
bindColToSqlValue' :: Ptr CStmt -> BindCol -> Int64 -> 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
return $ SqlByteString bs
| otherwise = getColData pcstmt 1 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
return $ SqlByteString bs
| otherwise = getColData pcstmt 1 col
bindColToSqlValue' _ (BindColBit buf) strLen = do
bit <- peek buf
l $ "bindColToSqlValue BindColBit " ++ show bit
return $ SqlChar (castCUCharToChar bit)
bindColToSqlValue' _ (BindColTinyInt buf) strLen = do
tinyInt <- peek buf
l $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt
return $ SqlChar (castCCharToChar tinyInt)
bindColToSqlValue' _ (BindColShort buf) strLen = do
short <- peek buf
l $ "bindColToSqlValue BindColShort" ++ show short
return $ SqlInt32 (fromIntegral short)
bindColToSqlValue' _ (BindColLong buf) strLen = do
long <- peek buf
l $ "bindColToSqlValue BindColLong " ++ show long
return $ SqlInt32 (fromIntegral long)
bindColToSqlValue' _ (BindColBigInt buf) strLen = do
bigInt <- peek buf
l $ "bindColToSqlValue BindColBigInt " ++ show bigInt
return $ SqlInt64 (fromIntegral bigInt)
bindColToSqlValue' _ (BindColFloat buf) strLen = do
float <- peek buf
l $ "bindColToSqlValue BindColFloat " ++ show float
return $ SqlDouble (realToFrac float)
bindColToSqlValue' _ (BindColDouble buf) strLen = do
double <- peek buf
l $ "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
return $ SqlByteString bs
| otherwise = getColData pcstmt (2) col
bindColToSqlValue' _ (BindColDate buf) strLen = do
StructDate year month day <- peek buf
l $ "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"
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"
return $ SqlLocalTime $ LocalTime
(fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))
(TimeOfDay (fromIntegral hour) (fromIntegral minute)
(fromIntegral second + (fromIntegral nanosecond / 1000000000)))
bindColToSqlValue' _ (BindColGetData _) _ =
error "bindColToSqlValue': unexpected BindColGetData!"
fgetcolinfo :: Ptr CStmt -> IO [(String, SqlColDesc)]
fgetcolinfo cstmt =
do ncols <- getNumResultCols cstmt
mapM getname [1..ncols]
where getname icol = alloca $ \colnamelp ->
allocaBytes 128 $ \cscolname ->
alloca $ \datatypeptr ->
alloca $ \colsizeptr ->
alloca $ \nullableptr ->
do sqlDescribeCol cstmt icol cscolname 127 colnamelp
datatypeptr colsizeptr nullPtr nullableptr
colnamelen <- peek colnamelp
colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen)
let colname = BUTF8.toString colnamebs
datatype <- peek datatypeptr
colsize <- peek colsizeptr
nullable <- peek nullableptr
return $ fromOTypeInfo colname datatype colsize nullable
fexecutemany :: SState -> [[SqlValue]] -> IO ()
fexecutemany sstate arglist =
mapM_ (fexecute sstate) arglist >> return ()
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
return Nothing
ffinish :: Stmt -> IO ()
ffinish stmt = withRawStmt stmt $ sqlFreeHandleSth_app
foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc"
wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt)
foreign import ccall safe "sql.h SQLDescribeCol"
sqlDescribeCol :: Ptr CStmt
-> Int16
-> CString
-> Int16
-> Ptr (Int16)
-> Ptr (Int16)
-> Ptr (Word64)
-> Ptr (Int16)
-> Ptr (Int16)
-> IO Int16
foreign import ccall safe "sql.h SQLGetData"
sqlGetData :: Ptr CStmt
-> Word16
-> Int16
-> CString
-> Int64
-> Ptr (Int64)
-> IO Int16
foreign import ccall safe "sql.h SQLBindCol"
sqlBindCol :: Ptr CStmt
-> Word16
-> Int16
-> Ptr ColBuf
-> Int64
-> Ptr (Int64)
-> IO Int16
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 ccall safe "sql.h SQLPrepare"
sqlPrepare :: Ptr CStmt -> CString -> Int32
-> IO Int16
foreign import ccall safe "sql.h SQLExecute"
sqlExecute :: Ptr CStmt -> IO Int16
foreign import ccall safe "sql.h SQLAllocHandle"
sqlAllocStmtHandle :: Int16 -> Ptr CConn ->
Ptr (Ptr CStmt) -> IO Int16
foreign import ccall safe "sql.h SQLNumResultCols"
sqlNumResultCols :: Ptr CStmt -> Ptr Int16
-> IO Int16
foreign import ccall safe "sql.h SQLRowCount"
sqlRowCount :: Ptr CStmt -> Ptr Int32 -> IO Int16
foreign import ccall safe "sql.h SQLBindParameter"
sqlBindParameter :: Ptr CStmt
-> Word16
-> Int16
-> Int16
-> Int16
-> Word64
-> Int16
-> CString
-> Int64
-> Ptr Int64
-> IO Int16
foreign import ccall safe "hdbc-odbc-helper.h &nullDataHDBC"
nullDataHDBC :: Ptr Int64
foreign import ccall safe "sql.h SQLDescribeParam"
sqlDescribeParam :: Ptr CStmt
-> Word16
-> Ptr Int16
-> Ptr Word64
-> Ptr Int16
-> Ptr Int16
-> IO Int16
foreign import ccall safe "sql.h SQLFetch"
sqlFetch :: Ptr CStmt -> IO Int16
foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables"
simpleSqlTables :: Ptr CStmt -> IO Int16
foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns"
simpleSqlColumns :: Ptr CStmt -> Ptr CChar ->
Int16 -> IO Int16
fgetparminfo :: Ptr CStmt -> IO [SqlColDesc]
fgetparminfo cstmt =
do ncols <- getNumParams cstmt
mapM getname [1..ncols]
where getname icol =
alloca $ \datatypeptr ->
alloca $ \colsizeptr ->
alloca $ \nullableptr ->
do poke datatypeptr 127
res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol)
datatypeptr colsizeptr nullPtr nullableptr
putStrLn $ show res
datatype <- peek datatypeptr
colsize <- peek colsizeptr
nullable <- peek nullableptr
return $ snd $ fromOTypeInfo "" datatype colsize nullable
getNumParams :: Ptr CStmt -> IO Int16
getNumParams sthptr = alloca $ \pcount ->
do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols"
(StmtHandle sthptr)
peek pcount
foreign import ccall safe "sql.h SQLNumParams"
sqlNumParams :: Ptr CStmt -> Ptr Int16
-> IO Int16