Permalink
Browse files

fix incorrect use of 'with' to allocate storage that is used for binds.

--HG--
extra : convert_revision : fb6d91f5bf1a4d7895b7917c193bf7c3adbf2fe7
  • Loading branch information...
1 parent 4c3e019 commit eb6ff9ee0d799cc0cdad1a3a92b04acfefb69b9e @waterson waterson committed Apr 17, 2010
Showing with 98 additions and 88 deletions.
  1. +94 −83 Database/HDBC/MySQL/Connection.hsc
  2. +1 −1 HDBC-mysql.cabal
  3. +3 −4 Test.hs
@@ -350,92 +350,103 @@ bindParams stmt_ params = do
-- pass its value.
bindOfSqlValue :: Types.SqlValue -> IO MYSQL_BIND
-bindOfSqlValue Types.SqlNull =
- with (1 :: CChar) $ \isNull_ ->
- return $ MYSQL_BIND
- { bindLength = nullPtr
- , bindIsNull = isNull_
- , bindBuffer = nullPtr
- , bindError = nullPtr
- , bindBufferType = #{const MYSQL_TYPE_NULL}
- , bindBufferLength = 0
- , bindIsUnsigned = 0
- }
-
-bindOfSqlValue (Types.SqlString s) =
- -- XXX this might not handle embedded null characters correctly.
- bindOfSqlValue' (length s) (withCString s) #{const MYSQL_TYPE_VAR_STRING} Signed
-
-bindOfSqlValue (Types.SqlByteString s) =
- bindOfSqlValue' (B.length s) (B.useAsCString s) #{const MYSQL_TYPE_VAR_STRING} Signed
-
-bindOfSqlValue (Types.SqlInteger n) =
- bindOfSqlValue' (8::Int) (with (fromIntegral n :: CLLong)) #{const MYSQL_TYPE_LONGLONG} Signed
-
-bindOfSqlValue (Types.SqlBool b) =
- bindOfSqlValue' (1::Int) (with (if b then 1 else 0 :: CChar)) #{const MYSQL_TYPE_TINY} Signed
-
-bindOfSqlValue (Types.SqlChar c) =
- bindOfSqlValue' (1::Int) (with c) #{const MYSQL_TYPE_TINY} Signed
-
-bindOfSqlValue (Types.SqlDouble d) =
- bindOfSqlValue' (8::Int) (with (realToFrac d :: CDouble)) #{const MYSQL_TYPE_DOUBLE} Signed
-
-bindOfSqlValue (Types.SqlInt32 n) =
- bindOfSqlValue' (4::Int) (with n) #{const MYSQL_TYPE_LONG} Signed
-
-bindOfSqlValue (Types.SqlInt64 n) =
- bindOfSqlValue' (8::Int) (with n) #{const MYSQL_TYPE_LONGLONG} Signed
-
-bindOfSqlValue (Types.SqlRational n) =
- bindOfSqlValue' (8::Int) (with (realToFrac n :: CDouble)) #{const MYSQL_TYPE_DOUBLE} Signed
-
-bindOfSqlValue (Types.SqlWord32 n) =
- bindOfSqlValue' (4::Int) (with n) #{const MYSQL_TYPE_LONG} Unsigned
-
-bindOfSqlValue (Types.SqlWord64 n) =
- bindOfSqlValue' (8::Int) (with n) #{const MYSQL_TYPE_LONGLONG} Unsigned
-
-bindOfSqlValue (Types.SqlEpochTime epoch) =
- let t = utcToMysqlTime $ posixSecondsToUTCTime (fromIntegral epoch) in
- bindOfSqlValue' (#{const sizeof(MYSQL_TIME)}::Int) (with t) #{const MYSQL_TYPE_DATETIME} Signed
- where utcToMysqlTime :: UTCTime -> MYSQL_TIME
- utcToMysqlTime (UTCTime day difftime) =
- let (y, m, d) = toGregorian day
- t = floor $ (realToFrac difftime :: Double)
- h = t `div` 3600
- mn = t `div` 60 `mod` 60
- s = t `mod` 60
- in MYSQL_TIME (fromIntegral y) (fromIntegral m) (fromIntegral d) h mn s
+bindOfSqlValue Types.SqlNull = do
+ isNull_ <- new (1 :: CChar)
+ return $ MYSQL_BIND
+ { bindLength = nullPtr
+ , bindIsNull = isNull_
+ , bindBuffer = nullPtr
+ , bindError = nullPtr
+ , bindBufferType = #{const MYSQL_TYPE_NULL}
+ , bindBufferLength = 0
+ , bindIsUnsigned = 0
+ }
-bindOfSqlValue (Types.SqlTimeDiff n) =
- let h = fromIntegral $ n `div` 3600
- mn = fromIntegral $ n `div` 60 `mod` 60
- s = fromIntegral $ n `mod` 60
- t = MYSQL_TIME 0 0 0 h mn s in
- bindOfSqlValue' (#{const sizeof(MYSQL_TIME)}::Int) (with t) #{const MYSQL_TYPE_TIME} Signed
+bindOfSqlValue (Types.SqlString s) = do
+ -- XXX this might not handle embedded null characters correctly.
+ (buf_, len) <- newCAStringLen s
+ bindOfSqlValue' len buf_ #{const MYSQL_TYPE_VAR_STRING} Signed
+
+bindOfSqlValue (Types.SqlByteString s) = do
+ B.useAsCString s $ \c_ -> do
+ let len = B.length s
+ buf_ <- mallocBytes len
+ copyBytes buf_ c_ len
+ bindOfSqlValue' len buf_ #{const MYSQL_TYPE_VAR_STRING} Signed
+
+bindOfSqlValue (Types.SqlInteger n) = do
+ buf_ <- new (fromIntegral n :: CLLong)
+ bindOfSqlValue' (8::Int) buf_ #{const MYSQL_TYPE_LONGLONG} Signed
+
+bindOfSqlValue (Types.SqlBool b) = do
+ buf_ <- new (if b then 1 else 0 :: CChar)
+ bindOfSqlValue' (1::Int) buf_ #{const MYSQL_TYPE_TINY} Signed
+
+bindOfSqlValue (Types.SqlChar c) = do
+ buf_ <- new c
+ bindOfSqlValue' (1::Int) buf_ #{const MYSQL_TYPE_TINY} Signed
+
+bindOfSqlValue (Types.SqlDouble d) = do
+ buf_ <- new (realToFrac d :: CDouble)
+ bindOfSqlValue' (8::Int) buf_ #{const MYSQL_TYPE_DOUBLE} Signed
+
+bindOfSqlValue (Types.SqlInt32 n) = do
+ buf_ <- new n
+ bindOfSqlValue' (4::Int) buf_ #{const MYSQL_TYPE_LONG} Signed
+
+bindOfSqlValue (Types.SqlInt64 n) = do
+ buf_ <- new n
+ bindOfSqlValue' (8::Int) buf_ #{const MYSQL_TYPE_LONGLONG} Signed
+
+bindOfSqlValue (Types.SqlRational n) = do
+ buf_ <- new (realToFrac n :: CDouble)
+ bindOfSqlValue' (8::Int) buf_ #{const MYSQL_TYPE_DOUBLE} Signed
+
+bindOfSqlValue (Types.SqlWord32 n) = do
+ buf_ <- new n
+ bindOfSqlValue' (4::Int) buf_ #{const MYSQL_TYPE_LONG} Unsigned
+
+bindOfSqlValue (Types.SqlWord64 n) = do
+ buf_ <- new n
+ bindOfSqlValue' (8::Int) buf_ #{const MYSQL_TYPE_LONGLONG} Unsigned
+
+bindOfSqlValue (Types.SqlEpochTime epoch) = do
+ let t = utcToMysqlTime $ posixSecondsToUTCTime (fromIntegral epoch)
+ buf_ <- new t
+ bindOfSqlValue' (#{const sizeof(MYSQL_TIME)}::Int) buf_ #{const MYSQL_TYPE_DATETIME} Signed
+ where utcToMysqlTime :: UTCTime -> MYSQL_TIME
+ utcToMysqlTime (UTCTime day difftime) =
+ let (y, m, d) = toGregorian day
+ t = floor $ (realToFrac difftime :: Double)
+ h = t `div` 3600
+ mn = t `div` 60 `mod` 60
+ s = t `mod` 60
+ in MYSQL_TIME (fromIntegral y) (fromIntegral m) (fromIntegral d) h mn s
+
+bindOfSqlValue (Types.SqlTimeDiff n) = do
+ let h = fromIntegral $ n `div` 3600
+ mn = fromIntegral $ n `div` 60 `mod` 60
+ s = fromIntegral $ n `mod` 60
+ t = MYSQL_TIME 0 0 0 h mn s
+ buf_ <- new t
+ bindOfSqlValue' (#{const sizeof(MYSQL_TIME)}::Int) buf_ #{const MYSQL_TYPE_TIME} Signed
-- A nasty helper function that cuts down on the boilerplate a bit.
-bindOfSqlValue' :: (Integral a, Storable b) =>
- a ->
- ((Ptr b -> IO MYSQL_BIND) -> IO MYSQL_BIND) ->
- CInt -> Signedness ->
- IO MYSQL_BIND
-
-bindOfSqlValue' len buf btype signedness =
- let buflen = fromIntegral len in
- with (0 :: CChar) $ \isNull_ ->
- with buflen $ \len_ ->
- buf $ \buf_ ->
- return $ MYSQL_BIND
- { bindLength = len_
- , bindIsNull = isNull_
- , bindBuffer = castPtr buf_
- , bindError = nullPtr
- , bindBufferType = btype
- , bindBufferLength = buflen
- , bindIsUnsigned = (if signedness == Unsigned then 1 else 0)
- }
+bindOfSqlValue' :: (Integral a, Storable b) => a -> Ptr b -> CInt -> Signedness -> IO MYSQL_BIND
+
+bindOfSqlValue' len buf_ btype signedness = do
+ let buflen = fromIntegral len
+ isNull_ <- new (0 :: CChar)
+ len_ <- new buflen
+ return $ MYSQL_BIND
+ { bindLength = len_
+ , bindIsNull = isNull_
+ , bindBuffer = castPtr buf_
+ , bindError = nullPtr
+ , bindBufferType = btype
+ , bindBufferLength = buflen
+ , bindIsUnsigned = (if signedness == Unsigned then 1 else 0)
+ }
-- Returns an appropriate binding structure for a field.
resultOfField :: MYSQL_FIELD -> IO MYSQL_BIND
View
@@ -1,7 +1,7 @@
Name: HDBC-mysql
Category: Database
Synopsis: MySQL driver for HDBC
-Version: 0.6.1
+Version: 0.6.2
Description: This package provides a MySQL driver for HDBC.
Stability: Experimental
Maintainer: Chris Waterson <waterson@maubi.net>
View
@@ -12,8 +12,6 @@ connectDatabase = connectMySQL defaultMySQLConnectInfo
go :: IO ()
go = do conn <- connectDatabase
- {-
-
putStrLn $ "driver " ++ (show $ hdbcDriverName conn)
putStrLn $ "server version " ++ (show $ dbServerVer conn)
tables <- getTables conn
@@ -26,11 +24,12 @@ go = do conn <- connectDatabase
rows1 <- quickQuery' conn "SELECT str FROM album" []
forM_ (zip rows0 rows1) $ \(a, str) -> putStrLn $ "a=" ++ (show a) ++ ", str=" ++ (show str)
- -}
-
+ {-
stmt <- prepare conn "INSERT INTO album VALUES (?, ?)"
n <- execute stmt [SqlWord32 3000000000, SqlString "hello"]
commit conn
+ -}
+
main :: IO ()
main = handleSqlError (replicateM_ 1 go)

0 comments on commit eb6ff9e

Please sign in to comment.