Skip to content

Commit

Permalink
Merge pull request #58 from MasterWordServices/text-2-compat
Browse files Browse the repository at this point in the history
Compatibility with text 2
  • Loading branch information
psibi authored Mar 5, 2024
2 parents 38e0434 + 99ce870 commit 8b9f41f
Show file tree
Hide file tree
Showing 3 changed files with 53 additions and 8 deletions.
3 changes: 2 additions & 1 deletion CHANGELOG
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
0.2.7:
0.3.0:
* Add support for DATETIMEOFFSET
* Add support for text-2.0
0.2.6:
* Add support for SQLSTATE
* Fix copying issues for error messages
Expand Down
2 changes: 1 addition & 1 deletion odbc.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@ description: Haskell binding to the ODBC API. This has been tested
suite runs on OS X, Windows and Linux.
copyright: FP Complete 2018
maintainer: [email protected]
version: 0.2.6
version: 0.3.0
license: BSD3
license-file: LICENSE
build-type: Simple
Expand Down
56 changes: 50 additions & 6 deletions src/Database/ODBC/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}

-- | ODBC database API.
--
Expand Down Expand Up @@ -62,7 +63,14 @@ import Data.Int
import Data.String
import Data.Text (Text)
import qualified Data.Text as T
#if MIN_VERSION_text(2,0,0)
import qualified Data.ByteString.Internal as SI
import qualified Data.Text.Encoding.Error as T
import qualified Data.Text.Encoding as T
#else
import qualified Data.Text.Foreign as T
import Data.Text.Foreign (I16)
#endif
import Data.Time
import Foreign hiding (void)
import Foreign.C
Expand Down Expand Up @@ -399,7 +407,7 @@ withExecDirect dbc string params cont =
(assertSuccessOrNoData
dbc
"odbc_SQLExecDirectW"
(T.useAsPtr
(useAsPtrCompat
string
(\wstring len ->
odbc_SQLExecDirectW
Expand Down Expand Up @@ -449,7 +457,7 @@ withBindParameter dbc parameter_number param cont statement_handle = go param
go =
\case
TextParam text ->
T.useAsPtr -- Pass as wide char UTF-16.
useAsPtrCompat -- Pass as wide char UTF-16.
text
(\ptr len_in_chars ->
runBind
Expand Down Expand Up @@ -588,7 +596,7 @@ fetchStatementRows dbc stmt = do
-- | Describe the given column by its integer index.
describeColumn :: Ptr EnvAndDbc -> SQLHSTMT s -> Int16 -> IO Column
describeColumn dbPtr stmt i =
T.useAsPtr
useAsPtrCompat
(T.replicate 1000 (fromString "0"))
(\namep namelen ->
(withMalloc
Expand Down Expand Up @@ -619,7 +627,7 @@ describeColumn dbPtr stmt i =
digits <- peek digitsp
isnull <- peek nullp
namelen' <- peek namelenp
name <- T.fromPtr namep (fromIntegral namelen')
name <- fromPtrCompat namep (fromIntegral namelen')
evaluate
Column
{ columnType = typ
Expand Down Expand Up @@ -931,12 +939,13 @@ getBinaryData dbc stmt column = do
-- | Get the column's data as a text string.
getTextData :: Ptr EnvAndDbc -> SQLHSTMT s -> SQLUSMALLINT -> IO Value
getTextData dbc stmt column = do
-- We need to fetch as UTF-16LE (see callsite), then convert to Text
mavailableChars <- getSize dbc stmt sql_c_wchar column
case mavailableChars of
Just 0 -> pure (TextValue mempty)
Nothing -> pure NullValue
Just availableBytes -> do
let allocBytes = availableBytes + 2
let allocBytes = availableBytes + 2 -- room for NULL
withMallocBytes
(fromIntegral allocBytes)
(\bufferp -> do
Expand All @@ -948,7 +957,7 @@ getTextData dbc stmt column = do
column
(coerce bufferp)
(SQLLEN (fromIntegral allocBytes)))
t <- T.fromPtr bufferp (fromIntegral (div availableBytes 2))
t <- fromPtrCompat bufferp (fromIntegral (div availableBytes 2))
let !v = TextValue t
pure v)

Expand Down Expand Up @@ -1434,3 +1443,38 @@ sql_c_time = coerce sql_time
-- <https://docs.rs/odbc-sys/0.6.3/odbc_sys/constant.SQL_SS_LENGTH_UNLIMITED.html>
sql_ss_length_unlimited :: SQLULEN
sql_ss_length_unlimited = 0


#if MIN_VERSION_text(2,0,0)
type I16 = Int
#endif

-- FIXME fail with Randomized with seed 1862667972
-- (on 9.2 as well)

-------- 'T.fromPtr' but compatible with text v1 and v2

fromPtrCompat :: Ptr Word16 -> I16 -> IO Text
#if MIN_VERSION_text(2,0,0)
fromPtrCompat bufferp len16 = do
let lenBytes = len16 * 2
noFinalizer = return () -- N.B. inner bufferp is 'free'd after this withMallocBytes block
-- invariant: this does no additional allocation
tempBS <- S.unsafePackCStringFinalizer (castPtr bufferp) lenBytes noFinalizer
-- invariant: this makes a copy:
return $! T.decodeUtf16LEWith T.strictDecode tempBS
#else
fromPtrCompat = T.fromPtr
#endif

useAsPtrCompat :: Text -> (Ptr Word16 -> I16 -> IO a) -> IO a
#if MIN_VERSION_text(2,0,0)
useAsPtrCompat t cont16 = do
let (fp8, len8) = SI.toForeignPtr0 $ T.encodeUtf16LE t
fp16 = castForeignPtr fp8
len16 = len8 `div` 2
withForeignPtr fp16 $ \p16 ->
cont16 p16 (fromIntegral len16)
#else
useAsPtrCompat = T.useAsPtr
#endif

0 comments on commit 8b9f41f

Please sign in to comment.