htoolkit-cvs — HToolkit CVS commit messages

[htoolkit-cvs] HSQL/SQLite/Database/HSQL SQLite.hsc,1.2,1.3

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

Update of /cvsroot/htoolkit/HSQL/SQLite/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/SQLite/Database/HSQL

Modified Files:
	SQLite.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: SQLite.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/SQLite/Database/HSQL/SQLite.hsc,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** SQLite.hsc	9 Jun 2005 12:16:34 -0000	1.2
--- SQLite.hsc	12 Dec 2005 15:21:56 -0000	1.3
***************
*** 145,158 ****
  			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples))
  
! 		getColValue pResult refIndex columns rows colNumber  (name,sqlType,nullable) f = do
  			index <- readMVar refIndex
  			when (index > rows) (throwDyn SqlNoData)
  			pStr <- peekElemOff pResult (columns*index+colNumber)
  			if pStr == nullPtr
! 			  then return Nothing
! 			  else do
! 				strLen <- strlen pStr
! 				mb_value <- f sqlType pStr (fromIntegral strLen)
! 				case mb_value of
! 					Just v   -> return (Just v)
! 					Nothing -> throwDyn (SqlBadTypeCast name sqlType)
--- 145,154 ----
  			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples))
  
! 		getColValue pResult refIndex columns rows colNumber fieldDef f = do
  			index <- readMVar refIndex
  			when (index > rows) (throwDyn SqlNoData)
  			pStr <- peekElemOff pResult (columns*index+colNumber)
  			if pStr == nullPtr
! 			  then f fieldDef pStr 0
! 			  else do strLen <- strlen pStr
! 				  f fieldDef pStr (fromIntegral strLen)

[htoolkit-cvs] HSQL/MSI/Database/HSQL MSI.hsc,1.3,1.4

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

Update of /cvsroot/htoolkit/HSQL/MSI/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/MSI/Database/HSQL

Modified Files:
	MSI.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: MSI.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/MSI/Database/HSQL/MSI.hsc,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** MSI.hsc	17 Jun 2005 14:32:54 -0000	1.3
--- MSI.hsc	12 Dec 2005 15:21:56 -0000	1.4
***************
*** 207,212 ****
                    return True
  
!     getColValue :: IORef MSIHANDLE -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
!     getColValue refRecord colNumber (name,sqlType,nullable) f =
        allocaBytes col_buffer_size $ \buffer ->
        alloca                      $ \plen -> do
--- 207,212 ----
                    return True
  
!     getColValue :: IORef MSIHANDLE -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
!     getColValue refRecord colNumber fieldDef f =
        allocaBytes col_buffer_size $ \buffer ->
        alloca                      $ \plen -> do
***************
*** 215,219 ****
          msiRecordGetString hRecord (fromIntegral colNumber+1) buffer plen >>= checkResult
          len <- peek plen
!         f sqlType buffer (fromIntegral len)
  
      closeStatement :: MSIHANDLE -> IORef MSIHANDLE -> IO ()
--- 215,219 ----
          msiRecordGetString hRecord (fromIntegral colNumber+1) buffer plen >>= checkResult
          len <- peek plen
!         f fieldDef buffer (fromIntegral len)
  
      closeStatement :: MSIHANDLE -> IORef MSIHANDLE -> IO ()

[htoolkit-cvs] HSQL/PostgreSQL Setup.lhs,1.1,1.2

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

Update of /cvsroot/htoolkit/HSQL/PostgreSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/PostgreSQL

Modified Files:
	Setup.lhs 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: Setup.lhs
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/PostgreSQL/Setup.lhs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Setup.lhs	17 Jun 2005 06:47:07 -0000	1.1
--- Setup.lhs	12 Dec 2005 15:21:56 -0000	1.2
***************
*** 22,27 ****
        try (removeFile "PostgreSQL.buildinfo")
        return emptyHookedBuildInfo
!     postConf :: [String] -> ConfigFlags -> LocalBuildInfo -> IO ExitCode
!     postConf args flags localbuildinfo = do
        mb_bi <- pqConfigBuildInfo (configVerbose flags)
        writeHookedBuildInfo "PostgreSQL.buildinfo" (Just (fromMaybe emptyBuildInfo mb_bi),[])
--- 22,27 ----
        try (removeFile "PostgreSQL.buildinfo")
        return emptyHookedBuildInfo
!     postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode
!     postConf args flags _ localbuildinfo = do
        mb_bi <- pqConfigBuildInfo (configVerbose flags)
        writeHookedBuildInfo "PostgreSQL.buildinfo" (Just (fromMaybe emptyBuildInfo mb_bi),[])

[htoolkit-cvs] HSQL/PostgreSQL/Database/HSQL PostgreSQL.hsc,1.1,1.2

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

Update of /cvsroot/htoolkit/HSQL/PostgreSQL/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/PostgreSQL/Database/HSQL

Modified Files:
	PostgreSQL.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: PostgreSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/PostgreSQL/Database/HSQL/PostgreSQL.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** PostgreSQL.hsc	17 Jun 2005 06:47:08 -0000	1.1
--- PostgreSQL.hsc	12 Dec 2005 15:21:56 -0000	1.2
***************
*** 209,213 ****
  			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples-1))
  
! 		getColValue :: PGresult -> MVar Int -> Int -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
  		getColValue pRes tupleIndex countTuples colNumber  (name,sqlType,nullable) f = do
  			index <- readMVar tupleIndex
--- 209,213 ----
  			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples-1))
  
! 		getColValue :: PGresult -> MVar Int -> Int -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
  		getColValue pRes tupleIndex countTuples colNumber  (name,sqlType,nullable) f = do
  			index <- readMVar tupleIndex
***************
*** 215,224 ****
  			isnull <- pqGetisnull pRes index colNumber
  			if isnull == 1
! 				then return Nothing
  				else do
  					pStr <- pqGetvalue pRes index colNumber
  					strLen <- strlen pStr
! 					mb_value <- f sqlType pStr strLen
! 					case mb_value of
! 						Just v   -> return (Just v)
! 						Nothing -> throwDyn (SqlBadTypeCast name sqlType)
--- 215,221 ----
  			isnull <- pqGetisnull pRes index colNumber
  			if isnull == 1
! 				then f sqlType nullPtr 0
  				else do
  					pStr <- pqGetvalue pRes index colNumber
  					strLen <- strlen pStr
! 					f sqlType pStr strLen

[htoolkit-cvs] HSQL/SQLite3/Database/HSQL SQLite3.hsc,1.1,1.2

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

Update of /cvsroot/htoolkit/HSQL/SQLite3/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/SQLite3/Database/HSQL

Modified Files:
	SQLite3.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: SQLite3.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/SQLite3/Database/HSQL/SQLite3.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** SQLite3.hsc	16 Jun 2005 19:27:09 -0000	1.1
--- SQLite3.hsc	12 Dec 2005 15:21:56 -0000	1.2
***************
*** 146,159 ****
  			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples))
  
! 		getColValue pResult refIndex columns rows colNumber  (name,sqlType,nullable) f = do
  			index <- readMVar refIndex
  			when (index > rows) (throwDyn SqlNoData)
  			pStr <- peekElemOff pResult (columns*index+colNumber)
  			if pStr == nullPtr
! 			  then return Nothing
! 			  else do
! 				strLen <- strlen pStr
! 				mb_value <- f sqlType pStr (fromIntegral strLen)
! 				case mb_value of
! 					Just v   -> return (Just v)
! 					Nothing -> throwDyn (SqlBadTypeCast name sqlType)
--- 146,155 ----
  			modifyMVar tupleIndex (\index -> return (index+1,index < countTuples))
  
! 		getColValue pResult refIndex columns rows colNumber fieldDef f = do
  			index <- readMVar refIndex
  			when (index > rows) (throwDyn SqlNoData)
  			pStr <- peekElemOff pResult (columns*index+colNumber)
  			if pStr == nullPtr
! 			  then f fieldDef pStr 0
! 			  else do strLen <- strlen pStr
! 				  f fieldDef pStr (fromIntegral strLen)

[htoolkit-cvs] HSQL/Oracle/Database/HSQL Oracle.hsc,1.4,1.5

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

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

Modified Files:
	Oracle.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: Oracle.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/Oracle.hsc,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Oracle.hsc	29 Oct 2005 12:16:38 -0000	1.4
--- Oracle.hsc	12 Dec 2005 15:21:56 -0000	1.5
***************
*** 260,267 ****
        return (res /= (#const OCI_NO_DATA))
  
!     getColValue :: Ptr () -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
!     getColValue buffer colNumber (name,sqlType,nullable) f = do
        (offset :: CInt) <- peek (castPtr buffer `advancePtr` colNumber)
        let valuePtr = castPtr buffer `plusPtr` fromIntegral offset      
        valueLen <- strlen valuePtr
!       f sqlType valuePtr (fromIntegral valueLen)
--- 260,267 ----
        return (res /= (#const OCI_NO_DATA))
  
!     getColValue :: Ptr () -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
!     getColValue buffer colNumber fieldDef f = do
        (offset :: CInt) <- peek (castPtr buffer `advancePtr` colNumber)
        let valuePtr = castPtr buffer `plusPtr` fromIntegral offset      
        valueLen <- strlen valuePtr
!       f fieldDef valuePtr (fromIntegral valueLen)

[htoolkit-cvs] HSQL/HSQL/Database/HSQL Types.hs,1.2,1.3

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

Update of /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/HSQL/Database/HSQL

Modified Files:
	Types.hs 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL/Types.hs,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Types.hs	14 Jun 2005 09:38:47 -0000	1.2
--- Types.hs	12 Dec 2005 15:21:55 -0000	1.3
***************
*** 3,7 ****
--- 3,9 ----
  
  import Control.Concurrent.MVar
+ import Control.Exception
  import Data.Dynamic
+ import Foreign
  import Foreign.C
  
***************
*** 130,134 ****
  		, stmtClose  :: IO ()
  		, stmtFetch  :: IO Bool
! 		, stmtGetCol :: forall a . Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
  		, stmtFields :: [FieldDef]
  		, stmtClosed :: MVar Bool
--- 132,136 ----
  		, stmtClose  :: IO ()
  		, stmtFetch  :: IO Bool
! 		, stmtGetCol :: forall a . Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
  		, stmtFields :: [FieldDef]
  		, stmtClosed :: MVar Bool
***************
*** 139,146 ****
  	-- This allows for faster conversion for eq. integral numeric types, etc.
  	-- Default version uses fromSqlValue.
! 	fromNonNullSqlCStringLen :: SqlType -> CString -> Int -> IO (Maybe a)
! 	fromNonNullSqlCStringLen sqlType cstr cstrLen = do
! 	    str <- peekCStringLen (cstr, cstrLen)
! 	    return (fromSqlValue sqlType str)
  
  	fromSqlValue :: SqlType -> String -> Maybe a
--- 141,152 ----
  	-- This allows for faster conversion for eq. integral numeric types, etc.
  	-- Default version uses fromSqlValue.
! 	fromSqlCStringLen :: FieldDef -> CString -> Int -> IO a
! 	fromSqlCStringLen (name,sqlType,_) cstr cstrLen
! 	  | cstr == nullPtr = throwDyn (SqlFetchNull name)
! 	  | otherwise       = do 
! 	      str <- peekCStringLen (cstr, cstrLen)
! 	      case fromSqlValue sqlType str of
! 	        Nothing -> throwDyn (SqlBadTypeCast name sqlType)
! 	        Just v  -> return v
  
  	fromSqlValue :: SqlType -> String -> Maybe a

[htoolkit-cvs] HSQL/ODBC/Database/HSQL ODBC.hsc,1.4,1.5

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

Update of /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/ODBC/Database/HSQL

Modified Files:
	ODBC.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: ODBC.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL/ODBC.hsc,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** ODBC.hsc	12 Oct 2005 14:30:05 -0000	1.4
--- ODBC.hsc	12 Dec 2005 15:21:56 -0000	1.5
***************
*** 311,315 ****
  			-- Column name     #   Type
  			-- TABLE_NAME      3   VARCHAR
! 			collectRows (\s -> getFieldValue  s 3 ("TABLE_NAME", SqlVarChar 0, False) "") stmt
  			where sqlTables' hSTMT = sqlTables hSTMT nullPtr 0 nullPtr 0 nullPtr 0 nullPtr 0
  
--- 311,315 ----
  			-- Column name     #   Type
  			-- TABLE_NAME      3   VARCHAR
! 			collectRows (\s -> getFieldValue s "TABLE_NAME") stmt
  			where sqlTables' hSTMT = sqlTables hSTMT nullPtr 0 nullPtr 0 nullPtr 0 nullPtr 0
  
***************
*** 320,325 ****
  			where
  				sqlColumns' table hSTMT =
! 					withCStringLen table (\(pTable,len) ->
! 						sqlColumns hSTMT nullPtr 0 nullPtr 0 pTable (fromIntegral len) nullPtr 0)
  					-- SQLColumns returns (column names may vary):
  					-- Column name     #   Type
--- 320,325 ----
  			where
  				sqlColumns' table hSTMT =
! 				  withCStringLen table (\(pTable,len) ->
! 				        sqlColumns hSTMT nullPtr 0 nullPtr 0 pTable (fromIntegral len) nullPtr 0)
  					-- SQLColumns returns (column names may vary):
  					-- Column name     #   Type
***************
*** 331,345 ****
  
  				getColumnInfo stmt = do
! 					column_name <- getFieldValue stmt 4 ("COLUMN_NAME", SqlVarChar 0, False) ""
! 					(data_type::Int) <- getFieldValue stmt 5 ("DATA_TYPE", SqlSmallInt, False) 0
! 					(column_size::Int) <- getFieldValue stmt 7 ("COLUMN_SIZE", SqlInteger, True) 0
! 					(decimal_digits::Int) <- getFieldValue stmt 9 ("DECIMAL_DIGITS", SqlSmallInt, True) 0
! 					(nullable::Int) <- getFieldValue stmt 11 ("NULLABLE", SqlSmallInt, False) 0
! 					let sqlType = mkSqlType (fromIntegral data_type) (fromIntegral column_size) (fromIntegral decimal_digits)
! 					return (column_name, sqlType, toBool nullable)
! 
! 		getFieldValue stmt colNumber fieldDef v = do
! 			mb_v <- stmtGetCol stmt (colNumber-1) fieldDef fromNonNullSqlCStringLen
! 			return (case mb_v of { Nothing -> v; Just a -> a })
  
  		fetch :: HSTMT -> IO Bool
--- 331,341 ----
  
  				getColumnInfo stmt = do
! 				  column_name <- getFieldValue stmt "COLUMN_NAME"
! 				  (data_type::Int) <- getFieldValue stmt "DATA_TYPE"
! 				  (column_size::Int) <- getFieldValue' stmt "COLUMN_SIZE" 0
! 				  (decimal_digits::Int) <- getFieldValue' stmt "DECIMAL_DIGITS" 0
! 				  (nullable::Int) <- getFieldValue stmt "NULLABLE"
! 				  let sqlType = mkSqlType (fromIntegral data_type) (fromIntegral column_size) (fromIntegral decimal_digits)
! 				  return (column_name, sqlType, toBool nullable)
  
  		fetch :: HSTMT -> IO Bool
***************
*** 349,364 ****
  			return (res /= (#const SQL_NO_DATA))
  
! 		getColValue :: HSTMT -> CString -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
! 		getColValue hSTMT buffer colNumber (name,sqlType,nullable) f = do
  			(res,len_or_ind) <- getData buffer (fromIntegral stmtBufferSize)
  			if len_or_ind == (#const SQL_NULL_DATA)
! 			  then return Nothing
! 			  else do
! 				mb_value <- (if res == (#const SQL_SUCCESS_WITH_INFO)
! 				                      then getLongData len_or_ind
! 				                      else f sqlType buffer (fromIntegral len_or_ind))
! 				case mb_value of
! 					Just value -> return (Just value)
! 					Nothing    -> throwDyn (SqlBadTypeCast name sqlType)
  			where
  				getData :: CString -> SQLINTEGER -> IO (SQLRETURN, SQLINTEGER)
--- 345,356 ----
  			return (res /= (#const SQL_NO_DATA))
  
! 		getColValue :: HSTMT -> CString -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
! 		getColValue hSTMT buffer colNumber fieldDef f = do
  			(res,len_or_ind) <- getData buffer (fromIntegral stmtBufferSize)
  			if len_or_ind == (#const SQL_NULL_DATA)
! 			  then f fieldDef nullPtr 0
! 			  else if res == (#const SQL_SUCCESS_WITH_INFO)
! 				 then getLongData len_or_ind
! 				 else f fieldDef buffer (fromIntegral len_or_ind)
  			where
  				getData :: CString -> SQLINTEGER -> IO (SQLRETURN, SQLINTEGER)
***************
*** 382,386 ****
  					    newDataLen = newBufSize - (fromIntegral stmtBufferSize - 1)
  					(res,_) <- getData newDataStart newDataLen
! 					f sqlType newBuf (fromIntegral newBufSize-1)
  					where
  						newBufSize = len+1 -- to allow for terminating null character
--- 374,378 ----
  					    newDataLen = newBufSize - (fromIntegral stmtBufferSize - 1)
  					(res,_) <- getData newDataStart newDataLen
! 					f fieldDef newBuf (fromIntegral newBufSize-1)
  					where
  						newBufSize = len+1 -- to allow for terminating null character

[htoolkit-cvs] HSQL/MySQL/Database/HSQL MySQL.hsc,1.1,1.2

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

Update of /cvsroot/htoolkit/HSQL/MySQL/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/MySQL/Database/HSQL

Modified Files:
	MySQL.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: MySQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/MySQL/Database/HSQL/MySQL.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** MySQL.hsc	17 Jun 2005 08:43:51 -0000	1.1
--- MySQL.hsc	12 Dec 2005 15:21:56 -0000	1.2
***************
*** 201,216 ****
  				return ((pRow, pLengths), pRow /= nullPtr)
  
! 		getColValue :: MVar (MYSQL_ROW, MYSQL_LENGTHS) -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
! 		getColValue currRow colNumber (name,sqlType,nullable) f = do
  			(row, lengths) <- readMVar currRow
  			pValue <- peekElemOff row colNumber
  			len <- fmap fromIntegral (peekElemOff lengths colNumber)
! 			if pValue == nullPtr
! 			  then return Nothing
! 			  else do
! 				mv <- f sqlType pValue len
! 				case mv of
! 					Just v  -> return (Just v)
! 					Nothing -> throwDyn (SqlBadTypeCast name sqlType)
  
  		tables :: Connection -> MYSQL -> IO [String]
--- 201,210 ----
  				return ((pRow, pLengths), pRow /= nullPtr)
  
! 		getColValue :: MVar (MYSQL_ROW, MYSQL_LENGTHS) -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
! 		getColValue currRow colNumber fieldDef f = do
  			(row, lengths) <- readMVar currRow
  			pValue <- peekElemOff row colNumber
  			len <- fmap fromIntegral (peekElemOff lengths colNumber)
! 			f fieldDef pValue len
  
  		tables :: Connection -> MYSQL -> IO [String]

[htoolkit-cvs] HSQL/HSQL/Database HSQL.hsc,1.2,1.3

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

Update of /cvsroot/htoolkit/HSQL/HSQL/Database
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7000/HSQL/Database

Modified Files:
	HSQL.hsc 
Log Message:
Another way to handle null values in HSQL. Not tested yet.


Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL.hsc,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** HSQL.hsc	14 Jun 2005 09:39:56 -0000	1.2
--- HSQL.hsc	12 Dec 2005 15:21:55 -0000	1.3
***************
*** 29,33 ****
  	-- * Retrieving Statement values and types
  	, FieldDef, SqlType(..), SqlBind, toSqlValue
- 	, getFieldValueMB   -- :: SqlBind a => Statement -> String -> IO (Maybe a)
  	, getFieldValue     -- :: SqlBind a => Statement -> String -> IO a
  	, getFieldValue'    -- :: SqlBind a => Statement -> String -> a -> IO a
--- 29,32 ----
***************
*** 194,243 ****
  #endif
  
  instance SqlBind Int where
! 	fromNonNullSqlCStringLen sqlType cstr cstrLen = do
! 	    if sqlType==SqlInteger || sqlType==SqlMedInt 
! 	       || sqlType==SqlTinyInt || sqlType==SqlSmallInt
! 	       || sqlType==SqlBigInt
! 		then do
! 		    val <- c_atoi cstr
! 		    return (Just val)
! 		else
! 		    return Nothing
  
! 	fromSqlValue SqlInteger  s = Just (read s)
! 	fromSqlValue SqlMedInt s   = Just (read s)
! 	fromSqlValue SqlTinyInt s  = Just (read s)
! 	fromSqlValue SqlSmallInt s = Just (read s)
! 	fromSqlValue SqlBigInt s = Just (read s)
! 	fromSqlValue SqlDouble s = Just (truncate (read s :: Double))
! 	fromSqlValue SqlText   s = Just (read s)
! 	fromSqlValue _ _           = Nothing
  
! 	toSqlValue s = show s
  
  instance SqlBind Int64 where
! 	fromNonNullSqlCStringLen sqlType cstr cstrLen = do
! 	    if sqlType==SqlInteger || sqlType==SqlMedInt 
! 	       || sqlType==SqlTinyInt || sqlType==SqlSmallInt || sqlType==SqlBigInt
! 	      then do
  #ifdef mingw32_TARGET_OS
! 	        val <- c_atoi64 cstr
  #else
! 	        val <- c_strtoll cstr nullPtr 10
  #endif
! 	        return (Just val)
! 	      else
! 	        return Nothing
  
! 	fromSqlValue SqlInteger s = Just (read s)
! 	fromSqlValue SqlMedInt s   = Just (read s)
! 	fromSqlValue SqlTinyInt s  = Just (read s)
! 	fromSqlValue SqlSmallInt s = Just (read s)
! 	fromSqlValue SqlBigInt s = Just (read s)
! 	fromSqlValue SqlDouble s = Just (truncate (read s :: Double))
! 	fromSqlValue SqlText   s = Just (read s)
! 	fromSqlValue _ s = Nothing
  
! 	toSqlValue val = show val
  
  instance SqlBind Integer where
--- 193,254 ----
  #endif
  
+ instance SqlBind a => SqlBind (Maybe a) where
+   fromSqlCStringLen fieldDef cstr cstrLen
+     | cstr == nullPtr = return Nothing
+     | otherwise       = do v <- fromSqlCStringLen fieldDef cstr cstrLen
+                            return (Just v)
+                            
+   fromSqlValue tp "null" = Nothing
+   fromSqlValue tp s      = fromSqlValue tp s
+ 
+   toSqlValue (Just v) = toSqlValue v
+   toSqlValue Nothing  = "null"
+ 
  instance SqlBind Int where
!   fromSqlCStringLen (name,sqlType,_) cstr cstrLen
!     | cstr == nullPtr        = throwDyn (SqlFetchNull name)
!     | sqlType==SqlInteger || 
!       sqlType==SqlMedInt  ||
!       sqlType==SqlTinyInt ||
!       sqlType==SqlSmallInt||
!       sqlType==SqlBigInt     = c_atoi cstr
!     | otherwise              = throwDyn (SqlBadTypeCast name sqlType)
  
!   fromSqlValue SqlInteger  s = Just (read s)
!   fromSqlValue SqlMedInt   s = Just (read s)
!   fromSqlValue SqlTinyInt  s = Just (read s)
!   fromSqlValue SqlSmallInt s = Just (read s)
!   fromSqlValue SqlBigInt   s = Just (read s)
!   fromSqlValue SqlDouble   s = Just (truncate (read s :: Double))
!   fromSqlValue SqlText     s = Just (read s)
!   fromSqlValue _ _           = Nothing
  
!   toSqlValue s = show s
  
  instance SqlBind Int64 where
!   fromSqlCStringLen (name,sqlType,_) cstr cstrLen
!     | cstr == nullPtr        = throwDyn (SqlFetchNull name)
!     | sqlType==SqlInteger ||
!       sqlType==SqlMedInt  ||
!       sqlType==SqlTinyInt ||
!       sqlType==SqlSmallInt||
!       sqlType==SqlBigInt     =
  #ifdef mingw32_TARGET_OS
! 	                       c_atoi64 cstr
  #else
! 	                       c_strtoll cstr nullPtr 10
  #endif
!     | otherwise              = throwDyn (SqlBadTypeCast name sqlType)
  
!   fromSqlValue SqlInteger s = Just (read s)
!   fromSqlValue SqlMedInt s   = Just (read s)
!   fromSqlValue SqlTinyInt s  = Just (read s)
!   fromSqlValue SqlSmallInt s = Just (read s)
!   fromSqlValue SqlBigInt s = Just (read s)
!   fromSqlValue SqlDouble s = Just (truncate (read s :: Double))
!   fromSqlValue SqlText   s = Just (read s)
!   fromSqlValue _ s = Nothing
  
!   toSqlValue val = show val
  
  instance SqlBind Integer where
***************
*** 530,559 ****
  
  -- | Retrieves the value of field with the specified name.
- -- The returned value is Nothing if the field value is @null@.
- getFieldValueMB :: SqlBind a => Statement
-                              -> String         -- ^ Field name
-                              -> IO (Maybe a)   -- ^ Field value or Nothing
- getFieldValueMB stmt name = checkHandle (stmtClosed stmt) $
- 	stmtGetCol stmt colNumber (name,sqlType,nullable) fromCStr
- 	where
- 		(sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0
-                 fromCStr t c l = do m <- fromNonNullSqlCStringLen t c l
-                                     case m of
-                                            Just _ -> return m
-                                            Nothing ->
-                                                do str <- peekCStringLen (c, l)
-                                                   return (fromSqlValue t str)
- 
- 
- -- | Retrieves the value of field with the specified name.
- -- If the field value is @null@ then the function will throw 'SqlFetchNull' exception.
  getFieldValue :: SqlBind a => Statement
                             -> String       -- ^ Field name
                             -> IO a         -- ^ Field value
  getFieldValue stmt name = do
! 	mb_v <- getFieldValueMB stmt name
! 	case mb_v of
! 		Nothing -> throwDyn (SqlFetchNull name)
! 		Just a  -> return a
  
  -- | Retrieves the value of field with the specified name.
--- 541,551 ----
  
  -- | Retrieves the value of field with the specified name.
  getFieldValue :: SqlBind a => Statement
                             -> String       -- ^ Field name
                             -> IO a         -- ^ Field value
  getFieldValue stmt name = do
!   stmtGetCol stmt colNumber (name,sqlType,nullable) fromSqlCStringLen
!   where
!     (sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0
  
  -- | Retrieves the value of field with the specified name.
***************
*** 564,569 ****
                              -> IO a       -- ^ Field value
  getFieldValue' stmt name def = do
! 	mb_v <- getFieldValueMB stmt name
! 	return (case mb_v of { Nothing -> def; Just a -> a })
  
  
--- 556,561 ----
                              -> IO a       -- ^ Field value
  getFieldValue' stmt name def = do
!   mb_v <- getFieldValue stmt name
!   return (case mb_v of { Nothing -> def; Just a -> a })
  
  

[htoolkit-cvs] HSQL/Oracle/Database/HSQL Oracle.hsc,1.3,1.4

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

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

Modified Files:
	Oracle.hsc 
Log Message:
The query/fetch/getFieldValue functions seems to work


Index: Oracle.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/Oracle.hsc,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** Oracle.hsc	18 Oct 2005 11:43:28 -0000	1.3
--- Oracle.hsc	29 Oct 2005 12:16:38 -0000	1.4
***************
*** 32,35 ****
--- 32,36 ----
  type OCIStmt   = OCIHandle
  type OCIParam  = OCIHandle
+ type OCIDefine = OCIHandle
  
  type OCIEnvRef = ForeignPtr ()
***************
*** 47,50 ****
--- 48,52 ----
  foreign import ccall "OCIStmtExecute" ociStmtExecute :: OCISvcCtx -> OCIStmt -> OCIError -> CInt -> CInt -> OCIHandle -> OCIHandle -> CInt -> IO CInt
  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 "OCIParamGet" ociParamGet :: OCIStmt -> CInt -> OCIError -> Ptr OCIParam -> CInt -> IO CInt
***************
*** 57,60 ****
--- 59,64 ----
  foreign import ccall "OCITransRollback" ociTransRollback :: OCISvcCtx -> OCIError -> CInt -> IO CInt
  
+ foreign import ccall "strlen" strlen :: CString -> IO CInt
+ 
  -----------------------------------------------------------------------------------------
  -- keeper of OCIEnv
***************
*** 156,161 ****
  	ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
  	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs stmt 1)
! 	buffer <- mallocBytes (fetchBufferSize fields)
! 	definePositions buffer fields
  	refFalse <- newMVar False
          let statement = Statement
--- 160,166 ----
  	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 :: CInt = fromIntegral (length fields * sizeOf offsets_arr_size)
! 	buffer <- mallocBytes (fromIntegral (foldr ((+) . sqlType2Size) offsets_arr_size fields))
! 	definePositions stmt err buffer 0 offsets_arr_size fields
  	refFalse <- newMVar False
          let statement = Statement
***************
*** 163,167 ****
  		, stmtClose  = closeStatement stmt buffer err
  		, stmtFetch  = fetch stmt err
! 		, stmtGetCol = getColValue stmt buffer
  		, stmtFields = fields
  		, stmtClosed = refFalse
--- 168,172 ----
  		, stmtClose  = closeStatement stmt buffer err
  		, stmtFetch  = fetch stmt err
! 		, stmtGetCol = getColValue buffer
  		, stmtFields = fields
  		, stmtClosed = refFalse
***************
*** 194,225 ****
              colName <- peekCStringLen (pColName, fromIntegral colNameLen)
              ociDescriptorFree par (#const OCI_DTYPE_PARAM)
-             print (dtype,dsize,dprec,dscale)
              return (colName,mkSqlType dtype dsize dprec dscale,toBool (fromIntegral isNull))
  
!           fetchBufferSize []                = 0
!           fetchBufferSize ((_,tp,_):fields) = undefined + fetchBufferSize fields
!           
!           definePositions buffer [] = return ()
!           definePositions buffer (field:fields) = do
!             undefined
!             definePositions buffer fields
  
      mkSqlType :: (#type OCITypeCode) -> (#type ub2) -> (#type ub1) -> (#type ub1) -> SqlType
!     mkSqlType (#const OCI_TYPECODE_CHAR)         size _    _     = SqlChar    (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_VARCHAR)      size _    _     = SqlVarChar (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_VARCHAR2)     size _    _     = SqlVarChar (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_DECIMAL)      _    prec scale = SqlDecimal (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const OCI_TYPECODE_NUMBER)       _    prec scale = SqlNumeric (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const OCI_TYPECODE_SMALLINT)     _    _    _     = SqlSmallInt
!     mkSqlType (#const OCI_TYPECODE_INTEGER)      _    _    _     = SqlInteger
!     mkSqlType (#const OCI_TYPECODE_REAL)         _    _    _     = SqlReal
!     mkSqlType (#const OCI_TYPECODE_FLOAT)        _    _    _     = SqlFloat
!     mkSqlType (#const OCI_TYPECODE_DOUBLE)       _    _    _     = SqlDouble
!     mkSqlType (#const OCI_TYPECODE_DATE)         _    _    _     = SqlDate
!     mkSqlType (#const OCI_TYPECODE_TIME)         _    _    _     = SqlTime
!     mkSqlType (#const OCI_TYPECODE_TIME_TZ)      _    _    _     = SqlTimeTZ
!     mkSqlType (#const OCI_TYPECODE_TIMESTAMP)    _    _    _     = SqlTimeStamp
!     mkSqlType (#const SQLT_LNG)                  _    _    _     = SqlText
!     mkSqlType tp                                 _    _    _     = SqlUnknown (fromIntegral tp)
  
      tables connection svcCtx = undefined
--- 199,241 ----
              colName <- peekCStringLen (pColName, fromIntegral colNameLen)
              ociDescriptorFree par (#const OCI_DTYPE_PARAM)
              return (colName,mkSqlType dtype dsize dprec dscale,toBool (fromIntegral isNull))
  
!           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
!     mkSqlType (#const SQLT_CHR)       size _    _     = SqlVarChar (fromIntegral size)
!   --  mkSqlType (#const SQLT_STR)       size _    _     = SqlVarChar (fromIntegral size)
!     mkSqlType (#const SQLT_NUM)       _    prec scale = SqlNumeric (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const SQLT_INT)       _    _    _     = SqlInteger
!     mkSqlType (#const SQLT_FLT)       _    _    _     = SqlFloat
!     mkSqlType (#const SQLT_DATE)      _    _    _     = SqlDate
!     mkSqlType (#const SQLT_TIME)      _    _    _     = SqlTime
!     mkSqlType (#const SQLT_TIME_TZ)   _    _    _     = SqlTimeTZ
!     mkSqlType (#const SQLT_TIMESTAMP) _    _    _     = SqlTimeStamp
!     mkSqlType (#const SQLT_LNG)       _    _    _     = SqlText
!     mkSqlType tp                      _    _    _     = SqlUnknown (fromIntegral tp)
  
      tables connection svcCtx = undefined
***************
*** 244,246 ****
        return (res /= (#const OCI_NO_DATA))
  
!     getColValue stmt buffer = undefined
--- 260,267 ----
        return (res /= (#const OCI_NO_DATA))
  
!     getColValue :: Ptr () -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a)
!     getColValue buffer colNumber (name,sqlType,nullable) f = do
!       (offset :: CInt) <- peek (castPtr buffer `advancePtr` colNumber)
!       let valuePtr = castPtr buffer `plusPtr` fromIntegral offset      
!       valueLen <- strlen valuePtr
!       f sqlType valuePtr (fromIntegral valueLen)

[htoolkit-cvs] HSQL/Oracle/Database/HSQL HsOCI.h,1.2,1.3 Oracle.hsc,1.2,1.3

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

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

Modified Files:
	HsOCI.h Oracle.hsc 
Log Message:
closeStatement/fetch/startTransaction/commitTransaction/rollbackTransaction are added.


Index: HsOCI.h
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/HsOCI.h,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** HsOCI.h	12 Oct 2005 15:01:44 -0000	1.2
--- HsOCI.h	18 Oct 2005 11:43:28 -0000	1.3
***************
*** 10,13 ****
--- 10,14 ----
    ub1 dprec;
    ub1 dscale;
+   ub1 isNull;
    ub4 colNameLen;
    char *colName;

Index: Oracle.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/Oracle.hsc,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Oracle.hsc	12 Oct 2005 15:01:44 -0000	1.2
--- Oracle.hsc	18 Oct 2005 11:43:28 -0000	1.3
***************
*** 46,49 ****
--- 46,50 ----
  foreign import ccall "OCIStmtPrepare" ociStmtPrepare :: OCIStmt -> OCIError -> CString -> CInt -> CInt -> CInt -> IO CInt
  foreign import ccall "OCIStmtExecute" ociStmtExecute :: OCISvcCtx -> OCIStmt -> OCIError -> CInt -> CInt -> OCIHandle -> OCIHandle -> CInt -> IO CInt
+ foreign import ccall "OCIStmtFetch2" ociStmtFetch2 :: OCIStmt -> OCIError -> CInt -> CInt -> CInt -> CInt -> IO CInt
  
  foreign import ccall "OCIParamGet" ociParamGet :: OCIStmt -> CInt -> OCIError -> Ptr OCIParam -> CInt -> IO CInt
***************
*** 52,55 ****
--- 53,60 ----
  foreign import ccall "OCIDescriptorFree" ociDescriptorFree :: OCIHandle -> CInt -> IO CInt
  
+ foreign import ccall "OCITransStart" ociTransStart :: OCISvcCtx -> OCIError -> Word8 -> CInt -> IO CInt
+ foreign import ccall "OCITransCommit" ociTransCommit :: OCISvcCtx -> OCIError -> CInt -> IO CInt
+ foreign import ccall "OCITransRollback" ociTransRollback :: OCISvcCtx -> OCIError -> CInt -> IO CInt
+ 
  -----------------------------------------------------------------------------------------
  -- keeper of OCIEnv
***************
*** 121,127 ****
      			, connTables     = tables connection svcCtx
      			, connDescribe   = describe connection svcCtx
!     			, connBeginTransaction = beginTransaction myEnvironment svcCtx
!     			, connCommitTransaction = commitTransaction myEnvironment svcCtx
!     			, connRollbackTransaction = rollbackTransaction myEnvironment svcCtx
      			, connClosed     = refFalse
      			})
--- 126,132 ----
      			, connTables     = tables connection svcCtx
      			, connDescribe   = describe connection svcCtx
!     			, connBeginTransaction = beginTransaction myEnvironment svcCtx err
!     			, connCommitTransaction = commitTransaction myEnvironment svcCtx err 
!     			, connRollbackTransaction = rollbackTransaction myEnvironment svcCtx err
      			, connClosed     = refFalse
      			})
***************
*** 139,143 ****
          stmt <- peek pStmt
          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
          ociHandleFree stmt (#const OCI_HTYPE_STMT) >>= handleSqlResult err
  
--- 144,148 ----
          stmt <- peek pStmt
          ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult err
!         ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
          ociHandleFree stmt (#const OCI_HTYPE_STMT) >>= handleSqlResult err
  
***************
*** 151,160 ****
  	ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
  	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs stmt 1)
  	refFalse <- newMVar False
          let statement = Statement
  		{ stmtConn   = connection
! 		, stmtClose  = closeStatement stmt
! 		, stmtFetch  = fetch stmt
! 		, stmtGetCol = getColValue stmt
  		, stmtFields = fields
  		, stmtClosed = refFalse
--- 156,167 ----
  	ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
  	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs stmt 1)
+ 	buffer <- mallocBytes (fetchBufferSize fields)
+ 	definePositions buffer fields
  	refFalse <- newMVar False
          let statement = Statement
  		{ stmtConn   = connection
! 		, stmtClose  = closeStatement stmt buffer err
! 		, stmtFetch  = fetch stmt err
! 		, stmtGetCol = getColValue stmt buffer
  		, stmtFields = fields
  		, stmtClosed = refFalse
***************
*** 180,183 ****
--- 187,192 ----
              ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, dscale) buffer) nullPtr (#const OCI_ATTR_SCALE) err >>= handleSqlResult err
              dscale <- (#peek FIELD_DEF, dscale) buffer
+             ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, isNull) buffer) nullPtr (#const OCI_ATTR_IS_NULL) err >>= handleSqlResult err
+             (isNull :: (#type ub1)) <- (#peek FIELD_DEF, isNull) buffer
              ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, colName) buffer) ((#ptr FIELD_DEF, colNameLen) buffer) (#const OCI_ATTR_NAME) err >>= handleSqlResult err
              pColName <- (#peek FIELD_DEF, colName) buffer
***************
*** 186,212 ****
              ociDescriptorFree par (#const OCI_DTYPE_PARAM)
              print (dtype,dsize,dprec,dscale)
!             return (colName,mkSqlType dtype dsize dprec dscale,False)
  
      mkSqlType :: (#type OCITypeCode) -> (#type ub2) -> (#type ub1) -> (#type ub1) -> SqlType
!     mkSqlType (#const OCI_TYPECODE_CHAR)      size _    _     = SqlChar    (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_VARCHAR)   size _    _     = SqlVarChar (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_DECIMAL)   _    prec scale = SqlDecimal (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const OCI_TYPECODE_NUMBER)    _    prec scale = SqlNumeric (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const OCI_TYPECODE_SMALLINT)  _    _    _     = SqlSmallInt
!     mkSqlType (#const OCI_TYPECODE_INTEGER)   _    _    _     = SqlInteger
!     mkSqlType (#const OCI_TYPECODE_FLOAT)     _    _    _     = SqlFloat
!     mkSqlType (#const OCI_TYPECODE_DATE)      _    _    _     = SqlDate
!     mkSqlType (#const OCI_TYPECODE_TIME)      _    _    _     = SqlTime
!     mkSqlType (#const OCI_TYPECODE_TIMESTAMP) _    _    _     = SqlTimeStamp
!     mkSqlType (#const SQLT_LNG)               _    _    _     = SqlText
!     mkSqlType tp                              _    _    _     = SqlUnknown (fromIntegral tp)
  
      tables connection svcCtx = undefined
      describe connection svcCtx = undefined
-     beginTransaction myEnvironment svcCtx = undefined
-     commitTransaction myEnvironment svcCtx = undefined
-     rollbackTransaction myEnvironment svcCtx = undefined
      
!     closeStatement stmt = undefined
!     fetch stmt = undefined
!     getColValue stmt = undefined
--- 195,246 ----
              ociDescriptorFree par (#const OCI_DTYPE_PARAM)
              print (dtype,dsize,dprec,dscale)
!             return (colName,mkSqlType dtype dsize dprec dscale,toBool (fromIntegral isNull))
! 
!           fetchBufferSize []                = 0
!           fetchBufferSize ((_,tp,_):fields) = undefined + fetchBufferSize fields
!           
!           definePositions buffer [] = return ()
!           definePositions buffer (field:fields) = do
!             undefined
!             definePositions buffer fields
  
      mkSqlType :: (#type OCITypeCode) -> (#type ub2) -> (#type ub1) -> (#type ub1) -> SqlType
!     mkSqlType (#const OCI_TYPECODE_CHAR)         size _    _     = SqlChar    (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_VARCHAR)      size _    _     = SqlVarChar (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_VARCHAR2)     size _    _     = SqlVarChar (fromIntegral size)
!     mkSqlType (#const OCI_TYPECODE_DECIMAL)      _    prec scale = SqlDecimal (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const OCI_TYPECODE_NUMBER)       _    prec scale = SqlNumeric (fromIntegral prec) (fromIntegral scale)
!     mkSqlType (#const OCI_TYPECODE_SMALLINT)     _    _    _     = SqlSmallInt
!     mkSqlType (#const OCI_TYPECODE_INTEGER)      _    _    _     = SqlInteger
!     mkSqlType (#const OCI_TYPECODE_REAL)         _    _    _     = SqlReal
!     mkSqlType (#const OCI_TYPECODE_FLOAT)        _    _    _     = SqlFloat
!     mkSqlType (#const OCI_TYPECODE_DOUBLE)       _    _    _     = SqlDouble
!     mkSqlType (#const OCI_TYPECODE_DATE)         _    _    _     = SqlDate
!     mkSqlType (#const OCI_TYPECODE_TIME)         _    _    _     = SqlTime
!     mkSqlType (#const OCI_TYPECODE_TIME_TZ)      _    _    _     = SqlTimeTZ
!     mkSqlType (#const OCI_TYPECODE_TIMESTAMP)    _    _    _     = SqlTimeStamp
!     mkSqlType (#const SQLT_LNG)                  _    _    _     = SqlText
!     mkSqlType tp                                 _    _    _     = SqlUnknown (fromIntegral tp)
  
      tables connection svcCtx = undefined
      describe connection svcCtx = undefined
      
!     beginTransaction myEnvironment svcCtx err =
!       ociTransStart svcCtx err 0 (#const OCI_TRANS_READWRITE) >>= handleSqlResult err
!     
!     commitTransaction myEnvironment svcCtx err =
!       ociTransCommit svcCtx err (#const OCI_DEFAULT) >>= handleSqlResult err
!     
!     rollbackTransaction myEnvironment svcCtx err = do
!       ociTransRollback svcCtx err (#const OCI_DEFAULT) >>= handleSqlResult err
! 
!     closeStatement stmt buffer err = do
!       ociHandleFree stmt (#const OCI_HTYPE_STMT) >>= handleSqlResult err
!       free buffer
! 
!     fetch stmt err = do
!       res <- ociStmtFetch2 stmt err 1 (#const OCI_FETCH_NEXT) 0 (#const OCI_DEFAULT)
!       handleSqlResult err res
!       return (res /= (#const OCI_NO_DATA))
! 
!     getColValue stmt buffer = undefined

[htoolkit-cvs] HSQL/Oracle/Database/HSQL HsOCI.h,1.1,1.2 Oracle.hsc,1.1,1.2

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

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

Modified Files:
	HsOCI.h Oracle.hsc 
Log Message:
more work on Oracle backen


Index: HsOCI.h
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/HsOCI.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HsOCI.h	15 Sep 2005 12:57:10 -0000	1.1
--- HsOCI.h	12 Oct 2005 15:01:44 -0000	1.2
***************
*** 3,5 ****
--- 3,16 ----
  #include <oci.h>
  
+ typedef struct
+ {
+   OCIParam *par;
+   OCITypeCode dtype;
+   ub2 dsize;
+   ub1 dprec;
+   ub1 dscale;
+   ub4 colNameLen;
+   char *colName;
+ } FIELD_DEF;
+ 
  #undef _int64

Index: Oracle.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL/Oracle.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Oracle.hsc	15 Sep 2005 12:57:10 -0000	1.1
--- Oracle.hsc	12 Oct 2005 15:01:44 -0000	1.2
***************
*** 22,25 ****
--- 22,26 ----
  import Foreign.Concurrent as FC
  import Control.Concurrent.MVar
+ import Control.Exception(throwDyn)
  
  #include <HsOCI.h>
***************
*** 30,33 ****
--- 31,35 ----
  type OCISvcCtx = OCIHandle
  type OCIStmt   = OCIHandle
+ type OCIParam  = OCIHandle
  
  type OCIEnvRef = ForeignPtr ()
***************
*** 45,48 ****
--- 47,55 ----
  foreign import ccall "OCIStmtExecute" ociStmtExecute :: OCISvcCtx -> OCIStmt -> OCIError -> CInt -> CInt -> OCIHandle -> OCIHandle -> CInt -> IO CInt
  
+ foreign import ccall "OCIParamGet" ociParamGet :: OCIStmt -> CInt -> OCIError -> Ptr OCIParam -> CInt -> IO CInt
+ foreign import ccall "OCIAttrGet" ociAttrGet :: OCIParam -> CInt -> Ptr a -> Ptr CInt -> CInt -> OCIError -> IO CInt
+ 
+ foreign import ccall "OCIDescriptorFree" ociDescriptorFree :: OCIHandle -> CInt -> IO CInt
+ 
  -----------------------------------------------------------------------------------------
  -- keeper of OCIEnv
***************
*** 52,74 ****
  myEnvironment :: OCIEnvRef
  myEnvironment = unsafePerformIO $ alloca $ \ (pOCIEnv :: Ptr OCIEnv) -> do
!   ociEnvCreate pOCIEnv (#const OCI_DEFAULT) nullPtr nullFunPtr nullFunPtr nullFunPtr 0 nullPtr >>= handleSqlResult
    env <- peek pOCIEnv
    FC.newForeignPtr env terminate
    where
!     terminate = ociTerminate (#const OCI_DEFAULT) >>= handleSqlResult
! 
! -----------------------------------------------------------------------------------------
! -- allocate/deallocate handles
! -----------------------------------------------------------------------------------------
! 
! allocHandle :: CInt -> OCIHandle -> IO OCIHandle
! allocHandle handleType parent = 
!   alloca $ \pHandle -> do
!     ociHandleAlloc parent pHandle handleType 0 nullPtr >>= handleSqlResult
!     peek pHandle
! 
! freeHandle :: CInt -> OCIHandle -> IO ()
! freeHandle handleType handle =
!   ociHandleFree handle handleType >>= handleSqlResult
  
  -----------------------------------------------------------------------------------------
--- 59,67 ----
  myEnvironment :: OCIEnvRef
  myEnvironment = unsafePerformIO $ alloca $ \ (pOCIEnv :: Ptr OCIEnv) -> do
!   ociEnvCreate pOCIEnv (#const OCI_DEFAULT) nullPtr nullFunPtr nullFunPtr nullFunPtr 0 nullPtr >>= handleSqlResult nullPtr
    env <- peek pOCIEnv
    FC.newForeignPtr env terminate
    where
!     terminate = ociTerminate (#const OCI_DEFAULT) >>= handleSqlResult nullPtr
  
  -----------------------------------------------------------------------------------------
***************
*** 76,82 ****
  -----------------------------------------------------------------------------------------
  
! handleSqlResult err
!   | err == 0  = return ()
!   | otherwise = putStrLn ("ERROR: "++show err)
  
  -- | Makes a new connection to the Oracle service
--- 69,99 ----
  -----------------------------------------------------------------------------------------
  
! handleSqlResult err res
!   | res == (#const OCI_SUCCESS) || res == (#const OCI_NO_DATA) = return ()
!   | res == (#const OCI_SUCCESS_WITH_INFO) = do
! #ifdef DEBUG
!       e <- getSqlError
!       putTraceMsg (show e)
! #else
!       return ()
! #endif
!   | res == (#const OCI_INVALID_HANDLE)  = throwDyn SqlInvalidHandle
!   | res == (#const OCI_STILL_EXECUTING) = throwDyn SqlStillExecuting
!   | res == (#const OCI_NEED_DATA)       = throwDyn SqlNeedData
!   | res == (#const OCI_ERROR)           = getSqlError >>= throwDyn
!   | otherwise = error (show res)
!   where
!     stringBufferLen = 1024
!     
!     getSqlError =
!       alloca $ \pErrCode ->
!       allocaBytes stringBufferLen $ \pErrMsg -> do
!         rc <- ociErrorGet err 1 nullPtr pErrCode pErrMsg (fromIntegral stringBufferLen) (#const OCI_HTYPE_ERROR)
!         if rc < 0
!           then return SqlNoData
!           else do
!             msg <- peekCString pErrMsg
!             errCode <- peek pErrCode
!             return (SqlError {seState="", seNativeError=fromIntegral errCode, seErrorMsg=msg})
  
  -- | Makes a new connection to the Oracle service
***************
*** 90,99 ****
    withCStringLen pwd     $ \(pwd, pwd_len) ->
    withCStringLen service $ \(service, service_len) ->
    alloca $ \pSvcCtx -> do
!     err <- allocHandle (#const OCI_HTYPE_ERROR) env
      res <- ociLogon env err pSvcCtx user (fromIntegral user_len) pwd (fromIntegral pwd_len) service (fromIntegral service_len)
!     if res == (#const OCI_SUCCESS_WITH_INFO)
!       then handleSqlResult (#const OCI_ERROR)
!       else handleSqlResult res
      svcCtx <- peek pSvcCtx
      refFalse <- newMVar False
--- 107,116 ----
    withCStringLen pwd     $ \(pwd, pwd_len) ->
    withCStringLen service $ \(service, service_len) ->
+   alloca $ \pError -> do
    alloca $ \pSvcCtx -> do
!     ociHandleAlloc env pError (#const OCI_HTYPE_ERROR) 0 nullPtr >>= handleSqlResult nullPtr
!     err <- peek pError
      res <- ociLogon env err pSvcCtx user (fromIntegral user_len) pwd (fromIntegral pwd_len) service (fromIntegral service_len)
!     handleSqlResult err res
      svcCtx <- peek pSvcCtx
      refFalse <- newMVar False
***************
*** 112,133 ****
    where
      disconnect svcCtx err = do
!       ociLogoff svcCtx err >>= handleSqlResult
!       freeHandle (#const OCI_HTYPE_ERROR) err
  
      execute envRef svcCtx err query =
        withForeignPtr envRef $ \env ->
!       withCStringLen query $ \(query,query_len) -> do
!         stmt <- allocHandle (#const OCI_HTYPE_STMT) env
!         ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult
!         ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult
!         freeHandle (#const OCI_HTYPE_STMT) stmt
  
      query connection envRef svcCtx err query = 
        withForeignPtr envRef $ \env ->
!       withCStringLen query $ \(query,query_len) -> do
!         stmt <- allocHandle (#const OCI_HTYPE_STMT) env
! 	ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult
! 	ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult
! 	let fields = []
  	refFalse <- newMVar False
          let statement = Statement
--- 129,154 ----
    where
      disconnect svcCtx err = do
!       ociLogoff svcCtx err >>= handleSqlResult err
!       ociHandleFree err (#const OCI_HTYPE_ERROR) >>= handleSqlResult err
  
      execute 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
!         ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
!         ociHandleFree stmt (#const OCI_HTYPE_STMT) >>= handleSqlResult err
  
      query 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
! 	ociStmtExecute svcCtx stmt err 0 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult err
! 	fields <- allocaBytes (#const (sizeof(FIELD_DEF))) (getFieldDefs stmt 1)
  	refFalse <- newMVar False
          let statement = Statement
***************
*** 140,143 ****
--- 161,204 ----
  		}
          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 buffer
+                       fields <- getFieldDefs stmt (counter+1) buffer
+                       return (field:fields)
+               else return []
+ 
+           getFieldDef buffer = do
+             par <- (#peek FIELD_DEF, par) buffer
+             ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, dtype) buffer) nullPtr (#const OCI_ATTR_DATA_TYPE) err >>= handleSqlResult err
+             dtype <- (#peek FIELD_DEF, dtype) buffer
+             ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, dsize) buffer) nullPtr (#const OCI_ATTR_DATA_SIZE) err >>= handleSqlResult err
+             dsize <- (#peek FIELD_DEF, dsize) buffer
+             ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, dprec) buffer) nullPtr (#const OCI_ATTR_PRECISION) err >>= handleSqlResult err
+             dprec <- (#peek FIELD_DEF, dprec) buffer
+             ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, dscale) buffer) nullPtr (#const OCI_ATTR_SCALE) err >>= handleSqlResult err
+             dscale <- (#peek FIELD_DEF, dscale) buffer
+             ociAttrGet par (#const OCI_DTYPE_PARAM) ((#ptr FIELD_DEF, colName) buffer) ((#ptr FIELD_DEF, colNameLen) buffer) (#const OCI_ATTR_NAME) err >>= handleSqlResult err
+             pColName <- (#peek FIELD_DEF, colName) buffer
+             (colNameLen :: (#type ub4)) <- (#peek FIELD_DEF, colNameLen) buffer
+             colName <- peekCStringLen (pColName, fromIntegral colNameLen)
+             ociDescriptorFree par (#const OCI_DTYPE_PARAM)
+             print (dtype,dsize,dprec,dscale)
+             return (colName,mkSqlType dtype dsize dprec dscale,False)
+ 
+     mkSqlType :: (#type OCITypeCode) -> (#type ub2) -> (#type ub1) -> (#type ub1) -> SqlType
+     mkSqlType (#const OCI_TYPECODE_CHAR)      size _    _     = SqlChar    (fromIntegral size)
+     mkSqlType (#const OCI_TYPECODE_VARCHAR)   size _    _     = SqlVarChar (fromIntegral size)
+     mkSqlType (#const OCI_TYPECODE_DECIMAL)   _    prec scale = SqlDecimal (fromIntegral prec) (fromIntegral scale)
+     mkSqlType (#const OCI_TYPECODE_NUMBER)    _    prec scale = SqlNumeric (fromIntegral prec) (fromIntegral scale)
+     mkSqlType (#const OCI_TYPECODE_SMALLINT)  _    _    _     = SqlSmallInt
+     mkSqlType (#const OCI_TYPECODE_INTEGER)   _    _    _     = SqlInteger
+     mkSqlType (#const OCI_TYPECODE_FLOAT)     _    _    _     = SqlFloat
+     mkSqlType (#const OCI_TYPECODE_DATE)      _    _    _     = SqlDate
+     mkSqlType (#const OCI_TYPECODE_TIME)      _    _    _     = SqlTime
+     mkSqlType (#const OCI_TYPECODE_TIMESTAMP) _    _    _     = SqlTimeStamp
+     mkSqlType (#const SQLT_LNG)               _    _    _     = SqlText
+     mkSqlType tp                              _    _    _     = SqlUnknown (fromIntegral tp)
  
      tables connection svcCtx = undefined

[htoolkit-cvs] HSQL/ODBC/Database/HSQL ODBC.hsc,1.3,1.4

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

Update of /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28450/Database/HSQL

Modified Files:
	ODBC.hsc 
Log Message:
ODBC_DEBUG is renamed to DEBUG.


Index: ODBC.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL/ODBC.hsc,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** ODBC.hsc	9 Jun 2005 12:16:34 -0000	1.3
--- ODBC.hsc	12 Oct 2005 14:30:05 -0000	1.4
***************
*** 28,32 ****
  import System.IO.Unsafe
  import System.Time
! #ifdef ODBC_DEBUG
  import Debug.Trace
  #endif
--- 28,32 ----
  import System.IO.Unsafe
  import System.Time
! #ifdef DEBUG
  import Debug.Trace
  #endif
***************
*** 92,98 ****
  	| res == (#const SQL_SUCCESS) || res == (#const SQL_NO_DATA) = return ()
  	| res == (#const SQL_SUCCESS_WITH_INFO) = do
! #ifdef ODBC_DEBUG
! 	    e <- getDiagRec
! 	    trace (show e) $ return ()
  #else
  	    return ()
--- 92,98 ----
  	| res == (#const SQL_SUCCESS) || res == (#const SQL_NO_DATA) = return ()
  	| res == (#const SQL_SUCCESS_WITH_INFO) = do
! #ifdef DEBUG
! 	    e <- getSqlError
! 	    putTraceMsg (show e)
  #else
  	    return ()
***************
*** 102,110 ****
  	| res == (#const SQL_NEED_DATA) = throwDyn SqlNeedData
  	| res == (#const SQL_ERROR) = do
! 	    e <- getDiagRec
  	    throwDyn e
  	| otherwise = error (show res)
  	where
! 	  getDiagRec =
  	    allocaBytes 256 $ \pState ->
  	    alloca $ \pNative ->
--- 102,110 ----
  	| res == (#const SQL_NEED_DATA) = throwDyn SqlNeedData
  	| res == (#const SQL_ERROR) = do
! 	    e <- getSqlError
  	    throwDyn e
  	| otherwise = error (show res)
  	where
! 	  getSqlError =
  	    allocaBytes 256 $ \pState ->
  	    alloca $ \pNative ->

[htoolkit-cvs] HSQL/Oracle/Database/HSQL HsOCI.h,NONE,1.1 Oracle.hsc,NONE,1.1

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

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

Added Files:
	HsOCI.h Oracle.hsc 
Log Message:
Added Oracle driver. It isn't completed yet.


--- NEW FILE: HsOCI.h ---
#define _int64 long long

#include <oci.h>

#undef _int64

--- NEW FILE: Oracle.hsc ---
{-# OPTIONS -fglasgow-exts #-}

-----------------------------------------------------------------------------------------
{-| Module      :  Database.HSQL.Oracle
    Copyright   :  (c) Krasimir Angelov 2003
    License     :  BSD-style

    Maintainer  :  kr....@gm...
    Stability   :  provisional
    Portability :  portable

    The module provides interface to Oracle
-}
-----------------------------------------------------------------------------------------

module Database.HSQL.Oracle(connect, module Database.HSQL) where

import Database.HSQL
import Database.HSQL.Types
import Foreign
import Foreign.C
import Foreign.Concurrent as FC
import Control.Concurrent.MVar

#include <HsOCI.h>

type OCIHandle = Ptr ()
type OCIEnv    = OCIHandle
type OCIError  = OCIHandle
type OCISvcCtx = OCIHandle
type OCIStmt   = OCIHandle

type OCIEnvRef = ForeignPtr ()

foreign import ccall "OCIEnvCreate" ociEnvCreate :: Ptr OCIEnv -> CInt -> Ptr a -> FunPtr a -> FunPtr a -> FunPtr a -> CInt -> Ptr (Ptr a) -> IO CInt
foreign import ccall "OCITerminate" ociTerminate :: CInt -> IO CInt
foreign import ccall "OCIHandleAlloc" ociHandleAlloc :: OCIHandle -> Ptr OCIHandle -> CInt -> CInt -> Ptr a -> IO CInt
foreign import ccall "OCIHandleFree" ociHandleFree :: OCIHandle -> CInt -> IO CInt
foreign import ccall "OCIErrorGet" ociErrorGet :: OCIHandle -> CInt -> CString -> Ptr CInt -> CString -> CInt -> CInt -> IO CInt

foreign import ccall "OCILogon" ociLogon :: OCIEnv -> OCIError -> Ptr OCISvcCtx -> CString -> CInt -> CString -> CInt -> CString -> CInt -> IO CInt
foreign import ccall "OCILogoff" ociLogoff :: OCISvcCtx -> OCIError -> IO CInt

foreign import ccall "OCIStmtPrepare" ociStmtPrepare :: OCIStmt -> OCIError -> CString -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall "OCIStmtExecute" ociStmtExecute :: OCISvcCtx -> OCIStmt -> OCIError -> CInt -> CInt -> OCIHandle -> OCIHandle -> CInt -> IO CInt

-----------------------------------------------------------------------------------------
-- keeper of OCIEnv
-----------------------------------------------------------------------------------------

{-# NOINLINE myEnvironment #-}
myEnvironment :: OCIEnvRef
myEnvironment = unsafePerformIO $ alloca $ \ (pOCIEnv :: Ptr OCIEnv) -> do
  ociEnvCreate pOCIEnv (#const OCI_DEFAULT) nullPtr nullFunPtr nullFunPtr nullFunPtr 0 nullPtr >>= handleSqlResult
  env <- peek pOCIEnv
  FC.newForeignPtr env terminate
  where
    terminate = ociTerminate (#const OCI_DEFAULT) >>= handleSqlResult

-----------------------------------------------------------------------------------------
-- allocate/deallocate handles
-----------------------------------------------------------------------------------------

allocHandle :: CInt -> OCIHandle -> IO OCIHandle
allocHandle handleType parent = 
  alloca $ \pHandle -> do
    ociHandleAlloc parent pHandle handleType 0 nullPtr >>= handleSqlResult
    peek pHandle

freeHandle :: CInt -> OCIHandle -> IO ()
freeHandle handleType handle =
  ociHandleFree handle handleType >>= handleSqlResult

-----------------------------------------------------------------------------------------
-- error handling
-----------------------------------------------------------------------------------------

handleSqlResult err
  | err == 0  = return ()
  | otherwise = putStrLn ("ERROR: "++show err)

-- | Makes a new connection to the Oracle service
connect :: String               -- ^ Service name
        -> String               -- ^ User identifier
        -> String               -- ^ Password
        -> IO Connection        -- ^ the returned value represents the new connection
connect service user pwd =
  withForeignPtr myEnvironment $ \env ->
  withCStringLen user    $ \(user, user_len) ->
  withCStringLen pwd     $ \(pwd, pwd_len) ->
  withCStringLen service $ \(service, service_len) ->
  alloca $ \pSvcCtx -> do
    err <- allocHandle (#const OCI_HTYPE_ERROR) env
    res <- ociLogon env err pSvcCtx user (fromIntegral user_len) pwd (fromIntegral pwd_len) service (fromIntegral service_len)
    if res == (#const OCI_SUCCESS_WITH_INFO)
      then handleSqlResult (#const OCI_ERROR)
      else handleSqlResult res
    svcCtx <- peek pSvcCtx
    refFalse <- newMVar False
    let connection = (Connection
    			{ connDisconnect = disconnect svcCtx err
    			, connExecute    = execute myEnvironment svcCtx err
    			, connQuery      = query connection myEnvironment svcCtx err
    			, connTables     = tables connection svcCtx
    			, connDescribe   = describe connection svcCtx
    			, connBeginTransaction = beginTransaction myEnvironment svcCtx
    			, connCommitTransaction = commitTransaction myEnvironment svcCtx
    			, connRollbackTransaction = rollbackTransaction myEnvironment svcCtx
    			, connClosed     = refFalse
    			})
    return connection
  where
    disconnect svcCtx err = do
      ociLogoff svcCtx err >>= handleSqlResult
      freeHandle (#const OCI_HTYPE_ERROR) err

    execute envRef svcCtx err query =
      withForeignPtr envRef $ \env ->
      withCStringLen query $ \(query,query_len) -> do
        stmt <- allocHandle (#const OCI_HTYPE_STMT) env
        ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult
        ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult
        freeHandle (#const OCI_HTYPE_STMT) stmt

    query connection envRef svcCtx err query = 
      withForeignPtr envRef $ \env ->
      withCStringLen query $ \(query,query_len) -> do
        stmt <- allocHandle (#const OCI_HTYPE_STMT) env
	ociStmtPrepare stmt err query (fromIntegral query_len) (#const OCI_NTV_SYNTAX) (#const OCI_DEFAULT) >>= handleSqlResult
	ociStmtExecute svcCtx stmt err 1 0 nullPtr nullPtr (#const OCI_DEFAULT) >>= handleSqlResult
	let fields = []
	refFalse <- newMVar False
        let statement = Statement
		{ stmtConn   = connection
		, stmtClose  = closeStatement stmt
		, stmtFetch  = fetch stmt
		, stmtGetCol = getColValue stmt
		, stmtFields = fields
		, stmtClosed = refFalse
		}
        return statement

    tables connection svcCtx = undefined
    describe connection svcCtx = undefined
    beginTransaction myEnvironment svcCtx = undefined
    commitTransaction myEnvironment svcCtx = undefined
    rollbackTransaction myEnvironment svcCtx = undefined
    
    closeStatement stmt = undefined
    fetch stmt = undefined
    getColValue stmt = undefined

[htoolkit-cvs] HSQL/Oracle Oracle.cabal,NONE,1.1 Setup.lhs,NONE,1.1

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

Update of /cvsroot/htoolkit/HSQL/Oracle
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24808/Oracle

Added Files:
	Oracle.cabal Setup.lhs 
Log Message:
Added Oracle driver. It isn't completed yet.


--- NEW FILE: Oracle.cabal ---
name:		hsql-oracle
version:	1.6
license:	BSD3
author:		Krasimir Angelov <kr....@gm...>
category:	Database
description:	Oracle driver for HSQL.
exposed-modules:Database.HSQL.Oracle
build-depends:	base, hsql
extensions:     ForeignFunctionInterface, CPP
cc-options:     -IDatabase/HSQL
extra-libraries: oci
--- NEW FILE: Setup.lhs ---
#!/usr/bin/runghc

\begin{code}
import Distribution.Simple
import Distribution.Setup
import Distribution.PackageDescription
import System.Info

main = defaultMainWithHooks defaultUserHooks{preConf=configure}
  where
    configure :: [String] -> ConfigFlags -> IO HookedBuildInfo
    configure args flags = do
      let binfo = emptyBuildInfo
          hbi   = (Just binfo,[])
      writeHookedBuildInfo "Oracle.buildinfo" hbi
      return hbi
\end{code}

[htoolkit-cvs] HSQL/mingw32lib oci.def,NONE,1.1 Makefile,1.2,1.3

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

Update of /cvsroot/htoolkit/HSQL/mingw32lib
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24808/mingw32lib

Modified Files:
	Makefile 
Added Files:
	oci.def 
Log Message:
Added Oracle driver. It isn't completed yet.


--- NEW FILE: oci.def ---
EXPORTS
clsslsmutexlock
clsslsshrlock
clsslstrylock
clsslsunlock
clssshutdown
clsssinit
clsssterm
k2mdii
kadcrfub1
kadgetembtype
kadread
kadsize
kgebem
kgegec
kgeres
kgesic0
kod2psw
kodpaih2
[...1172 lines suppressed...]
upilof
upilog
upilon
upinbls
upiopn
upiosd
upiosq
upipse
upirol
upirtr
upisfc
upispi
upista8
upisto
upisyn
xaoEnv
xaosterr
xaoSvcCtx
xaosw
xaoswd

Index: Makefile
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/mingw32lib/Makefile,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** Makefile	10 Jun 2005 08:26:19 -0000	1.2
--- Makefile	15 Sep 2005 12:57:10 -0000	1.3
***************
*** 1,3 ****
! all: liblibmysql.a liblibpq.a libsqlite.a libmsi.a
  
  liblibmysql.a: libmysql.def
--- 1,3 ----
! all: liblibmysql.a liblibpq.a libsqlite.a libmsi.a liboci.a
  
  liblibmysql.a: libmysql.def
***************
*** 12,13 ****
--- 12,16 ----
  libmsi.a: msi.def
  	dlltool --input-def msi.def --dllname msi.dll --output-lib libmsi.a -k
+ 
+ liboci.a: oci.def
+ 	dlltool --input-def oci.def --dllname oci.dll --output-lib liboci.a -k

[htoolkit-cvs] HSQL/Oracle - New directory

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

Update of /cvsroot/htoolkit/HSQL/Oracle
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24080/Oracle

Log Message:
Directory /cvsroot/htoolkit/HSQL/Oracle added to the repository

[htoolkit-cvs] HSQL/Oracle/Database - New directory

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

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

Log Message:
Directory /cvsroot/htoolkit/HSQL/Oracle/Database added to the repository

[htoolkit-cvs] HSQL/Oracle/Database/HSQL - New directory

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

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

Log Message:
Directory /cvsroot/htoolkit/HSQL/Oracle/Database/HSQL added to the repository

[htoolkit-cvs] HSQL/MySQL Setup.lhs,1.1,1.2

[<br...@us...>]

Update of /cvsroot/htoolkit/HSQL/MySQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv1218

Modified Files:
	Setup.lhs 
Log Message:
Use mysql_config --include instead of mysql_config --cflags, since the latter may use flags not supported by GHC.

Index: Setup.lhs
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/MySQL/Setup.lhs,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** Setup.lhs	17 Jun 2005 08:43:51 -0000	1.1
--- Setup.lhs	31 Jul 2005 10:30:27 -0000	1.2
***************
*** 74,78 ****
         res <- rawSystemGrabOutput verbose mysql_config_path ["--libs"]
         let (lib_dirs,libs,ld_opts) = splitLibsFlags (words res)
!        res <- rawSystemGrabOutput verbose mysql_config_path ["--cflags"]
         let (inc_dirs,cc_opts) = splitCFlags (words res)
         let bi = emptyBuildInfo{extraLibDirs=lib_dirs, extraLibs=libs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts}
--- 74,78 ----
         res <- rawSystemGrabOutput verbose mysql_config_path ["--libs"]
         let (lib_dirs,libs,ld_opts) = splitLibsFlags (words res)
!        res <- rawSystemGrabOutput verbose mysql_config_path ["--include"]
         let (inc_dirs,cc_opts) = splitCFlags (words res)
         let bi = emptyBuildInfo{extraLibDirs=lib_dirs, extraLibs=libs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts}

[htoolkit-cvs] HSQL/HSQL HSQL.cabal,1.1,1.2

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

Update of /cvsroot/htoolkit/HSQL/HSQL
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5831/HSQL

Modified Files:
	HSQL.cabal 
Log Message:
Update version numbers


Index: HSQL.cabal
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/HSQL/HSQL.cabal,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HSQL.cabal	1 Feb 2005 13:04:06 -0000	1.1
--- HSQL.cabal	17 Jun 2005 15:44:43 -0000	1.2
***************
*** 1,4 ****
  name:		hsql
! version:	1.5
  license:	BSD3
  author:		Krasimir Angelov <ka2...@ya...>
--- 1,4 ----
  name:		hsql
! version:	1.6
  license:	BSD3
  author:		Krasimir Angelov <ka2...@ya...>

[htoolkit-cvs] HSQL/SQLite SQLite.cabal,1.4,1.5

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

Update of /cvsroot/htoolkit/HSQL/SQLite
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5345/SQLite

Modified Files:
	SQLite.cabal 
Log Message:
Update version numbers


Index: SQLite.cabal
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/SQLite/SQLite.cabal,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** SQLite.cabal	17 Jun 2005 06:48:10 -0000	1.4
--- SQLite.cabal	17 Jun 2005 15:44:00 -0000	1.5
***************
*** 1,4 ****
  name:		 hsql-sqlite
! version:	 1.5
  license:	 BSD3
  author:		 Krasimir Angelov <kr....@gm...>
--- 1,4 ----
  name:		 hsql-sqlite
! version:	 1.6
  license:	 BSD3
  author:		 Krasimir Angelov <kr....@gm...>

[htoolkit-cvs] HSQL/MSI MSI.cabal,1.1,1.2

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

Update of /cvsroot/htoolkit/HSQL/MSI
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5345/MSI

Modified Files:
	MSI.cabal 
Log Message:
Update version numbers


Index: MSI.cabal
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/MSI/MSI.cabal,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** MSI.cabal	14 Jun 2005 14:16:31 -0000	1.1
--- MSI.cabal	17 Jun 2005 15:44:00 -0000	1.2
***************
*** 1,4 ****
  name:		hsql-msi
! version:	1.5
  license:	BSD3
  author:		Krasimir Angelov <kr....@gm...>
--- 1,4 ----
  name:		hsql-msi
! version:	1.0
  license:	BSD3
  author:		Krasimir Angelov <kr....@gm...>

[htoolkit-cvs] HSQL/ODBC ODBC.cabal,1.2,1.3

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

Update of /cvsroot/htoolkit/HSQL/ODBC
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5345/ODBC

Modified Files:
	ODBC.cabal 
Log Message:
Update version numbers


Index: ODBC.cabal
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/ODBC/ODBC.cabal,v
retrieving revision 1.2
retrieving revision 1.3
diff -C2 -d -r1.2 -r1.3
*** ODBC.cabal	9 Jun 2005 12:16:34 -0000	1.2
--- ODBC.cabal	17 Jun 2005 15:44:00 -0000	1.3
***************
*** 1,4 ****
  name:		hsql-odbc
! version:	1.5
  license:	BSD3
  author:		Krasimir Angelov <kr....@gm...>
--- 1,4 ----
  name:		hsql-odbc
! version:	1.6
  license:	BSD3
  author:		Krasimir Angelov <kr....@gm...>