{-# OPTIONS_GHC -optc-D__HUGS__ #-} {-# INCLUDE #-} {-# INCLUDE #-} {-# LINE 1 "Database/HDBC/ODBC/Statement.hsc" #-} -- -*- mode: haskell; -*- {-# LINE 2 "Database/HDBC/ODBC/Statement.hsc" #-} {-# CFILES hdbc-odbc-helper.c #-} -- Above line for hugs {- Copyright (C) 2005-2006 John Goerzen This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA -} module Database.HDBC.ODBC.Statement 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.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.List import Data.Word import Data.Int import Control.Exception import System.IO import Data.Maybe l _ = return () --l m = hPutStrLn stderr ("\n" ++ m) {-# LINE 49 "Database/HDBC/ODBC/Statement.hsc" #-} {-# LINE 50 "Database/HDBC/ODBC/Statement.hsc" #-} {-# LINE 51 "Database/HDBC/ODBC/Statement.hsc" #-} data SState = SState { stomv :: MVar (Maybe Stmt), dbo :: Conn, squery :: String, colinfomv :: MVar [(String, SqlColDesc)]} -- FIXME: we currently do no prepare optimization whatsoever. newSState :: Conn -> String -> IO SState newSState indbo query = do newstomv <- newMVar Nothing newcolinfomv <- newMVar [] return SState {stomv = newstomv, dbo = indbo, squery = query, colinfomv = newcolinfomv} wrapStmt :: SState -> Statement wrapStmt sstate = Statement {execute = fexecute sstate, 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 iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) -> withConn iconn $ \cconn -> withCString "" $ \emptycs -> do rc1 <- sqlAllocStmtHandle 3 cconn psthptr {-# LINE 91 "Database/HDBC/ODBC/Statement.hsc" #-} sthptr <- peek psthptr wrappedsthptr <- withRawConn iconn (\rawconn -> wrapstmt sthptr rawconn) fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr checkError (name ++ " allocHandle") (DbcHandle cconn) rc1 return fsthptr wrapTheStmt iconn fsthptr = do sstate <- newSState iconn "" sstate <- newSState iconn "" swapMVar (stomv sstate) (Just fsthptr) let sth = wrapStmt sstate return sth fgettables iconn = do fsthptr <- makesth iconn "fgettables" withStmt fsthptr (\sthptr -> simpleSqlTables sthptr >>= checkError "gettables simpleSqlTables" (StmtHandle sthptr) ) sth <- wrapTheStmt iconn fsthptr results <- fetchAllRows' sth l (show results) return $ map (\x -> fromSql (x !! 2)) results fdescribetable iconn tablename = withCStringLen tablename $ \(cs, csl) -> do fsthptr <- makesth iconn "fdescribetable" withStmt fsthptr (\sthptr -> simpleSqlColumns sthptr cs (fromIntegral csl) >>= checkError "fdescribetable simpleSqlColumns" (StmtHandle sthptr) ) sth <- wrapTheStmt iconn fsthptr results <- fetchAllRows' sth l (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 args = withConn (dbo sstate) $ \cconn -> withCStringLen (squery sstate) $ \(cquery, cqlen) -> alloca $ \(psthptr::Ptr (Ptr CStmt)) -> do l "in fexecute" public_ffinish sstate rc1 <- sqlAllocStmtHandle 3 cconn psthptr {-# LINE 137 "Database/HDBC/ODBC/Statement.hsc" #-} 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) argsToFree <- zipWithM (bindCol sthptr) args [1..] 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) (concat argsToFree) case r of 100 -> return () -- Update that did nothing {-# LINE 157 "Database/HDBC/ODBC/Statement.hsc" #-} 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 sthptr = alloca $ \pcount -> do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" (StmtHandle sthptr) peek pcount -- Bind a parameter column before execution. bindCol sthptr arg icol = alloca $ \pdtype -> alloca $ \pcolsize -> alloca $ \pdecdigits -> {- We have to start by getting the SQL type of the column so we can send the correct type back to the server. Sigh. If the ODBC backend won't tell us the type, we fake it. We've got an annoying situation with error handling. Must make sure that all data is freed, but if there's an error, we have to raise it and the caller never gets to freed the allocated data to-date. 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 nullPtr when (not (isOK rc1)) $ -- Some drivers don't support that call do poke pdtype 1 {-# LINE 196 "Database/HDBC/ODBC/Statement.hsc" #-} poke pcolsize 0 poke pdecdigits 0 coltype <- peek pdtype colsize <- peek pcolsize decdigits <- peek pdecdigits case arg of SqlNull -> -- NULL parameter, bind it as such. do rc2 <- sqlBindParameter sthptr (fromIntegral icol) 1 {-# LINE 205 "Database/HDBC/ODBC/Statement.hsc" #-} 1 coltype colsize decdigits {-# LINE 206 "Database/HDBC/ODBC/Statement.hsc" #-} nullPtr 0 nullData checkError ("bindparameter " ++ show icol) (StmtHandle sthptr) rc2 return [] x -> do -- Otherwise, we have to allocate RAM, make sure it's -- not freed now, and pass it along... (csptr, cslen) <- newCStringLen (fromSql x) do pcslen <- malloc poke pcslen (fromIntegral cslen) rc2 <- sqlBindParameter sthptr (fromIntegral icol) 1 {-# LINE 217 "Database/HDBC/ODBC/Statement.hsc" #-} 1 coltype colsize decdigits {-# LINE 218 "Database/HDBC/ODBC/Statement.hsc" #-} csptr (fromIntegral cslen + 1) pcslen if isOK rc2 then do -- We bound it. Make foreignPtrs and return. fp1 <- newForeignPtr finalizerFree pcslen fp2 <- newForeignPtr finalizerFree csptr return [(fp1, fp2)] else do -- Binding failed. Free the data and raise -- error. free pcslen free csptr checkError ("bindparameter " ++ show icol) (StmtHandle sthptr) rc2 return [] -- will never get hit getSqlRowCount cstmt = alloca $ \prows -> do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt) peek prows {- General algorithm: find out how many columns we have, check the type of each to see if it's NULL. If it's not, fetch it as text and return that. -} ffetchrow :: SState -> IO (Maybe [SqlValue]) ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> case stmt of Nothing -> l "ffr nos" >> return (stmt, Nothing) Just cmstmt -> withStmt cmstmt $ \cstmt -> do rc <- sqlFetch cstmt if rc == 100 {-# LINE 247 "Database/HDBC/ODBC/Statement.hsc" #-} then do l "no more rows" -- Don't use public_ffinish here ffinish cmstmt return (Nothing, Nothing) else do l "getting stuff" checkError "sqlFetch" (StmtHandle cstmt) rc ncols <- getNumResultCols cstmt res <- mapM (getCol cstmt ) [1..ncols] return (stmt, Just res) where getCol cstmt icol = alloca $ \psize -> do sqlDescribeCol cstmt icol nullPtr 0 nullPtr nullPtr psize nullPtr nullPtr >>= checkError "sqlDescribeCol" (StmtHandle cstmt) size <- peek psize l $ "colsize: " ++ show size let bufsize = size + 127 -- Try to give extra space alloca $ \plen -> allocaBytes (fromIntegral bufsize + 1) $ \cs -> do sqlGetData cstmt (fromIntegral icol) 1 {-# LINE 268 "Database/HDBC/ODBC/Statement.hsc" #-} cs (fromIntegral bufsize) plen reslen <- peek plen case reslen of -1 -> return SqlNull {-# LINE 272 "Database/HDBC/ODBC/Statement.hsc" #-} -4 -> fail $ "Unexpected SQL_NO_TOTAL" {-# LINE 273 "Database/HDBC/ODBC/Statement.hsc" #-} len -> do s <- peekCStringLen (cs, fromIntegral len) l $ "col is: " ++ s return (SqlString s) 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 colname <- peekCStringLen (cscolname, fromIntegral colnamelen) datatype <- peek datatypeptr colsize <- peek colsizeptr nullable <- peek nullableptr return $ fromOTypeInfo colname datatype colsize nullable -- FIXME: needs a faster algorithm. fexecutemany :: SState -> [[SqlValue]] -> IO () fexecutemany sstate arglist = mapM_ (fexecute sstate) arglist >> return () -- Finish and change state public_ffinish sstate = do l "public_ffinish" modifyMVar_ (stomv sstate) worker where worker Nothing = return Nothing worker (Just sth) = ffinish sth >> return Nothing ffinish :: Stmt -> IO () ffinish p = withRawStmt p $ sqlFreeHandleSth_app foreign import ccall unsafe "hdbc-odbc-helper.h wrapobjodbc" wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt) foreign import ccall unsafe "sql.h SQLDescribeCol" sqlDescribeCol :: Ptr CStmt -> Int16 -- ^ Column number {-# LINE 317 "Database/HDBC/ODBC/Statement.hsc" #-} -> CString -- ^ Column name -> Int16 -- ^ Buffer length {-# LINE 319 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr (Int16) -- ^ name length ptr {-# LINE 320 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr (Int16) -- ^ data type ptr {-# LINE 321 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr (Word32) -- ^ column size ptr {-# LINE 322 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr (Int16) -- ^ decimal digits ptr {-# LINE 323 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr (Int16) -- ^ nullable ptr {-# LINE 324 "Database/HDBC/ODBC/Statement.hsc" #-} -> IO Int16 {-# LINE 325 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLGetData" sqlGetData :: Ptr CStmt -- ^ statement handle -> Word16 -- ^ Column number {-# LINE 329 "Database/HDBC/ODBC/Statement.hsc" #-} -> Int16 -- ^ target type {-# LINE 330 "Database/HDBC/ODBC/Statement.hsc" #-} -> CString -- ^ target value pointer (void * in C) -> Int32 -- ^ buffer len {-# LINE 332 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr (Int32) {-# LINE 333 "Database/HDBC/ODBC/Statement.hsc" #-} -> IO Int16 {-# LINE 334 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "hdbc-odbc-helper.h sqlFreeHandleSth_app" sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO () foreign import ccall unsafe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer" sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ()) foreign import ccall unsafe "sql.h SQLPrepare" sqlPrepare :: Ptr CStmt -> CString -> Int32 {-# LINE 343 "Database/HDBC/ODBC/Statement.hsc" #-} -> IO Int16 {-# LINE 344 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLExecute" sqlExecute :: Ptr CStmt -> IO Int16 {-# LINE 347 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLAllocHandle" sqlAllocStmtHandle :: Int16 -> Ptr CConn -> {-# LINE 350 "Database/HDBC/ODBC/Statement.hsc" #-} Ptr (Ptr CStmt) -> IO Int16 {-# LINE 351 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLNumResultCols" sqlNumResultCols :: Ptr CStmt -> Ptr Int16 {-# LINE 354 "Database/HDBC/ODBC/Statement.hsc" #-} -> IO Int16 {-# LINE 355 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLRowCount" sqlRowCount :: Ptr CStmt -> Ptr Int32 -> IO Int16 {-# LINE 358 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLBindParameter" sqlBindParameter :: Ptr CStmt -- ^ Statement handle -> Word16 -- ^ Parameter Number {-# LINE 362 "Database/HDBC/ODBC/Statement.hsc" #-} -> Int16 -- ^ Input or output {-# LINE 363 "Database/HDBC/ODBC/Statement.hsc" #-} -> Int16 -- ^ Value type {-# LINE 364 "Database/HDBC/ODBC/Statement.hsc" #-} -> Int16 -- ^ Parameter type {-# LINE 365 "Database/HDBC/ODBC/Statement.hsc" #-} -> Word32 -- ^ column size {-# LINE 366 "Database/HDBC/ODBC/Statement.hsc" #-} -> Int16 -- ^ decimal digits {-# LINE 367 "Database/HDBC/ODBC/Statement.hsc" #-} -> CString -- ^ Parameter value pointer -> Int32 -- ^ buffer length {-# LINE 369 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr Int32 -- ^ strlen_or_indptr {-# LINE 370 "Database/HDBC/ODBC/Statement.hsc" #-} -> IO Int16 {-# LINE 371 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "hdbc-odbc-helper.h &nullData" nullData :: Ptr Int32 {-# LINE 374 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLDescribeParam" sqlDescribeParam :: Ptr CStmt -> Word16 -- ^ parameter number {-# LINE 378 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr Int16 -- ^ data type ptr {-# LINE 379 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr Word32 -- ^ parameter size ptr {-# LINE 380 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr Int16 -- ^ dec digits ptr {-# LINE 381 "Database/HDBC/ODBC/Statement.hsc" #-} -> Ptr Int16 -- ^ nullable ptr {-# LINE 382 "Database/HDBC/ODBC/Statement.hsc" #-} -> IO Int16 {-# LINE 383 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "sql.h SQLFetch" sqlFetch :: Ptr CStmt -> IO Int16 {-# LINE 386 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlTables" simpleSqlTables :: Ptr CStmt -> IO Int16 {-# LINE 389 "Database/HDBC/ODBC/Statement.hsc" #-} foreign import ccall unsafe "hdbc-odbc-helper.h simpleSqlColumns" simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> Int16 -> IO Int16 {-# LINE 393 "Database/HDBC/ODBC/Statement.hsc" #-}