diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -1,4 +1,4 @@ -Copyright (C) 2005-2008 John Goerzen +Copyright (C) 2005-2009 John Goerzen This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public diff --git a/Database/HDBC/ODBC/Connection.hsc b/Database/HDBC/ODBC/Connection.hsc --- a/Database/HDBC/ODBC/Connection.hsc +++ b/Database/HDBC/ODBC/Connection.hsc @@ -2,7 +2,7 @@ {-# CFILES hdbc-odbc-helper.c #-} -- Above line for hugs {- -Copyright (C) 2005-2006 John Goerzen +Copyright (C) 2005-2009 John Goerzen This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -38,6 +38,8 @@ import Data.Int import Control.Concurrent.MVar import Control.Monad (when) +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BUTF8 #ifdef mingw32_HOST_OS #include @@ -86,7 +88,7 @@ -} connectODBC :: String -> IO Impl.Connection -connectODBC args = withCStringLen args $ \(cs, cslen) -> +connectODBC args = B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> alloca $ \(penvptr::Ptr (Ptr CEnv)) -> alloca $ \(pdbcptr::Ptr (Ptr CConn)) -> do -- Create the Environment Handle diff --git a/Database/HDBC/ODBC/Statement.hsc b/Database/HDBC/ODBC/Statement.hsc --- a/Database/HDBC/ODBC/Statement.hsc +++ b/Database/HDBC/ODBC/Statement.hsc @@ -39,6 +39,9 @@ import Control.Exception import System.IO import Data.Maybe +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BUTF8 +import qualified Data.ByteString.Unsafe as B l _ = return () --l m = hPutStrLn stderr ("\n" ++ m) @@ -120,7 +123,8 @@ l (show results) return $ map (\x -> fromSql (x !! 2)) results -fdescribetable iconn tablename = withCStringLen tablename $ \(cs, csl) -> +fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ + \(cs, csl) -> do fsthptr <- makesth iconn "fdescribetable" withStmt fsthptr (\sthptr -> simpleSqlColumns sthptr cs (fromIntegral csl) >>= @@ -135,7 +139,8 @@ {- For now, we try to just handle things as simply as possible. FIXME lots of room for improvement here (types, etc). -} fexecute sstate args = withConn (dbo sstate) $ \cconn -> - withCStringLen (squery sstate) $ \(cquery, cqlen) -> + B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ + \(cquery, cqlen) -> alloca $ \(psthptr::Ptr (Ptr CStmt)) -> do l "in fexecute" public_ffinish sstate @@ -216,12 +221,13 @@ return [] x -> do -- Otherwise, we have to allocate RAM, make sure it's -- not freed now, and pass it along... - (csptr, cslen) <- newCStringLen (fromSql x) + (csptr, cslen) <- cstrUtf8BString (fromSql x) do pcslen <- malloc poke pcslen (fromIntegral cslen) rc2 <- sqlBindParameter sthptr (fromIntegral icol) #{const SQL_PARAM_INPUT} - #{const SQL_C_CHAR} coltype colsize decdigits + #{const SQL_C_CHAR} coltype + (if isOK rc1 then colsize else fromIntegral cslen + 1) decdigits csptr (fromIntegral cslen + 1) pcslen if isOK rc2 then do -- We bound it. Make foreignPtrs and return. @@ -244,6 +250,18 @@ of each to see if it's NULL. If it's not, fetch it as text and return that. -} +cstrUtf8BString :: B.ByteString -> IO CStringLen +cstrUtf8BString bs = do + B.unsafeUseAsCStringLen bs $ \(s,len) -> do + res <- mallocBytes (len+1) + -- copy in + copyBytes res s len + -- null terminate + poke (plusPtr res len) (0::CChar) + -- return ptr + return (res, len) + + ffetchrow :: SState -> IO (Maybe [SqlValue]) ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> case stmt of @@ -273,18 +291,19 @@ case len of #{const SQL_NULL_DATA} -> return SqlNull #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL" - len -> do s <- peekCString buf - l $ "col is: " ++ s - return (SqlString s) + len -> do bs <- B.packCString buf + l $ "col is: " ++ show (BUTF8.toString bs) + return (SqlByteString bs) #{const SQL_SUCCESS_WITH_INFO} -> do len <- peek plen allocaBytes (fromIntegral len + 1) $ \buf2 -> do sqlGetData cstmt (fromIntegral icol) #{const SQL_CHAR} buf2 (fromIntegral len + 1) plen >>= checkError "sqlGetData" (StmtHandle cstmt) - s <- liftM2 (++) (peekCString buf) (peekCString buf2) - l $ "col is: " ++ s - return (SqlString s) + bs <- liftM2 (B.append) (B.packCString buf) + (B.packCString buf2) + l $ "col is: " ++ (BUTF8.toString bs) + return (SqlByteString bs) res -> raiseError "sqlGetData" res (StmtHandle cstmt) @@ -299,7 +318,8 @@ do sqlDescribeCol cstmt icol cscolname 127 colnamelp datatypeptr colsizeptr nullPtr nullableptr colnamelen <- peek colnamelp - colname <- peekCStringLen (cscolname, fromIntegral colnamelen) + colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen) + let colname = BUTF8.toString colnamebs datatype <- peek datatypeptr colsize <- peek colsizeptr nullable <- peek nullableptr diff --git a/Database/HDBC/ODBC/Utils.hsc b/Database/HDBC/ODBC/Utils.hsc --- a/Database/HDBC/ODBC/Utils.hsc +++ b/Database/HDBC/ODBC/Utils.hsc @@ -1,5 +1,5 @@ {- -*- mode: haskell; -*- -Copyright (C) 2005 John Goerzen +Copyright (C) 2005-2009 John Goerzen This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public @@ -21,6 +21,7 @@ import Foreign.ForeignPtr import Foreign.Ptr import Data.Int +import Database.HDBC(throwSqlError) import Database.HDBC.Types import Database.HDBC.ODBC.Types import Foreign.C.Types @@ -29,6 +30,8 @@ import Foreign.Marshal.Array import Foreign.Marshal.Alloc import Data.Word +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as BUTF8 #ifdef mingw32_HOST_OS #include @@ -55,9 +58,9 @@ raiseError :: String -> #{type SQLRETURN} -> SqlHandleT -> IO a raiseError msg code cconn = do info <- getdiag ht hp 1 - throwDyn $ SqlError {seState = show (map fst info), - seNativeError = fromIntegral code, - seErrorMsg = msg ++ ": " ++ + throwSqlError $ SqlError {seState = show (map fst info), + seNativeError = fromIntegral code, + seErrorMsg = msg ++ ": " ++ show (map snd info)} where (ht, hp::(Ptr ())) = case cconn of EnvHandle c -> (#{const SQL_HANDLE_ENV}, castPtr c) @@ -74,8 +77,9 @@ else do state <- peekCStringLen (csstate, 5) nat <- peek pnaterr msglen <- peek pmsglen - msg <- peekCStringLen (csmsg, - fromIntegral msglen) + msgbs <- B.packCStringLen (csmsg, + fromIntegral msglen) + let msg = BUTF8.toString msgbs next <- getdiag ht hp (irow + 1) return $ (state, (show nat) ++ ": " ++ msg) : next @@ -108,15 +112,6 @@ withRawEnv :: Env -> (Ptr WrappedCEnv -> IO b) -> IO b withRawEnv = withForeignPtr - -withCStringArr0 :: [SqlValue] -> (Ptr CString -> IO a) -> IO a -withCStringArr0 inp action = withAnyArr0 convfunc freefunc inp action - where convfunc SqlNull = return nullPtr - convfunc x = newCString (fromSql x) - freefunc x = - if x == nullPtr - then return () - else free x withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer -> (Ptr b -> IO ()) -- ^ Function that frees generated data diff --git a/HDBC-odbc.cabal b/HDBC-odbc.cabal --- a/HDBC-odbc.cabal +++ b/HDBC-odbc.cabal @@ -1,11 +1,11 @@ Name: HDBC-odbc -Version: 1.1.6.0 +Version: 2.0.0.0 Cabal-Version: >=1.2.3 Build-type: Simple License: LGPL Maintainer: John Goerzen Author: John Goerzen -Copyright: Copyright (c) 2005-2008 John Goerzen +Copyright: Copyright (c) 2005-2009 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, hdbc-odbc-helper.h homepage: http://software.complete.org/hdbc-odbc @@ -17,6 +17,10 @@ MySQL databases from Haskell. Stability: Beta +Flag buildtests + description: Build the executable to run unit tests + default: False + Library Exposed-Modules: Database.HDBC.ODBC Other-Modules: Database.HDBC.ODBC.Connection, @@ -29,7 +33,7 @@ ExistentialQuantification, ForeignFunctionInterface, PatternSignatures - Build-Depends: base<4, mtl, HDBC>=1.1.0 + Build-Depends: base, mtl, HDBC>=2.0.0, utf8-string, bytestring GHC-Options: -O2 C-Sources: hdbc-odbc-helper.c if os(mingw32) || os(win32) @@ -38,3 +42,38 @@ Extra-Libraries: odbc include-dirs: . -- extra-lib-dirs: + +Executable runtests + if flag(buildtests) + Buildable: True + else + Buildable: False + Build-Depends: HUnit, QuickCheck, testpack, containers, old-time, + time, old-locale, convertible + Main-Is: runtests.hs + Other-Modules: Database.HDBC.ODBC, + Database.HDBC.ODBC.Connection, + Database.HDBC.ODBC.Statement, + Database.HDBC.ODBC.Types, + Database.HDBC.ODBC.Utils, + Database.HDBC.ODBC.TypeConv, + Database.HDBC.ODBC.ConnectionImpl + SpecificDB, + SpecificDBTests, + TestMisc, + TestSbasics, + TestUtils, + Testbasics, + Tests + Hs-Source-Dirs: ., testsrc + C-Sources: hdbc-odbc-helper.c + if os(mingw32) || os(win32) + Extra-Libraries: odbc32 + else + Extra-Libraries: odbc + include-dirs: . + GHC-Options: -O2 + Extensions: + ExistentialQuantification, + ForeignFunctionInterface, + PatternSignatures