Thread: [htoolkit-cvs] HSQL/ODBC HSQL.hsc,1.1,1.2

SourceForge Headquarters 225 Broadway Suite 1600 San Diego, CA 92101 +1 (858) 422-6466

Update of /cvsroot/htoolkit/HSQL/ODBC
In directory sc8-pr-cvs1:/tmp/cvs-serv10736/ODBC

Modified Files:
	HSQL.hsc 
Log Message:
Add better support for sql types

Index: HSQL.hsc
===================================================================
RCS file: /cvsroot/htoolkit/HSQL/ODBC/HSQL.hsc,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** HSQL.hsc	5 Sep 2003 21:44:10 -0000	1.1
--- HSQL.hsc	6 Sep 2003 22:44:13 -0000	1.2
***************
*** 102,110 ****

  data SqlType	
! 	= SqlChar			Int
! 	| SqlVarChar		Int
! 	| SqlLongVarChar	Int
! 	| SqlDecimal		Int Int
! 	| SqlNumeric		Int Int
  	| SqlSmallInt
  	| SqlInteger
--- 102,110 ----

  data SqlType	
! 	= SqlChar          Int
! 	| SqlVarChar       Int
! 	| SqlLongVarChar   Int
! 	| SqlDecimal       Int Int
! 	| SqlNumeric       Int Int
  	| SqlSmallInt
  	| SqlInteger
***************
*** 114,120 ****
  	| SqlTinyInt
  	| SqlBigInt
! 	| SqlBinary			Int
! 	| SqlVarBinary		Int
! 	| SqlLongVarBinary  Int
  	| SqlDate
  	| SqlTime
--- 114,120 ----
  	| SqlTinyInt
  	| SqlBigInt
! 	| SqlBinary        Int
! 	| SqlVarBinary     Int
! 	| SqlLongVarBinary Int
  	| SqlDate
  	| SqlTime
***************
*** 124,130 ****
  data SqlError
     = SqlError
! 		{ seState		:: String
! 		, seNativeError	:: Int
! 		, seErrorMsg	:: String
  		}
     | SqlNoData
--- 124,130 ----
  data SqlError
     = SqlError
! 		{ seState       :: String
! 		, seNativeError :: Int
! 		, seErrorMsg    :: String
  		}
     | SqlNoData
***************
*** 132,136 ****
     | SqlStillExecuting
     | SqlNeedData
!    deriving Show

  -----------------------------------------------------------------------------------------
--- 132,143 ----
     | SqlStillExecuting
     | SqlNeedData
!    | SqlBadTypeCast
!       		{ seFieldName :: String
!    		, seFieldType :: SqlType
!    		}
!    | SqlFetchNull
!    		{ seFieldName :: String
! 		}
!    deriving (Show, Typeable)

  -----------------------------------------------------------------------------------------
***************
*** 138,147 ****
  -----------------------------------------------------------------------------------------

- {-# NOINLINE sqlErrorTy #-}
- sqlErrorTy = mkAppTy (mkTyCon "SqlError") []
- 
- instance Typeable SqlError where
- 	typeOf x = sqlErrorTy
- 
  catchSql :: IO a -> (SqlError -> IO a) -> IO a
  catchSql = catchDyn
--- 145,148 ----
***************
*** 332,367 ****

  class SqlBind a where
! 	getSqlValue :: SqlType -> Ptr () -> Int -> IO a

  instance SqlBind Int where
! 	getSqlValue SqlInteger ptr size = peek (castPtr ptr)
! 	getSqlValue SqlSmallInt ptr size = do
  		(n :: Int16) <- peek (castPtr ptr)
! 		return (fromIntegral n)

  instance SqlBind Integer where
! 	getSqlValue SqlInteger ptr size = do
  		(n :: Int32) <- peek (castPtr ptr)
! 		return (fromIntegral n)
! 	getSqlValue SqlSmallInt ptr size = do
  		(n :: Int16) <- peek (castPtr ptr)
! 		return (fromIntegral n)
! 	getSqlValue SqlBigInt ptr size = do
  		str <- peekCStringLen (castPtr ptr, size)
! 		return (read str)

  instance SqlBind String where
! 	getSqlValue (SqlChar _) ptr size = peekCStringLen (castPtr ptr, size)
! 	getSqlValue (SqlVarChar _) ptr size = peekCStringLen (castPtr ptr, size)
! 	getSqlValue (SqlLongVarChar _) ptr size = peekCStringLen (castPtr ptr, size)

  instance SqlBind Double where
! 	getSqlValue (SqlDecimal _ _) ptr size = peek (castPtr ptr)
! 	getSqlValue (SqlNumeric _ _) ptr size = peek (castPtr ptr)
! 	getSqlValue SqlDouble ptr size = peek (castPtr ptr)
! 	getSqlValue SqlReal ptr size = peek (castPtr ptr)

  instance SqlBind ClockTime where
! 	getSqlValue SqlDate ptr size = allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
  		(year :: SQLSMALLINT) <- (#peek TIMESTAMP_STRUCT, year) ptr
  		(#poke struct tm,tm_year ) p_tm	(fromIntegral (year-1900) :: CInt)
--- 333,384 ----

  class SqlBind a where
! 	fromSqlValue :: SqlType -> Ptr () -> Int -> IO (Maybe a)
! 	toSqlValue   :: a -> String

  instance SqlBind Int where
! 	fromSqlValue SqlInteger ptr size = fmap Just $ peek (castPtr ptr)
! 	fromSqlValue SqlSmallInt ptr size = do
  		(n :: Int16) <- peek (castPtr ptr)
! 		return (Just (fromIntegral n))
! 	fromSqlValue _ _ _ = return Nothing
! 	
! 	toSqlValue val = show val

  instance SqlBind Integer where
! 	fromSqlValue SqlInteger ptr size = do
  		(n :: Int32) <- peek (castPtr ptr)
! 		return (Just (fromIntegral n))
! 	fromSqlValue SqlSmallInt ptr size = do
  		(n :: Int16) <- peek (castPtr ptr)
! 		return (Just (fromIntegral n))
! 	fromSqlValue SqlBigInt ptr size = do
  		str <- peekCStringLen (castPtr ptr, size)
! 		return (Just (read str))
! 	fromSqlValue _ _ _ = return Nothing
! 	
! 	toSqlValue val = show val

  instance SqlBind String where
! 	fromSqlValue (SqlChar _) ptr size = fmap Just $ peekCStringLen (castPtr ptr, size)
! 	fromSqlValue (SqlVarChar _) ptr size = fmap Just $ peekCStringLen (castPtr ptr, size)
! 	fromSqlValue (SqlLongVarChar _) ptr size = fmap Just $ peekCStringLen (castPtr ptr, size)
! 	fromSqlValue _ _ _ = return Nothing
! 	
! 	toSqlValue s = '\'' : foldr mapChar "'" s
! 		where
! 			mapChar '\'' s = '\'':'\'':s
! 			mapChar c    s = c:s

  instance SqlBind Double where
! 	fromSqlValue (SqlDecimal _ _) ptr size = fmap Just $ peek (castPtr ptr)
! 	fromSqlValue (SqlNumeric _ _) ptr size = fmap Just $ peek (castPtr ptr)
! 	fromSqlValue SqlDouble ptr size = fmap Just $ peek (castPtr ptr)
! 	fromSqlValue SqlReal ptr size = fmap Just $ peek (castPtr ptr)
! 	fromSqlValue _ _ _ = return Nothing
! 	
! 	toSqlValue val = show val

  instance SqlBind ClockTime where
! 	fromSqlValue SqlDate ptr size = allocaBytes (#const sizeof(struct tm)) $ \p_tm -> do
  		(year :: SQLSMALLINT) <- (#peek TIMESTAMP_STRUCT, year) ptr
  		(#poke struct tm,tm_year ) p_tm	(fromIntegral (year-1900) :: CInt)
***************
*** 379,384 ****
  		(#poke struct tm,tm_isdst) p_tm	(-1 :: CInt)
  		t <- mktime p_tm
! 		return (TOD (fromIntegral t) (fromIntegral fraction*1000))
! foreign import ccall unsafe mktime :: Ptr () -> IO CTime	

  getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
--- 396,420 ----
  		(#poke struct tm,tm_isdst) p_tm	(-1 :: CInt)
  		t <- mktime p_tm
! 		return (Just (TOD (fromIntegral t) (fromIntegral fraction*1000)))
! 	fromSqlValue _ _ _ = return Nothing
! 	
! 	toSqlValue ct = '\'' : (shows (ctYear t) .
! 				score .
! 				shows (ctMonth t) .
! 				score .
! 				shows (ctDay t) .
! 				space .
! 				shows (ctHour t) .
! 				colon .
! 				shows (ctMin t) .
! 				colon .
! 				shows (ctSec t)) "'"
! 		       where
! 			 t = toUTCTime ct
! 			 score = showChar '-'
! 			 space = showChar ' '
!                          colon = showChar ':'
!                          
! foreign import ccall unsafe mktime :: Ptr () -> IO CTime

  getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)
***************
*** 390,397 ****
  	if len_or_ind == (#const SQL_NULL_DATA) 
  		then return Nothing
! 		else fmap Just $
! 				(if res == (#const SQL_SUCCESS_WITH_INFO)
  					then getLongData len_or_ind
! 					else getSqlValue sqlType dataBuffer (fromIntegral len_or_ind))
  	where
  		(sqlType,nullable,colNumber) = findFieldInfo name fields 1
--- 426,436 ----
  	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 fromSqlValue sqlType dataBuffer (fromIntegral len_or_ind))
! 			case mb_value of
! 				Just value -> return (Just value)
! 				Nothing    -> throwDyn (SqlBadTypeCast name sqlType)
  	where
  		(sqlType,nullable,colNumber) = findFieldInfo name fields 1
***************
*** 404,408 ****
  			handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
  			(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
! 			r <- getSqlValue sqlType dataBuffer (fromIntegral len_or_ind)
  			free buffer
  			return r
--- 443,447 ----
  			handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res
  			(len_or_ind :: SQLINTEGER) <- peek (castPtr buffer)
! 			r <- fromSqlValue sqlType dataBuffer (fromIntegral len_or_ind)
  			free buffer
  			return r
***************
*** 432,437 ****
  	mb_v <- getFieldValueMB stmt name
  	case mb_v of 
! 		Nothing -> fail ("Column \"" ++ name ++ "\" has null value")
! 		Just a -> return a

  getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a
--- 471,476 ----
  	mb_v <- getFieldValueMB stmt name
  	case mb_v of 
! 		Nothing -> throwDyn (SqlFetchNull name)
! 		Just a  -> return a

  getFieldValue' :: SqlBind a => Statement -> String -> a -> IO a