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
data SqlHandleT = EnvHandle (Ptr CEnv)
| DbcHandle (Ptr CConn)
| StmtHandle (Ptr CStmt)
checkError :: String -> SqlHandleT -> Int16 -> IO ()
checkError msg o res =
do let rc = sqlSucceeded res
if rc == 0
then raiseError msg res o
else return ()
raiseError :: String -> Int16 -> 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 -> (1, castPtr c)
DbcHandle c -> (2, castPtr c)
StmtHandle c -> (3, 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
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))
-> (Ptr b -> IO ())
-> [a]
-> (Ptr (Ptr b) -> IO c)
-> IO c
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 <- (\hsc_ptr -> peekByteOff hsc_ptr 0) structptr
action objptr
)
isOK :: Int16 -> Bool
isOK r = sqlSucceeded r /= 0
foreign import ccall unsafe "sqlSucceeded"
sqlSucceeded :: Int16 -> CInt
foreign import ccall unsafe "sql.h SQLGetDiagRec"
sqlGetDiagRec :: Int16 -> Ptr () ->
Int16 -> CString -> Ptr (Int32)
-> CString -> Int16
-> Ptr (Int16) -> IO Int16