[htoolkit-cvs] HSQL/Oracle/Database/HSQL Oracle.hsc,1.10,1.11

[<kr_...@us...>]

Update of /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL
In directory sc8-pr-cvs5.sourceforge.net:/tmp/cvs-serv30720/Database/HSQL

Modified Files:
	Oracle.hsc 
Log Message:
Prepared statements and NULL value fetch for Oracle


Index: Oracle.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/Oracle.hsc,v
retrieving revision 1.10
retrieving revision 1.11
diff -C2 -d -r1.10 -r1.11
*** Oracle.hsc	4 Jan 2006 09:04:36 -0000	1.10
--- Oracle.hsc	19 Sep 2006 12:23:09 -0000	1.11
***************
*** 22,25 ****
--- 22,26 ----
  import Control.Exception(throwDyn)
  import Data.Word
+ import Data.List(foldl')
  
  #include <HsOCI.h>
***************
*** 32,35 ****
--- 33,37 ----
  type OCIParam  = OCIHandle
  type OCIDefine = OCIHandle
+ type OCIBind   = OCIHandle
  type OCIDescribe=OCIHandle
  
***************
*** 49,52 ****
--- 51,55 ----
  foreign import ccall "OCIStmtFetch2" ociStmtFetch2 :: OCIStmt -> OCIError -> CInt -> CInt -> CInt -> CInt -> IO CInt
  foreign import ccall "OCIDefineByPos" ociDefineByPos :: OCIStmt -> Ptr OCIDefine -> OCIError -> CInt -> Ptr a -> CInt -> CShort -> Ptr CShort -> Ptr CShort -> Ptr CShort -> CInt -> IO CInt
+ foreign import ccall "OCIBindByPos"   ociBindByPos   :: OCIStmt -> Ptr OCIBind   -> OCIError -> CInt -> Ptr a -> CInt -> CShort -> Ptr CShort -> Ptr CShort -> Ptr CShort -> CInt -> Ptr CInt -> CInt -> IO CInt
  
  foreign import ccall "OCIParamGet" ociParamGet :: OCIHandle -> CInt -> OCIError -> Ptr OCIParam -> CInt -> IO CInt
***************
*** 128,131 ****
--- 131,135 ----
      			{ connDisconnect = disconnect svcCtx err
      			, connExecute    = execute myEnvironment svcCtx err
+     			, connPrepare    = prepare connection myEnvironment svcCtx err
      			, connQuery      = query connection myEnvironment svcCtx err
      			, connTables     = tables env svcCtx err
***************
*** 145,149 ****
        withForeignPtr envRef $ \env ->
        withCStringLen query $ \(query,query_len) ->
!       alloca $ \pStmt -> do
        alloca $ \pCount -> do
          ociHandleAlloc env pStmt (#const OCI_HTYPE_STMT) 0 nullPtr >>= handleSqlResult err
--- 149,153 ----
        withForeignPtr envRef $ \env ->
        withCStringLen query $ \(query,query_len) ->
!       alloca $ \pStmt ->
        alloca $ \pCount -> do
          ociHandleAlloc env pStmt (#const OCI_HTYPE_STMT) 0 nullPtr >>= handleSqlResult err
***************
*** 156,159 ****
--- 160,185 ----
          return $! fromIntegral count
  
+     prepare connection envRef svcCtx err query = 
+       withForeignPtr envRef $ \env ->
+       withCStringLen query $ \(query,query_len) ->
+       alloca $ \pStmt -> do
+         ociHandleAlloc env pStmt (#const OCI_HTYPE_STMT) 0 nullPtr >>= handleSqlResult err
+         stmt <- peek pStmt
+ 	ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult err
+ 	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs err stmt 1)
+ 	let offsets_arr_size = length fields * sizeOf offsets_arr_size
+ 	buffer <- mallocBytes (foldl' (\s t -> sizeOf (undefined :: CShort) + sqlType2Size t + s) offsets_arr_size fields)
+ 	definePositions stmt err buffer 0 offsets_arr_size fields
+ 	refFalse <- newMVar False
+         return (Statement
+                   { stmtConn   = connection
+                   , stmtClose  = closeStatement stmt buffer err
+                   , stmtExecute= executePrepared svcCtx stmt err
+                   , stmtFetch  = fetch stmt err
+                   , stmtGetCol = getColValue buffer
+                   , stmtFields = fields
+                   , stmtClosed = refFalse
+                   })
+ 
      query connection envRef svcCtx err query = 
        withForeignPtr envRef $ \env ->
***************
*** 164,214 ****
  	ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult err
  	ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
! 	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs stmt 1)
! 	let offsets_arr_size = fromIntegral (length fields * sizeOf offsets_arr_size) :: CInt
! 	buffer <- mallocBytes (fromIntegral (foldr ((+) . sqlType2Size) offsets_arr_size fields))
  	definePositions stmt err buffer 0 offsets_arr_size fields
  	refFalse <- newMVar False
!         let statement = Statement
! 		{ stmtConn   = connection
! 		, stmtClose  = closeStatement stmt buffer err
! 		, stmtFetch  = fetch stmt err
! 		, stmtGetCol = getColValue buffer
! 		, stmtFields = fields
! 		, stmtClosed = refFalse
! 		}
!         return statement
!         where
!           getFieldDefs stmt counter buffer = do
!             res <- ociParamGet stmt (#const OCI_HTYPE_STMT) err ((#ptr FIELD_DEF, par) buffer) counter
!             if res == (#const OCI_SUCCESS)
!               then do field  <- getFieldDef err buffer
!                       fields <- getFieldDefs stmt (counter+1) buffer
!                       return (field:fields)
!               else return []
  
!           sqlType2Size :: FieldDef -> CInt
!           sqlType2Size (_,tp,_) =
!             case tp of
!               SqlVarChar n   -> fromIntegral n+1
!               SqlNumeric p s -> fromIntegral (p+s+3) -- The value precision plus optional positions for '.', '-' and
!                                                      -- one position for the '\0' character at end of the string.
!               SqlInteger     -> 16 -- 12 digits are enough (maxBound :: Int) has 10 digits.
!                                    -- in addition we may need one position for '-' and one
!                                    -- for the '\0' character at end of the string.
!               SqlFloat       -> 100
!               SqlDate        -> 100
! 	      SqlTime        -> 100
! 	      SqlTimeTZ      -> 100
! 	      SqlTimeStamp   -> 100
! 	      SqlText        -> 100
! 	      SqlUnknown _   -> 0
  
!           definePositions stmt err buffer pos offset [] = return ()
!           definePositions stmt err buffer pos offset (field:fields) =
!             alloca $ \pDef -> do
!               let size = sqlType2Size field
!               poke (castPtr buffer `advancePtr` fromIntegral pos) offset
!               ociDefineByPos stmt pDef err (pos+1) (buffer `plusPtr` fromIntegral offset) size (#const SQLT_STR) nullPtr nullPtr nullPtr (#const OCI_DEFAULT)
!               definePositions stmt err buffer (pos+1) (offset+size) fields
  
      mkSqlType :: (#type OCITypeCode) -> (#type ub2) -> (#type ub1) -> (#type ub1) -> SqlType
--- 190,282 ----
  	ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult err
  	ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
! 	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs err stmt 1)
! 	let offsets_arr_size = length fields * sizeOf offsets_arr_size
! 	buffer <- mallocBytes (foldl' (\s t -> sizeOf (undefined :: CShort) + sqlType2Size t + s) offsets_arr_size fields)
  	definePositions stmt err buffer 0 offsets_arr_size fields
  	refFalse <- newMVar False
!         return (Statement
!                   { stmtConn   = connection
!                   , stmtClose  = closeStatement stmt buffer err
!                   , stmtExecute= throwDyn SqlUnsupportedOperation
!                   , stmtFetch  = fetch stmt err
!                   , stmtGetCol = getColValue buffer
!                   , stmtFields = fields
!                   , stmtClosed = refFalse
!                   })
  
!     executePrepared svcCtx stmt err values =
!       alloca $ \pCount -> do
!         bindings <- setParams stmt err 0 [] values
!         res <- ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT)
!         mapM_ free bindings
!         handleSqlResult err res
!         ociAttrGet stmt (#const OCI_HTYPE_STMT) pCount nullPtr (#const OCI_ATTR_ROW_COUNT) err >>= handleSqlResult err
!         count <- peek (pCount :: Ptr (#type ub4))
!         return $! fromIntegral count
  
!     setParams stmt err index bindings []                                 = return bindings
!     setParams stmt err index bindings (SqlStringValue    value : values) =
!       alloca $ \pBind -> do
!         cstr <- newCString value
!         res <- ociBindByPos stmt pBind err (index+1) cstr (fromIntegral (length value+1)) (#const SQLT_STR) nullPtr nullPtr nullPtr (#const OCI_DEFAULT) nullPtr (#const OCI_DEFAULT)
!         handleSqlResult err res
!         setParams stmt err (index+1) (castPtr cstr:bindings) values
!     setParams stmt err index bindings (SqlIntValue       value : values) =
!       alloca $ \pBind -> do
!         pValue <- malloc
!         poke pValue value
!         res <- ociBindByPos stmt pBind err (index+1) pValue (fromIntegral (sizeOf value)) (#const SQLT_INT) nullPtr nullPtr nullPtr (#const OCI_DEFAULT) nullPtr (#const OCI_DEFAULT)
!         handleSqlResult err res
!         setParams stmt err (index+1) (castPtr pValue:bindings) values
!     setParams stmt err index bindings (SqlDoubleValue    value : values) =
!       alloca $ \pBind -> do
!         pValue <- malloc
!         poke pValue value
!         res <- ociBindByPos stmt pBind err (index+1) pValue (fromIntegral (sizeOf value)) (#const SQLT_FLT) nullPtr nullPtr nullPtr (#const OCI_DEFAULT) nullPtr (#const OCI_DEFAULT)
!         handleSqlResult err res
!         setParams stmt err (index+1) (castPtr pValue:bindings) values
! 
!     getFieldDefs err stmt counter buffer = do
!       res <- ociParamGet stmt (#const OCI_HTYPE_STMT) err ((#ptr FIELD_DEF, par) buffer) counter
!       if res == (#const OCI_SUCCESS)
!         then do field  <- getFieldDef err buffer
!                 fields <- getFieldDefs err stmt (counter+1) buffer
!                 return (field:fields)
!         else return []
! 
!     sqlType2Size :: FieldDef -> Int
!     sqlType2Size (_,tp,_) =
!       case tp of
!         SqlVarChar n   -> n+1
!         SqlNumeric p s -> p+s+3   -- The value precision plus optional positions for '.', '-' and
!                                   -- one position for the '\0' character at end of the string.
!         SqlInteger     -> 16 -- 12 digits are enough (maxBound :: Int) has 10 digits.
!                              -- in addition we may need one position for '-' and one
!                              -- for the '\0' character at end of the string.
!         SqlFloat       -> 100
!         SqlDate        -> 100
! 	SqlTime        -> 100
! 	SqlTimeTZ      -> 100
! 	SqlTimeStamp   -> 100
! 	SqlText        -> 100
! 	SqlUnknown _   -> 0
! 
!     definePositions stmt err buffer pos offset [] = return ()
!     definePositions stmt err buffer pos offset (field:fields) =
!       alloca $ \pDef -> do
!         let size = sqlType2Size field
!         poke (castPtr buffer `advancePtr` pos) (fromIntegral offset :: CInt)
!         ociDefineByPos stmt
!                        pDef
!                        err
!                        (fromIntegral pos+1)
!                        (buffer `plusPtr` (offset+sizeOf (undefined :: CShort)))
!                        (fromIntegral size)
!                        (#const SQLT_STR)
!                        (castPtr buffer `plusPtr` offset)
!                        nullPtr
!                        nullPtr
!                        (#const OCI_DEFAULT)
!         definePositions stmt err buffer (pos+1) (offset+size) fields
  
      mkSqlType :: (#type OCITypeCode) -> (#type ub2) -> (#type ub1) -> (#type ub1) -> SqlType
***************
*** 329,334 ****
      getColValue :: Ptr () -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
      getColValue buffer colNumber fieldDef f = do
!       offset <- peek (castPtr buffer `advancePtr` colNumber)
!       let valuePtr = castPtr buffer `plusPtr` fromIntegral (offset :: CInt)
!       valueLen <- strlen valuePtr
!       f fieldDef valuePtr (fromIntegral valueLen)
--- 397,406 ----
      getColValue :: Ptr () -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
      getColValue buffer colNumber fieldDef f = do
!       offset <- peek (castPtr buffer `advancePtr` colNumber) :: IO CInt
!       let nullIndPtr = castPtr buffer `plusPtr` (fromIntegral offset)
!           valuePtr   = castPtr buffer `plusPtr` (fromIntegral offset + sizeOf (undefined :: CShort))
!       nullInd  <- peek nullIndPtr :: IO CShort
!       if nullInd /= 0
!         then f fieldDef nullPtr 0
!         else do valueLen <- strlen valuePtr
!                 f fieldDef valuePtr (fromIntegral valueLen)