packages feed

HDBC-odbc 2.3.1.1 → 2.4.0.0

raw patch · 25 files changed

+2828/−2678 lines, 25 filesdep +HDBC-odbcdep +randomdep +resource-pooldep ~HDBCdep ~basesetup-changednew-component:exe:stresstestnew-uploader

Dependencies added: HDBC-odbc, random, resource-pool

Dependency ranges changed: HDBC, base

Files

Database/HDBC/ODBC.hs view
@@ -1,23 +1,23 @@-{- |-   Module     : Database.HDBC.ODBC-   Copyright  : Copyright (C) 2005 John Goerzen-   License    : BSD3--   Maintainer : John Goerzen <jgoerzen@complete.org>-   Stability  : provisional-   Portability: portable--HDBC driver interface for ODBC 3.x--Written by John Goerzen, jgoerzen\@complete.org--}--module Database.HDBC.ODBC-    (-     connectODBC, Connection(), getQueryInfo-    )--where--import Database.HDBC.ODBC.Connection(connectODBC, Connection())-import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo)+{- |
+   Module     : Database.HDBC.ODBC
+   Copyright  : Copyright (C) 2005 John Goerzen
+   License    : BSD3
+
+   Maintainer : John Goerzen <jgoerzen@complete.org>
+   Stability  : provisional
+   Portability: portable
+
+HDBC driver interface for ODBC 3.x
+
+Written by John Goerzen, jgoerzen\@complete.org
+-}
+
+module Database.HDBC.ODBC
+    (
+     connectODBC, Connection(), getQueryInfo
+    )
+
+where
+
+import Database.HDBC.ODBC.Connection(connectODBC, Connection())
+import Database.HDBC.ODBC.ConnectionImpl(getQueryInfo)
Database/HDBC/ODBC/Connection.hsc view
@@ -1,228 +1,228 @@--- -*- mode: haskell; -*--{-# CFILES hdbc-odbc-helper.c #-}--- Above line for hugs--module Database.HDBC.ODBC.Connection (connectODBC, Impl.Connection) where--import Database.HDBC.Types-import Database.HDBC-import Database.HDBC.DriverUtils-import qualified Database.HDBC.ODBC.ConnectionImpl as Impl-import Database.HDBC.ODBC.Types-import Database.HDBC.ODBC.Statement-import Foreign.C.Types-import Foreign.C.String-import Foreign.Marshal-import Foreign.Storable-import Database.HDBC.ODBC.Utils-import Foreign.ForeignPtr-import Foreign.Ptr-import Data.Word-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 <windows.h>-#endif-#include <sql.h>-#include <sqlext.h>--#ifdef mingw32_HOST_OS-#let CALLCONV = "stdcall"-#else-#let CALLCONV = "ccall"-#endif--{- | Connect to an ODBC server.--For information on the meaning of the passed string, please see:--<http://msdn2.microsoft.com/en-us/library/ms715433(VS.85).aspx>--An example string is:-->"DSN=hdbctest1"--This, and all other functions that use ODBC directly or indirectly, can raise-SqlErrors just like other HDBC backends.  The seErrorMsg field is specified-as a String in HDBC.  ODBC specifies this data as a list of strings.-Therefore, this driver uses show on the data from ODBC.  For friendly display,-or handling of individual component messages in your code, you can use -read on the seErrorMsg field in a context that expects @[String]@.--Important note for MySQL users:--Unless you are going to use InnoDB tables, you are strongly encouraged to set-->Option = 262144--in your odbc.ini (for Unix users), or to disable transaction support in your-DSN setup for Windows users.--If you fail to do this, the MySQL ODBC driver will incorrectly state that it-supports transactions.  dbTransactionSupport will incorrectly return True.-commit and rollback will then silently fail.  This is certainly /NOT/ what you-want.  It is a bug (or misfeature) in the MySQL driver, not in HDBC.--You should ignore this advice if you are using InnoDB tables.---}-connectODBC :: String -> IO Impl.Connection-connectODBC args = B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> -                   alloca $ \(penvptr::Ptr (Ptr CEnv)) ->-                   alloca $ \(pdbcptr::Ptr (Ptr CConn)) ->-         do -- Create the Environment Handle-            rc1 <- sqlAllocHandle #{const SQL_HANDLE_ENV}-                                  nullPtr  -- {const SQL_NULL_HANDLE}-                                   (castPtr penvptr)-            envptr <- peek penvptr --            checkError "connectODBC/alloc env" (EnvHandle envptr) rc1-            sqlSetEnvAttr envptr #{const SQL_ATTR_ODBC_VERSION}-                             (getSqlOvOdbc3) 0--            -- Create the DBC handle.-            sqlAllocHandle #{const SQL_HANDLE_DBC} (castPtr envptr) -                               (castPtr pdbcptr)-                          >>= checkError "connectODBC/alloc dbc"-                                  (EnvHandle envptr)-            dbcptr <- peek pdbcptr-            wrappeddbcptr <- wrapconn dbcptr envptr nullPtr-            fdbcptr <- newForeignPtr sqlFreeHandleDbc_ptr wrappeddbcptr--            -- Now connect.-            sqlDriverConnect dbcptr nullPtr cs (fromIntegral cslen)-                             nullPtr 0 nullPtr-                             #{const SQL_DRIVER_NOPROMPT}-                              >>= checkError "connectODBC/sqlDriverConnect" -                                  (DbcHandle dbcptr)-            mkConn args fdbcptr---- FIXME: environment vars may have changed, should use pgsql enquiries--- for clone.-mkConn :: String -> Conn -> IO Impl.Connection-mkConn args iconn = withConn iconn $ \cconn -> -                    alloca $ \plen ->-                    alloca $ \psqlusmallint ->-                    allocaBytes 128 $ \pbuf -> -    do -       children <- newMVar []-       sqlGetInfo cconn #{const SQL_DBMS_VER} (castPtr pbuf) 127 plen-         >>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn)-       len <- peek plen-       serverver <- peekCStringLen (pbuf, fromIntegral len)--       sqlGetInfo cconn #{const SQL_DRIVER_VER} (castPtr pbuf) 127 plen-         >>= checkError "sqlGetInfo SQL_DRIVER_VER" (DbcHandle cconn)-       len <- peek plen-       proxiedclientver <- peekCStringLen (pbuf, fromIntegral len)--       sqlGetInfo cconn #{const SQL_ODBC_VER} (castPtr pbuf) 127 plen-         >>= checkError "sqlGetInfo SQL_ODBC_VER" (DbcHandle cconn)-       len <- peek plen-       clientver <- peekCStringLen (pbuf, fromIntegral len)--       sqlGetInfo cconn #{const SQL_DBMS_NAME} (castPtr pbuf) 127 plen-         >>= checkError "sqlGetInfo SQL_DBMS_NAME" (DbcHandle cconn)-       len <- peek plen-       clientname <- peekCStringLen (pbuf, fromIntegral len)--       sqlGetInfo cconn #{const SQL_TXN_CAPABLE} (castPtr psqlusmallint)-                      0 nullPtr-         >>= checkError "sqlGetInfo SQL_TXN_CAPABLE" (DbcHandle cconn)-       txninfo <- ((peek psqlusmallint)::IO (#{type SQLUSMALLINT}))-       let txnsupport = txninfo /= #{const SQL_TC_NONE}--       when txnsupport-         (disableAutoCommit cconn-          >>= checkError "sqlSetConnectAttr" (DbcHandle cconn)-         )-       return $ Impl.Connection {-                            Impl.getQueryInfo = fGetQueryInfo iconn children,-                            Impl.disconnect = fdisconnect iconn children,-                            Impl.commit = fcommit iconn,-                            Impl.rollback = frollback iconn,-                            Impl.run = frun iconn children,-                            Impl.prepare = newSth iconn children,-                            Impl.clone = connectODBC args,-                            -- FIXME: add clone-                            Impl.hdbcDriverName = "odbc",-                            Impl.hdbcClientVer = clientver,-                            Impl.proxiedClientName = clientname,-                            Impl.proxiedClientVer = proxiedclientver,-                            Impl.dbServerVer = serverver,-                            Impl.dbTransactionSupport = txnsupport,-                            Impl.getTables = fgettables iconn,-                            Impl.describeTable = fdescribetable iconn-                           }------------------------------------------------------- Guts here-----------------------------------------------------frun conn children query args =-    do sth <- newSth conn children query-       res <- execute sth args-       finish sth-       return res--fcommit iconn = withConn iconn $ \cconn ->-    sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_COMMIT}-    >>= checkError "sqlEndTran commit" (DbcHandle cconn)--frollback iconn = withConn iconn $ \cconn ->-    sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_ROLLBACK}-    >>= checkError "sqlEndTran rollback" (DbcHandle cconn)--fdisconnect iconn mchildren  = withRawConn iconn $ \rawconn -> -                               withConn iconn $ \llconn ->-    do closeAllChildren mchildren-       res <- sqlFreeHandleDbc_app rawconn-       -- FIXME: will this checkError segfault?-       checkError "disconnect" (DbcHandle $ llconn) res--foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"-  sqlAllocHandle :: #{type SQLSMALLINT} -> Ptr () -> -                    Ptr () -> IO (#{type SQLRETURN})--foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc_extra"-  wrapconn :: Ptr CConn -> Ptr CEnv -> Ptr WrappedCConn -> IO (Ptr WrappedCConn)--foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleDbc_finalizer"-  sqlFreeHandleDbc_ptr :: FunPtr (Ptr WrappedCConn -> IO ())--foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleDbc_app"-  sqlFreeHandleDbc_app :: Ptr WrappedCConn -> IO (#{type SQLRETURN})--foreign import #{CALLCONV} safe "sql.h SQLSetEnvAttr"-  sqlSetEnvAttr :: Ptr CEnv -> #{type SQLINTEGER} -> -                   Ptr () -> #{type SQLINTEGER} -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLDriverConnect"-  sqlDriverConnect :: Ptr CConn -> Ptr () -> CString -> #{type SQLSMALLINT}-                   -> CString -> #{type SQLSMALLINT}-                   -> Ptr #{type SQLSMALLINT} -> #{type SQLUSMALLINT}-                   -> IO #{type SQLRETURN}--foreign import ccall safe "hdbc-odbc-helper.h getSqlOvOdbc3"-  getSqlOvOdbc3 :: Ptr ()--foreign import ccall safe "hdbc-odbc-helper.h SQLSetConnectAttr"-  sqlSetConnectAttr :: Ptr CConn -> #{type SQLINTEGER} -                    -> Ptr #{type SQLUINTEGER} -> #{type SQLINTEGER}-                    -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLEndTran"-  sqlEndTran :: #{type SQLSMALLINT} -> Ptr CConn -> #{type SQLSMALLINT}-             -> IO #{type SQLRETURN}--foreign import ccall safe "hdbc-odbc-helper.h disableAutoCommit"-  disableAutoCommit :: Ptr CConn -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLGetInfo"-  sqlGetInfo :: Ptr CConn -> #{type SQLUSMALLINT} -> Ptr () ->-                #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} ->-                IO #{type SQLRETURN}+-- -*- mode: haskell; -*-
+{-# CFILES hdbc-odbc-helper.c #-}
+-- Above line for hugs
+
+module Database.HDBC.ODBC.Connection (connectODBC, Impl.Connection) where
+
+import Database.HDBC.Types
+import Database.HDBC
+import Database.HDBC.DriverUtils
+import qualified Database.HDBC.ODBC.ConnectionImpl as Impl
+import Database.HDBC.ODBC.Types
+import Database.HDBC.ODBC.Statement
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Marshal
+import Foreign.Storable
+import Database.HDBC.ODBC.Utils
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Data.Word
+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 <windows.h>
+#endif
+#include <sql.h>
+#include <sqlext.h>
+
+#ifdef mingw32_HOST_OS
+#let CALLCONV = "stdcall"
+#else
+#let CALLCONV = "ccall"
+#endif
+
+{- | Connect to an ODBC server.
+
+For information on the meaning of the passed string, please see:
+
+<http://msdn2.microsoft.com/en-us/library/ms715433(VS.85).aspx>
+
+An example string is:
+
+>"DSN=hdbctest1"
+
+This, and all other functions that use ODBC directly or indirectly, can raise
+SqlErrors just like other HDBC backends.  The seErrorMsg field is specified
+as a String in HDBC.  ODBC specifies this data as a list of strings.
+Therefore, this driver uses show on the data from ODBC.  For friendly display,
+or handling of individual component messages in your code, you can use 
+read on the seErrorMsg field in a context that expects @[String]@.
+
+Important note for MySQL users:
+
+Unless you are going to use InnoDB tables, you are strongly encouraged to set
+
+>Option = 262144
+
+in your odbc.ini (for Unix users), or to disable transaction support in your
+DSN setup for Windows users.
+
+If you fail to do this, the MySQL ODBC driver will incorrectly state that it
+supports transactions.  dbTransactionSupport will incorrectly return True.
+commit and rollback will then silently fail.  This is certainly /NOT/ what you
+want.  It is a bug (or misfeature) in the MySQL driver, not in HDBC.
+
+You should ignore this advice if you are using InnoDB tables.
+
+-}
+connectODBC :: String -> IO Impl.Connection
+connectODBC args = B.useAsCStringLen (BUTF8.fromString args) $ \(cs, cslen) -> 
+                   alloca $ \(penvptr::Ptr (Ptr CEnv)) ->
+                   alloca $ \(pdbcptr::Ptr (Ptr CConn)) ->
+         do -- Create the Environment Handle
+            rc1 <- sqlAllocHandle #{const SQL_HANDLE_ENV}
+                                  nullPtr  -- {const SQL_NULL_HANDLE}
+                                   (castPtr penvptr)
+            envptr <- peek penvptr 
+
+            checkError "connectODBC/alloc env" (EnvHandle envptr) rc1
+            sqlSetEnvAttr envptr #{const SQL_ATTR_ODBC_VERSION}
+                             (getSqlOvOdbc3) 0
+
+            -- Create the DBC handle.
+            sqlAllocHandle #{const SQL_HANDLE_DBC} (castPtr envptr) 
+                               (castPtr pdbcptr)
+                          >>= checkError "connectODBC/alloc dbc"
+                                  (EnvHandle envptr)
+            dbcptr <- peek pdbcptr
+            wrappeddbcptr <- wrapconn dbcptr envptr nullPtr
+            fdbcptr <- newForeignPtr sqlFreeHandleDbc_ptr wrappeddbcptr
+
+            -- Now connect.
+            sqlDriverConnect dbcptr nullPtr cs (fromIntegral cslen)
+                             nullPtr 0 nullPtr
+                             #{const SQL_DRIVER_NOPROMPT}
+                              >>= checkError "connectODBC/sqlDriverConnect" 
+                                  (DbcHandle dbcptr)
+            mkConn args fdbcptr
+
+-- FIXME: environment vars may have changed, should use pgsql enquiries
+-- for clone.
+mkConn :: String -> Conn -> IO Impl.Connection
+mkConn args iconn = withConn iconn $ \cconn -> 
+                    alloca $ \plen ->
+                    alloca $ \psqlusmallint ->
+                    allocaBytes 128 $ \pbuf -> 
+    do 
+       children <- newMVar []
+       sqlGetInfo cconn #{const SQL_DBMS_VER} (castPtr pbuf) 127 plen
+         >>= checkError "sqlGetInfo SQL_DBMS_VER" (DbcHandle cconn)
+       len <- peek plen
+       serverver <- peekCStringLen (pbuf, fromIntegral len)
+
+       sqlGetInfo cconn #{const SQL_DRIVER_VER} (castPtr pbuf) 127 plen
+         >>= checkError "sqlGetInfo SQL_DRIVER_VER" (DbcHandle cconn)
+       len <- peek plen
+       proxiedclientver <- peekCStringLen (pbuf, fromIntegral len)
+
+       sqlGetInfo cconn #{const SQL_ODBC_VER} (castPtr pbuf) 127 plen
+         >>= checkError "sqlGetInfo SQL_ODBC_VER" (DbcHandle cconn)
+       len <- peek plen
+       clientver <- peekCStringLen (pbuf, fromIntegral len)
+
+       sqlGetInfo cconn #{const SQL_DBMS_NAME} (castPtr pbuf) 127 plen
+         >>= checkError "sqlGetInfo SQL_DBMS_NAME" (DbcHandle cconn)
+       len <- peek plen
+       clientname <- peekCStringLen (pbuf, fromIntegral len)
+
+       sqlGetInfo cconn #{const SQL_TXN_CAPABLE} (castPtr psqlusmallint)
+                      0 nullPtr
+         >>= checkError "sqlGetInfo SQL_TXN_CAPABLE" (DbcHandle cconn)
+       txninfo <- ((peek psqlusmallint)::IO (#{type SQLUSMALLINT}))
+       let txnsupport = txninfo /= #{const SQL_TC_NONE}
+
+       when txnsupport
+         (disableAutoCommit cconn
+          >>= checkError "sqlSetConnectAttr" (DbcHandle cconn)
+         )
+       return $ Impl.Connection {
+                            Impl.getQueryInfo = fGetQueryInfo iconn children,
+                            Impl.disconnect = fdisconnect iconn children,
+                            Impl.commit = fcommit iconn,
+                            Impl.rollback = frollback iconn,
+                            Impl.run = frun iconn children,
+                            Impl.prepare = newSth iconn children,
+                            Impl.clone = connectODBC args,
+                            -- FIXME: add clone
+                            Impl.hdbcDriverName = "odbc",
+                            Impl.hdbcClientVer = clientver,
+                            Impl.proxiedClientName = clientname,
+                            Impl.proxiedClientVer = proxiedclientver,
+                            Impl.dbServerVer = serverver,
+                            Impl.dbTransactionSupport = txnsupport,
+                            Impl.getTables = fgettables iconn,
+                            Impl.describeTable = fdescribetable iconn
+                           }
+
+--------------------------------------------------
+-- Guts here
+--------------------------------------------------
+
+frun conn children query args =
+    do sth <- newSth conn children query
+       res <- execute sth args
+       finish sth
+       return res
+
+fcommit iconn = withConn iconn $ \cconn ->
+    sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_COMMIT}
+    >>= checkError "sqlEndTran commit" (DbcHandle cconn)
+
+frollback iconn = withConn iconn $ \cconn ->
+    sqlEndTran #{const SQL_HANDLE_DBC} cconn #{const SQL_ROLLBACK}
+    >>= checkError "sqlEndTran rollback" (DbcHandle cconn)
+
+fdisconnect iconn mchildren  = withRawConn iconn $ \rawconn -> 
+                               withConn iconn $ \llconn ->
+    do closeAllChildren mchildren
+       res <- sqlFreeHandleDbc_app rawconn
+       -- FIXME: will this checkError segfault?
+       checkError "disconnect" (DbcHandle $ llconn) res
+
+foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"
+  sqlAllocHandle :: #{type SQLSMALLINT} -> Ptr () -> 
+                    Ptr () -> IO (#{type SQLRETURN})
+
+foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc_extra"
+  wrapconn :: Ptr CConn -> Ptr CEnv -> Ptr WrappedCConn -> IO (Ptr WrappedCConn)
+
+foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleDbc_finalizer"
+  sqlFreeHandleDbc_ptr :: FunPtr (Ptr WrappedCConn -> IO ())
+
+foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleDbc_app"
+  sqlFreeHandleDbc_app :: Ptr WrappedCConn -> IO (#{type SQLRETURN})
+
+foreign import #{CALLCONV} safe "sql.h SQLSetEnvAttr"
+  sqlSetEnvAttr :: Ptr CEnv -> #{type SQLINTEGER} -> 
+                   Ptr () -> #{type SQLINTEGER} -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLDriverConnect"
+  sqlDriverConnect :: Ptr CConn -> Ptr () -> CString -> #{type SQLSMALLINT}
+                   -> CString -> #{type SQLSMALLINT}
+                   -> Ptr #{type SQLSMALLINT} -> #{type SQLUSMALLINT}
+                   -> IO #{type SQLRETURN}
+
+foreign import ccall safe "hdbc-odbc-helper.h getSqlOvOdbc3"
+  getSqlOvOdbc3 :: Ptr ()
+
+foreign import ccall safe "hdbc-odbc-helper.h SQLSetConnectAttr"
+  sqlSetConnectAttr :: Ptr CConn -> #{type SQLINTEGER} 
+                    -> Ptr #{type SQLUINTEGER} -> #{type SQLINTEGER}
+                    -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLEndTran"
+  sqlEndTran :: #{type SQLSMALLINT} -> Ptr CConn -> #{type SQLSMALLINT}
+             -> IO #{type SQLRETURN}
+
+foreign import ccall safe "hdbc-odbc-helper.h disableAutoCommit"
+  disableAutoCommit :: Ptr CConn -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLGetInfo"
+  sqlGetInfo :: Ptr CConn -> #{type SQLUSMALLINT} -> Ptr () ->
+                #{type SQLSMALLINT} -> Ptr #{type SQLSMALLINT} ->
+                IO #{type SQLRETURN}
Database/HDBC/ODBC/ConnectionImpl.hs view
@@ -1,40 +1,40 @@-module Database.HDBC.ODBC.ConnectionImpl where--import qualified Database.HDBC.Statement as Types-import qualified Database.HDBC.Types as Types-import Database.HDBC.ColTypes as ColTypes--data Connection = -    Connection {-                getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]),-                disconnect :: IO (),-                commit :: IO (),-                rollback :: IO (),-                run :: String -> [Types.SqlValue] -> IO Integer,-                prepare :: String -> IO Types.Statement,-                clone :: IO Connection,-                hdbcDriverName :: String,-                hdbcClientVer :: String,-                proxiedClientName :: String,-                proxiedClientVer :: String,-                dbServerVer :: String,-                dbTransactionSupport :: Bool,-                getTables :: IO [String],-                describeTable :: String -> IO [(String, ColTypes.SqlColDesc)]-               }--instance Types.IConnection Connection where-  disconnect = disconnect-  commit = commit-  rollback = rollback-  run = run-  prepare = prepare-  clone = clone-  hdbcDriverName = hdbcDriverName-  hdbcClientVer = hdbcClientVer-  proxiedClientName = proxiedClientName-  proxiedClientVer = proxiedClientVer-  dbServerVer = dbServerVer-  dbTransactionSupport = dbTransactionSupport-  getTables = getTables-  describeTable = describeTable+module Database.HDBC.ODBC.ConnectionImpl where
+
+import qualified Database.HDBC.Statement as Types
+import qualified Database.HDBC.Types as Types
+import Database.HDBC.ColTypes as ColTypes
+
+data Connection = 
+    Connection {
+                getQueryInfo :: String -> IO ([SqlColDesc], [(String, SqlColDesc)]),
+                disconnect :: IO (),
+                commit :: IO (),
+                rollback :: IO (),
+                run :: String -> [Types.SqlValue] -> IO Integer,
+                prepare :: String -> IO Types.Statement,
+                clone :: IO Connection,
+                hdbcDriverName :: String,
+                hdbcClientVer :: String,
+                proxiedClientName :: String,
+                proxiedClientVer :: String,
+                dbServerVer :: String,
+                dbTransactionSupport :: Bool,
+                getTables :: IO [String],
+                describeTable :: String -> IO [(String, ColTypes.SqlColDesc)]
+               }
+
+instance Types.IConnection Connection where
+  disconnect = disconnect
+  commit = commit
+  rollback = rollback
+  run = run
+  prepare = prepare
+  clone = clone
+  hdbcDriverName = hdbcDriverName
+  hdbcClientVer = hdbcClientVer
+  proxiedClientName = proxiedClientName
+  proxiedClientVer = proxiedClientVer
+  dbServerVer = dbServerVer
+  dbTransactionSupport = dbTransactionSupport
+  getTables = getTables
+  describeTable = describeTable
Database/HDBC/ODBC/Statement.hsc view
@@ -1,1012 +1,1062 @@--- -*- mode: haskell; -*--{-# CFILES hdbc-odbc-helper.c #-}--- Above line for hugs-{-# LANGUAGE EmptyDataDecls #-}--module Database.HDBC.ODBC.Statement (-   fGetQueryInfo,-   newSth,-   fgettables,-   fdescribetable- ) where--import Database.HDBC.Types-import Database.HDBC-import Database.HDBC.DriverUtils-import Database.HDBC.ODBC.Types-import Database.HDBC.ODBC.Utils-import Database.HDBC.ODBC.TypeConv--import Foreign.C.String (castCUCharToChar)-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import Control.Concurrent.MVar-import Foreign.C.String-import Foreign.Marshal-import Foreign.Storable-import Control.Monad-import Data.Word-import Data.Time.Calendar (fromGregorian)-import Data.Time.LocalTime (TimeOfDay(TimeOfDay), LocalTime(LocalTime))-import Data.Int-import Data.Maybe (catMaybes, fromMaybe)-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as BUTF8-import qualified Data.ByteString.Unsafe as B-import Unsafe.Coerce (unsafeCoerce)--import System.IO (hPutStrLn, stderr)-import Debug.Trace--l :: String -> IO ()-l _ = return ()--- l m = hPutStrLn stderr ("\n" ++ m)--#ifdef mingw32_HOST_OS-#include <windows.h>-#endif-#include <sql.h>-#include <sqlext.h>--#ifdef mingw32_HOST_OS-#let CALLCONV = "stdcall"-#else-#let CALLCONV = "ccall"-#endif--fGetQueryInfo :: Conn -> ChildList -> String-              -> IO ([SqlColDesc], [(String, SqlColDesc)])-fGetQueryInfo iconn children query =-    do l "in fGetQueryInfo"-       sstate <- newSState iconn query-       addChild children (wrapStmt sstate)   -- We get error if we forget this one. Not sure why.-       fakeExecute' sstate--fakeExecute' :: SState -> IO ([SqlColDesc], [(String, SqlColDesc)])-fakeExecute' sstate  = withConn (dbo sstate) $ \cconn ->-                       withCStringLen (squery sstate) $ \(cquery, cqlen) ->-                       alloca $ \(psthptr::Ptr (Ptr CStmt)) ->-    do l "in fexecute"-       -- public_ffinish sstate  -       rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr-       sthptr <- peek psthptr-       wrappedsthptr <- withRawConn (dbo sstate)-                        (\rawconn -> wrapstmt sthptr rawconn)-       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr-       checkError "execute allocHandle" (DbcHandle cconn) rc1--       sqlPrepare sthptr cquery (fromIntegral cqlen) >>= -            checkError "execute prepare" (StmtHandle sthptr)--       -- parmCount <- getNumParams sthptr-       parmInfo <- fgetparminfo sthptr-       -       -- rc <- getNumResultCols sthptr-       colInfo <- fgetcolinfo sthptr-       return (parmInfo, colInfo)---- | The Stament State-data SState = SState-  { stomv      :: MVar (Maybe Stmt)-  , dbo        :: Conn-  , squery     :: String-  , colinfomv  :: MVar [(String, SqlColDesc)]-  , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})])-  }---- FIXME: we currently do no prepare optimization whatsoever.--newSState :: Conn -> String -> IO SState-newSState indbo query =-    do newstomv     <- newMVar Nothing-       newcolinfomv <- newMVar []-       newBindCols  <- newMVar Nothing-       return SState-         { stomv      = newstomv-         , dbo        = indbo-         , squery     = query-         , colinfomv  = newcolinfomv-         , bindColsMV = newBindCols-         }--wrapStmt :: SState -> Statement-wrapStmt sstate = Statement-  { execute        = fexecute sstate-  , executeRaw     = return ()-  , executeMany    = fexecutemany sstate-  , finish         = public_ffinish sstate-  , fetchRow       = ffetchrow sstate-  , originalQuery  = (squery sstate)-  , getColumnNames = readMVar (colinfomv sstate) >>= (return . map fst)-  , describeResult = readMVar (colinfomv sstate)-  }--newSth :: Conn -> ChildList -> String -> IO Statement-newSth indbo mchildren query =-    do l "in newSth"-       sstate <- newSState indbo query-       let retval = wrapStmt sstate-       addChild mchildren retval-       return retval--makesth :: Conn -> [Char] -> IO (ForeignPtr WrappedCStmt)-makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) ->-                     withConn iconn $ \cconn -> -                     withCString "" $ \emptycs ->-    do rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr-       sthptr <- peek psthptr-       wrappedsthptr <- withRawConn iconn-                        (\rawconn -> wrapstmt sthptr rawconn)-       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr-       checkError (name ++ " allocHandle") (DbcHandle cconn) rc1-       return fsthptr--wrapTheStmt :: Conn -> Stmt -> IO (Statement, SState)-wrapTheStmt iconn fsthptr =-    do sstate <- newSState iconn ""-       sstate <- newSState iconn ""-       swapMVar (stomv sstate) (Just fsthptr)-       let sth = wrapStmt sstate-       return (sth, sstate)--fgettables :: Conn -> IO [String]-fgettables iconn =-    do fsthptr <- makesth iconn "fgettables"-       l "fgettables: after makesth"-       withStmt fsthptr (\sthptr ->-                             simpleSqlTables sthptr >>=-                                checkError "gettables simpleSqlTables" -                                               (StmtHandle sthptr)-                        )-       l "fgettables: after withStmt"-       (sth, sstate) <- wrapTheStmt iconn fsthptr-       withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))-       l "fgettables: after wrapTheStmt"-       results <- fetchAllRows' sth-       l ("fgettables: results: " ++ (show results))-       return $ map (\x -> fromSql (x !! 2)) results--fdescribetable :: Conn -> String -> IO [(String, SqlColDesc)]-fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ -                                 \(cs, csl) ->-    do fsthptr <- makesth iconn "fdescribetable"-       withStmt fsthptr (\sthptr ->-                             simpleSqlColumns sthptr cs (fromIntegral csl) >>=-                               checkError "fdescribetable simpleSqlColumns"-                                          (StmtHandle sthptr)-                        )-       (sth, sstate) <- wrapTheStmt iconn fsthptr-       withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))-       results <- fetchAllRows' sth-       l (show results)-       return $ map fromOTypeCol results--{- For now, we try to just  handle things as simply as possible.-FIXME lots of room for improvement here (types, etc). -}-fexecute :: SState -> [SqlValue] -> IO Integer-fexecute sstate args =-  withConn (dbo sstate) $ \cconn ->-  B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) ->-  alloca $ \(psthptr::Ptr (Ptr CStmt)) ->-    do l $ "in fexecute: " ++ show (squery sstate) ++ show args-       public_ffinish sstate-       rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr-       sthptr <- peek psthptr-       wrappedsthptr <- withRawConn (dbo sstate)-                        (\rawconn -> wrapstmt sthptr rawconn)-       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr-       checkError "execute allocHandle" (DbcHandle cconn) rc1--       sqlPrepare sthptr cquery (fromIntegral cqlen) >>= -            checkError "execute prepare" (StmtHandle sthptr)--       bindArgs <- zipWithM (bindParam sthptr) args [1..]-       l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args-       r <- sqlExecute sthptr-       mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs)--       case r of-         #{const SQL_NO_DATA} -> return () -- Update that did nothing-         x -> checkError "execute execute" (StmtHandle sthptr) x--       rc <- getNumResultCols sthptr--       case rc of-         0 -> do rowcount <- getSqlRowCount sthptr-                 ffinish fsthptr-                 swapMVar (colinfomv sstate) []-                 touchForeignPtr fsthptr-                 return (fromIntegral rowcount)-         colcount -> do fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)-                        swapMVar (stomv sstate) (Just fsthptr)-                        touchForeignPtr fsthptr-                        return 0--getNumResultCols :: Ptr CStmt -> IO #{type SQLSMALLINT}-getNumResultCols sthptr = alloca $ \pcount ->-    do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" -                                          (StmtHandle sthptr)-       peek pcount---- Bind a parameter column before execution.-bindParam :: Ptr CStmt -> SqlValue -> Word16-        -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar))-bindParam sthptr arg icol =  alloca $ \pdtype ->-                           alloca $ \pcolsize ->-                           alloca $ \pdecdigits ->-                           alloca $ \pnullable ->-{- We have to start by getting the SQL type of the column so we can-   send the correct type back to the server.  Sigh.  If the ODBC-   backend won't tell us the type, we fake it.--   We've got an annoying situation with error handling.  Must make-   sure that all data is freed, but if there's an error, we have to raise-   it and the caller never gets to freed the allocated data to-date.-   So, make sure we either free of have foreignized everything before-   control passes out of this function. -}--    do l $ "Binding col " ++ show icol ++ ": " ++ show arg-       rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable-       l $ "rc1 is " ++ show (isOK rc1)-       when (not (isOK rc1)) $ -- Some drivers don't support that call-          do poke pdtype #{const SQL_CHAR}-             poke pcolsize 0-             poke pdecdigits 0-       coltype <- peek pdtype-       colsize <- peek pcolsize-       decdigits <- peek pdecdigits-       l $ "Results: " ++ show (coltype, colsize, decdigits)-       case arg of-         SqlNull -> -- NULL parameter, bind it as such.-                    do l "Binding null"-                       rc2 <- sqlBindParameter sthptr (fromIntegral icol)-                              #{const SQL_PARAM_INPUT}-                              #{const SQL_C_CHAR} coltype colsize decdigits-                              nullPtr 0 nullDataHDBC-                       checkError ("bindparameter NULL " ++ show icol)-                                      (StmtHandle sthptr) rc2-                       return Nothing-         x -> do -- Otherwise, we have to allocate RAM, make sure it's-                 -- not freed now, and pass it along...-                  (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 -                       (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.-                                return $ Just (pcslen, csptr)-                        else do -- Binding failed.  Free the data and raise-                                -- error.-                                free pcslen-                                free csptr-                                checkError ("bindparameter " ++ show icol) -                                               (StmtHandle sthptr) rc2-                                return Nothing -- will never get hit--getSqlRowCount :: Ptr CStmt -> IO Int32-getSqlRowCount cstmt = alloca $ \prows ->-     do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt)-        peek prows-        --note: As of ODBC-3.52, the row count is only a C int, ie 32bit.---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 -> do-  l $ "ffetchrow"-  case stmt of-    Nothing -> do-      l "ffetchrow: no statement"-      return (stmt, Nothing)-    Just cmstmt -> withStmt cmstmt $ \cstmt -> do-      bindCols <- getBindCols sstate cstmt-      l "ffetchrow: fetching"-      rc <- sqlFetch cstmt-      if rc == #{const SQL_NO_DATA}-        then do-          l "ffetchrow: no more rows"-          ffinish cmstmt-          return (Nothing, Nothing)-        else do-          l "ffetchrow: fetching data"-          checkError "sqlFetch" (StmtHandle cstmt) rc-          sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO}-            then mapM (bindColToSqlValue cstmt) bindCols-            else raiseError "sqlGetData" rc (StmtHandle cstmt)-          return (stmt, Just sqlValues)--getBindCols :: SState -> Ptr CStmt -> IO [(BindCol, Ptr #{type SQLLEN})]-getBindCols sstate cstmt = do-  l "getBindCols"-  modifyMVar (bindColsMV sstate) $ \mBindCols ->-    case mBindCols of-      Nothing -> do-        cols <- getNumResultCols cstmt-        pBindCols <- mapM (mkBindCol sstate cstmt) [1 .. cols]-        return (Just pBindCols, pBindCols)-      Just bindCols -> do-        return (mBindCols, bindCols)---- This is only for String data. For binary fix should be very easy. Just check the column type and use buflen instead of buflen - 1-getLongColData cstmt bindCol = do-   let (BindColString buf bufLen col) = bindCol-   l $ "buflen: " ++ show bufLen-   bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1))-   l $ "sql_no_total col " ++ show (BUTF8.toString bs)-   bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs-   return $ SqlByteString bs2---getRestLongColData cstmt cBinding icol acc = do-  l "getLongColData"-  alloca $ \plen ->-   allocaBytes colBufSizeMaximum $ \buf ->-     do res <- sqlGetData cstmt (fromIntegral icol) cBinding-                          buf (fromIntegral colBufSizeMaximum) plen-        if res == #{const SQL_SUCCESS} || res == #{const SQL_SUCCESS_WITH_INFO}-           then do-                len <- peek plen-                if len == #{const SQL_NO_DATA}-                   then return acc-                   else do-                        let bufmax = fromIntegral $ colBufSizeMaximum - 1-                        bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len))-                        l $ "sql_no_total col is: " ++ show (BUTF8.toString bs)-                        let newacc = B.append acc bs-                        if len /= #{const SQL_NO_TOTAL} && len <= bufmax-                           then return newacc-                           else getRestLongColData cstmt cBinding icol newacc-           else  raiseError "sqlGetData" res (StmtHandle cstmt)---- TODO: This code does not deal well with data that is extremely large,--- where multiple fetches are required.-getColData cstmt cBinding icol = do-  alloca $ \plen ->-   allocaBytes colBufSizeDefault $ \buf ->-     do res <- sqlGetData cstmt (fromIntegral icol) cBinding-                          buf (fromIntegral colBufSizeDefault) plen-        case res of-          #{const SQL_SUCCESS} ->-              do len <- peek plen-                 case len of-                   #{const SQL_NULL_DATA} -> return SqlNull-                   #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL"-                   _ -> do bs <- B.packCStringLen (buf, fromIntegral len)-                           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) cBinding-                                 buf2 (fromIntegral len + 1) plen-                                 >>= checkError "sqlGetData" (StmtHandle cstmt)-                      len2 <- peek plen-                      let firstbuf = case cBinding of-                                       #{const SQL_C_BINARY} -> colBufSizeDefault-                                       _ -> colBufSizeDefault - 1 -- strip off NUL-                      bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf))-                            (B.packCStringLen (buf2, fromIntegral len2))-                      l $ "col is: " ++ (BUTF8.toString bs)-                      return (SqlByteString bs)-          _ -> raiseError "sqlGetData" res (StmtHandle cstmt)---- | ffetchrowBaseline is used for benchmarking fetches without the--- overhead of marshalling values.-ffetchrowBaseline sstate = do-  Just cmstmt <- readMVar (stomv sstate)-  withStmt cmstmt $ \cstmt -> do-    rc <- sqlFetch cstmt-    if rc == #{const SQL_NO_DATA}-      then do ffinish cmstmt-              return Nothing-      else do return (Just [])--data ColBuf---- These correspond to the C type identifiers found here:---     http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx--- The Ptr values point to the appropriate C types-data BindCol-  = BindColString  (Ptr CChar) #{type SQLLEN} #{type SQLUSMALLINT}-  | BindColWString (Ptr CWchar) #{type SQLLEN} #{type SQLUSMALLINT}-  | BindColBit     (Ptr CUChar)-  | BindColTinyInt (Ptr CChar)-  | BindColShort   (Ptr CShort)-  | BindColLong    (Ptr CLong)-  | BindColBigInt  (Ptr #{type SQLBIGINT})-  | BindColFloat   (Ptr CFloat)-  | BindColDouble  (Ptr CDouble)-  | BindColBinary  (Ptr CUChar) #{type SQLLEN} #{type SQLUSMALLINT}-  | BindColDate    (Ptr StructDate)-  | BindColTime    (Ptr StructTime)-  | BindColTimestamp (Ptr StructTimestamp)-  | BindColGetData #{type SQLUSMALLINT}----- Intervals and GUIDs have not been implemented, since there is no--- equivalent SqlValue for these.------  | BindColInterval---      typedef struct tagSQL_INTERVAL_STRUCT---      {---         SQLINTERVAL interval_type; ---         SQLSMALLINT interval_sign;---         union {---               SQL_YEAR_MONTH_STRUCT   year_month;---               SQL_DAY_SECOND_STRUCT   day_second;---               } intval;---      } SQL_INTERVAL_STRUCT;---      typedef enum ---      {---         SQL_IS_YEAR = 1,---         SQL_IS_MONTH = 2,---         SQL_IS_DAY = 3,---         SQL_IS_HOUR = 4,---         SQL_IS_MINUTE = 5,---         SQL_IS_SECOND = 6,---         SQL_IS_YEAR_TO_MONTH = 7,---         SQL_IS_DAY_TO_HOUR = 8,---         SQL_IS_DAY_TO_MINUTE = 9,---         SQL_IS_DAY_TO_SECOND = 10,---         SQL_IS_HOUR_TO_MINUTE = 11,---         SQL_IS_HOUR_TO_SECOND = 12,---         SQL_IS_MINUTE_TO_SECOND = 13---      } SQLINTERVAL;---      ---      typedef struct tagSQL_YEAR_MONTH---      {---         SQLUINTEGER year;---         SQLUINTEGER month; ---      } SQL_YEAR_MONTH_STRUCT;---      ---      typedef struct tagSQL_DAY_SECOND---      {---         SQLUINTEGER day;---         SQLUINTEGER hour;---         SQLUINTEGER minute;---         SQLUINTEGER second;---         SQLUINTEGER fraction;---      } SQL_DAY_SECOND_STRUCT;--- | BindColGUID (Ptr StructGUID)----- | StructDate is used to marshal the DATE_STRUCT--- This struct, and the ones which follow, are described here:---     http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx-data StructDate = StructDate-  #{type SQLSMALLINT}   -- ^ year-  #{type SQLUSMALLINT}  -- ^ month-  #{type SQLUSMALLINT}  -- ^ day- deriving Show--instance Storable StructDate where-  sizeOf _    = #{size DATE_STRUCT}-  alignment _ = alignment (undefined :: CLong)-  poke p (StructDate year month day) = do-    #{poke DATE_STRUCT, year}  p year-    #{poke DATE_STRUCT, month} p month-    #{poke DATE_STRUCT, day}   p day-  peek p = return StructDate-    `ap` (#{peek DATE_STRUCT, year}  p)-    `ap` (#{peek DATE_STRUCT, month} p)-    `ap` (#{peek DATE_STRUCT, day}   p)----- | StructTime is used to marshals the TIME_STRUCT:-data StructTime = StructTime-  #{type SQLUSMALLINT} -- ^ hour-  #{type SQLUSMALLINT} -- ^ minute-  #{type SQLUSMALLINT} -- ^ second--instance Storable StructTime where-  sizeOf _    = #{size TIME_STRUCT}-  alignment _ = alignment (undefined :: CLong)-  poke p (StructTime hour minute second) = do-    #{poke TIME_STRUCT, hour}   p hour-    #{poke TIME_STRUCT, minute} p minute-    #{poke TIME_STRUCT, second} p second-  peek p = return StructTime-    `ap` (#{peek TIME_STRUCT, hour}  p)-    `ap` (#{peek TIME_STRUCT, minute} p)-    `ap` (#{peek TIME_STRUCT, second}   p)---- | StructTimestamp is used to marshal the TIMESTAMP_STRUCT;-data StructTimestamp = StructTimestamp-  #{type SQLSMALLINT}   -- ^ year-  #{type SQLUSMALLINT}  -- ^ month-  #{type SQLUSMALLINT}  -- ^ day-  #{type SQLUSMALLINT}  -- ^ hour-  #{type SQLUSMALLINT}  -- ^ minute-  #{type SQLUSMALLINT}  -- ^ second-  #{type SQLUINTEGER}   -- ^ fraction--instance Storable StructTimestamp where-  sizeOf _    = #{size TIMESTAMP_STRUCT}-  alignment _ = alignment (undefined :: CLong)-  poke p (StructTimestamp year month day hour minute second fraction) = do-    #{poke TIMESTAMP_STRUCT, year}      p year-    #{poke TIMESTAMP_STRUCT, month}     p month-    #{poke TIMESTAMP_STRUCT, day}       p day-    #{poke TIMESTAMP_STRUCT, hour}      p hour-    #{poke TIMESTAMP_STRUCT, minute}    p minute-    #{poke TIMESTAMP_STRUCT, second}    p second-    #{poke TIMESTAMP_STRUCT, fraction}  p fraction-  peek p = return StructTimestamp-    `ap` (#{peek TIMESTAMP_STRUCT, year}     p)-    `ap` (#{peek TIMESTAMP_STRUCT, month}    p)-    `ap` (#{peek TIMESTAMP_STRUCT, day}      p)-    `ap` (#{peek TIMESTAMP_STRUCT, hour}     p)-    `ap` (#{peek TIMESTAMP_STRUCT, minute}   p)-    `ap` (#{peek TIMESTAMP_STRUCT, second}   p)-    `ap` (#{peek TIMESTAMP_STRUCT, fraction} p)---- | StructGUID--- data StructGUID = StructGUID---   #{type DWORD}     -- ^ Data1---   #{type WORD}      -- ^ Data2---   #{type WORD}      -- ^ Data3---   [#{type BYTE}]    -- ^ Data4[8]--- --- instance Storable StructGUID where---   sizeOf _ = #{size SQLGUID}---   alignment _ = alignment (undefined :: CLong)---   poke p (StructGUID data1 data2 data3 data4) = do---     #{poke SQLGUID, Data1} p data1---     #{poke SQLGUID, Data2} p data2---     #{poke SQLGUID, Data3} p data3---     pokeArray (p `plusPtr` #{offset SQLGUID, Data4}) data4---   peek p = return StructGUID---     `ap` (#{peek SQLGUID, Data1} p)---     `ap` (#{peek SQLGUID, Data2} p)---     `ap` (#{peek SQLGUID, Data3} p)---     `ap` (peekArray 8 (p `plusPtr` #{offset SQLGUID, Data4}))----- | This function binds the data in a column to a value of type--- BindCol, using the default conversion scheme described here:---     http://msdn.microsoft.com/en-us/library/ms716298(v=VS.85).aspx--- The corresponding C types are here:---     http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx--- These values are then ready for fetching.--- Documentation about SQLBindCol can be found here:---     http://msdn.microsoft.com/en-us/library/ms711010(v=vs.85).aspx------ Our implementation follows this code:---     http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=%2Fcli%2Frzadpfndecol.htm--- We have to make use of the column type and length information.--- These are given by SQLDescribeCol, which is stored in colinfomv.--- SQLDescribeCol can tell use the data type, and the size of a column (in--- characters, so add 1 for the null terminator), or the number of decimal--- digits that can be held.--- To find out type, and how much memory to allocate, we could also use:---    SQLColAttribute( ..., SQL_DESC_TYPE , ... )---    SQLColAttribute( ..., SQL_DESC_OCTET_LENGTH , ... )------ Further examples of how to use SQLBindCol are here, though these make use--- of SQLDescribeCol:---     http://msdn.microsoft.com/en-us/library/ms710118(v=vs.85).aspx--- This implementation makes use of Column-Wise binding. Further improvements--- might be had by using Row-Wise binding.-mkBindCol :: SState -> Ptr CStmt -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN})-mkBindCol sstate cstmt col = do-  l "mkBindCol"-  colInfo <- readMVar (colinfomv sstate)-  let colDesc = (snd (colInfo !! ((fromIntegral col) -1)))-  case colType colDesc of-    SqlCharT          -> mkBindColString    cstmt col' (colSize colDesc)-    SqlVarCharT       -> mkBindColString    cstmt col' (colSize colDesc)-    SqlLongVarCharT   -> mkBindColString    cstmt col' (colSize colDesc)-    SqlWCharT         -> mkBindColWString   cstmt col' (colSize colDesc)-    SqlWVarCharT      -> mkBindColWString   cstmt col' (colSize colDesc)-    SqlWLongVarCharT  -> mkBindColWString   cstmt col' (colSize colDesc)-    SqlDecimalT       -> mkBindColString    cstmt col' (colSize colDesc)-    SqlNumericT       -> mkBindColString    cstmt col' (colSize colDesc)-    SqlBitT           -> mkBindColBit       cstmt col' (colSize colDesc)-    SqlTinyIntT       -> mkBindColTinyInt   cstmt col' (colSize colDesc)-    SqlSmallIntT      -> mkBindColShort     cstmt col' (colSize colDesc)-    SqlIntegerT       -> mkBindColLong      cstmt col' (colSize colDesc)-    SqlBigIntT        -> mkBindColBigInt    cstmt col' (colSize colDesc)-    SqlRealT          -> mkBindColFloat     cstmt col' (colSize colDesc)-    SqlFloatT         -> mkBindColDouble    cstmt col' (colSize colDesc)-    SqlDoubleT        -> mkBindColDouble    cstmt col' (colSize colDesc)-    SqlBinaryT        -> mkBindColBinary    cstmt col' (colSize colDesc)-    SqlVarBinaryT     -> mkBindColBinary    cstmt col' (colSize colDesc)-    SqlLongVarBinaryT -> mkBindColBinary    cstmt col' (colSize colDesc)-    SqlDateT          -> mkBindColDate      cstmt col' (colSize colDesc)-    SqlTimeT          -> mkBindColTime      cstmt col' (colSize colDesc)-    SqlTimestampT     -> mkBindColTimestamp cstmt col' (colSize colDesc)---    SqlIntervalT i    -> mkBindColInterval  cstmt col' (colSize colDesc) i---    SqlGUIDT          -> mkBindColGUID      cstmt col' (colSize colDesc)-    _                 -> mkBindColGetData   col'--- The following are not supported by ODBC:---    SqlUTCDateTimeT---    SqlUTCTimeT---    SqlTimeWithZoneT---    SqlTimestampWithZoneT- where-  col' = fromIntegral col--colBufSizeDefault = 1024-colBufSizeMaximum = 4096---- The functions that follow do the marshalling from C into a Haskell type-mkBindColString cstmt col mColSize = do-  l "mkBindCol: BindColString"-  let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize-  let bufLen  = sizeOf (undefined :: CChar) * (colSize + 1)-  buf     <- mallocBytes bufLen-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColString buf (fromIntegral bufLen) col, pStrLen)-mkBindColWString cstmt col mColSize = do-  l "mkBindCol: BindColWString"-  let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize-  let bufLen  = sizeOf (undefined :: CWchar) * (colSize + 1)-  buf     <- mallocBytes bufLen-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColWString buf (fromIntegral bufLen) col, pStrLen)-mkBindColBit cstmt col mColSize = do-  l "mkBindCol: BindColBit"-  let bufLen  = sizeOf (undefined :: CChar)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColBit buf, pStrLen)-mkBindColTinyInt cstmt col mColSize = do-  l "mkBindCol: BindColTinyInt"-  let bufLen  = sizeOf (undefined :: CUChar)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColTinyInt buf, pStrLen)-mkBindColShort cstmt col mColSize = do-  l "mkBindCol: BindColShort"-  let bufLen  = sizeOf (undefined :: CShort)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColShort buf, pStrLen)-mkBindColLong cstmt col mColSize = do-  l "mkBindCol: BindColSize"-  let bufLen  = sizeOf (undefined :: CLong)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColLong buf, pStrLen)-mkBindColBigInt cstmt col mColSize = do-  l "mkBindCol: BindColBigInt"-  let bufLen  = sizeOf (undefined :: CInt)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColBigInt buf, pStrLen)-mkBindColFloat cstmt col mColSize = do-  l "mkBindCol: BindColFloat"-  let bufLen  = sizeOf (undefined :: CFloat)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColFloat buf, pStrLen)-mkBindColDouble cstmt col mColSize = do-  l "mkBindCol: BindColDouble"-  let bufLen  = sizeOf (undefined :: CDouble)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColDouble buf, pStrLen)-mkBindColBinary cstmt col mColSize = do-  l "mkBindCol: BindColBinary"-  let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize-  let bufLen  = sizeOf (undefined :: CUChar) * (colSize + 1)-  buf     <- mallocBytes bufLen-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColBinary buf (fromIntegral bufLen) col, pStrLen)-mkBindColDate cstmt col mColSize = do-  l "mkBindCol: BindColDate"-  let bufLen = sizeOf (undefined :: StructDate)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColDate buf, pStrLen)-mkBindColTime cstmt col mColSize = do-  l "mkBindCol: BindColTime"-  let bufLen = sizeOf (undefined :: StructTime)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColTime buf, pStrLen)-mkBindColTimestamp cstmt col mColSize = do-  l "mkBindCol: BindColTimestamp"-  let bufLen = sizeOf (undefined :: StructTimestamp)-  buf     <- malloc-  pStrLen <- malloc-  sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen-  return (BindColTimestamp buf, pStrLen)-mkBindColGetData col = do-  l "mkBindCol: BindColGetData"-  return (BindColGetData col, nullPtr)--freeBindCol :: BindCol -> IO ()-freeBindCol (BindColString   buf _ _) = free buf-freeBindCol (BindColWString  buf _ _) = free buf-freeBindCol (BindColBit      buf) = free buf-freeBindCol (BindColTinyInt  buf) = free buf-freeBindCol (BindColShort    buf) = free buf-freeBindCol (BindColLong     buf) = free buf-freeBindCol (BindColBigInt   buf) = free buf-freeBindCol (BindColFloat    buf) = free buf-freeBindCol (BindColDouble   buf) = free buf-freeBindCol (BindColBinary   buf _ _) = free buf-freeBindCol (BindColDate     buf) = free buf-freeBindCol (BindColTime     buf) = free buf-freeBindCol (BindColTimestamp buf) = free buf-freeBindCol (BindColGetData  _ )   = return ()---- | This assumes that SQL_ATTR_MAX_LENGTH is set to zero, otherwise, we--- cannot detect truncated columns. See "returning Data in Bound Columns":---     http://msdn.microsoft.com/en-us/library/ms712424(v=vs.85).aspx--- Also note that the strLen value of SQL_NTS denotes a null terminated string,--- but is only valid as input, so we don't make use of it here:---     http://msdn.microsoft.com/en-us/library/ms713532(v=VS.85).aspx-bindColToSqlValue :: Ptr CStmt -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue-bindColToSqlValue pcstmt (BindColGetData col, _) = do-  l "bindColToSqlValue: BindColGetData"-  getColData pcstmt #{const SQL_CHAR} col-bindColToSqlValue pcstmt (bindCol, pStrLen) = do-  l "bindColToSqlValue"-  strLen <- peek pStrLen-  case strLen of-    #{const SQL_NULL_DATA} -> return SqlNull-    #{const SQL_NO_TOTAL}  -> getLongColData pcstmt bindCol    -    _                      -> bindColToSqlValue' pcstmt bindCol strLen---- | This is a worker function for `bindcolToSqlValue`. Note that the case--- where the data is null should already be handled by this stage.-bindColToSqlValue' :: Ptr CStmt -> BindCol -> #{type SQLLEN} -> IO SqlValue-bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen-  | bufLen >= strLen = do-      bs <- B.packCStringLen (buf, fromIntegral strLen)-      l $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen-      return $ SqlByteString bs-  | otherwise = getColData pcstmt #{const SQL_CHAR} col-bindColToSqlValue' pcstmt (BindColWString buf bufLen col) strLen-  | bufLen >= strLen = do-      bs <- B.packCStringLen (castPtr buf, fromIntegral strLen)-      l $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen-      return $ SqlByteString bs-  | otherwise = getColData pcstmt #{const SQL_CHAR} col-bindColToSqlValue' _ (BindColBit     buf) strLen = do-  bit <- peek buf-  l $ "bindColToSqlValue BindColBit " ++ show bit-  return $ SqlChar (castCUCharToChar bit)-bindColToSqlValue' _ (BindColTinyInt buf) strLen = do-  tinyInt <- peek buf-  l $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt-  return $ SqlChar (castCCharToChar tinyInt)-bindColToSqlValue' _ (BindColShort   buf) strLen = do-  short <- peek buf-  l $ "bindColToSqlValue BindColShort" ++ show short-  return $ SqlInt32 (fromIntegral short)-bindColToSqlValue' _ (BindColLong    buf) strLen = do-  long <- peek buf-  l $ "bindColToSqlValue BindColLong " ++ show long-  return $ SqlInt32 (fromIntegral long)-bindColToSqlValue' _ (BindColBigInt  buf) strLen = do-  bigInt <- peek buf-  l $ "bindColToSqlValue BindColBigInt " ++ show bigInt-  return $ SqlInt64 (fromIntegral bigInt)-bindColToSqlValue' _ (BindColFloat   buf) strLen = do-  float <- peek buf-  l $ "bindColToSqlValue BindColFloat " ++ show float-  return $ SqlDouble (realToFrac float)-bindColToSqlValue' _ (BindColDouble  buf) strLen = do-  double <- peek buf-  l $ "bindColToSqlValue BindColDouble " ++ show double-  return $ SqlDouble (realToFrac double)-bindColToSqlValue' pcstmt (BindColBinary  buf bufLen col) strLen-  | bufLen >= strLen = do-      bs <- B.packCStringLen (castPtr buf, fromIntegral strLen)-      l $ "bindColToSqlValue BindColBinary " ++ show bs-      return $ SqlByteString bs-  | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col-bindColToSqlValue' _ (BindColDate buf) strLen = do-  StructDate year month day <- peek buf-  l $ "bindColToSqlValue BindColDate"-  return $ SqlLocalDate $ fromGregorian-    (fromIntegral year) (fromIntegral month) (fromIntegral day)-bindColToSqlValue' _ (BindColTime buf) strLen = do-  StructTime hour minute second <- peek buf-  l $ "bindColToSqlValue BindColTime"-  return $ SqlLocalTimeOfDay $ TimeOfDay-    (fromIntegral hour) (fromIntegral minute) (fromIntegral second)-bindColToSqlValue' _ (BindColTimestamp buf) strLen = do-  StructTimestamp year month day hour minute second nanosecond <- peek buf-  l $ "bindColToSqlValue BindColTimestamp"-  return $ SqlLocalTime $ LocalTime-    (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))-    (TimeOfDay (fromIntegral hour) (fromIntegral minute)-    (fromIntegral second + (fromIntegral nanosecond / 1000000000)))-bindColToSqlValue' _ (BindColGetData _) _ =-  error "bindColToSqlValue': unexpected BindColGetData!"--fgetcolinfo :: Ptr CStmt -> IO [(String, SqlColDesc)]-fgetcolinfo cstmt =-    do ncols <- getNumResultCols cstmt-       mapM getname [1..ncols]-    where getname icol = alloca $ \colnamelp ->-                         allocaBytes 128 $ \cscolname ->-                         alloca $ \datatypeptr ->-                         alloca $ \colsizeptr ->-                         alloca $ \nullableptr ->-              do sqlDescribeCol cstmt icol cscolname 127 colnamelp -                                datatypeptr colsizeptr nullPtr nullableptr-                 colnamelen <- peek colnamelp-                 colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen)-                 let colname = BUTF8.toString colnamebs-                 datatype <- peek datatypeptr-                 colsize <- peek colsizeptr-                 nullable <- peek nullableptr-                 return $ fromOTypeInfo colname datatype colsize nullable---- FIXME: needs a faster algorithm.-fexecutemany :: SState -> [[SqlValue]] -> IO ()-fexecutemany sstate arglist =-    mapM_ (fexecute sstate) arglist >> return ()---- Finish and change state-public_ffinish :: SState -> IO ()-public_ffinish sstate = do-  l "public_ffinish"-  modifyMVar_ (stomv sstate) freeMStmt-  modifyMVar_ (bindColsMV sstate) freeBindCols- where-  freeMStmt Nothing    = return Nothing-  freeMStmt (Just sth) = ffinish sth >> return Nothing-  freeBindCols Nothing = return Nothing-  freeBindCols (Just bindCols) = do-    l "public_ffinish: freeing bindcols"-    mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols-    return Nothing--ffinish :: Stmt -> IO ()-ffinish stmt = withRawStmt stmt $ sqlFreeHandleSth_app ---foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc"-  wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt)--foreign import #{CALLCONV} safe "sql.h SQLDescribeCol"-  sqlDescribeCol :: Ptr CStmt   -                 -> #{type SQLSMALLINT} -- ^ Column number-                 -> CString     -- ^ Column name-                 -> #{type SQLSMALLINT} -- ^ Buffer length-                 -> Ptr (#{type SQLSMALLINT}) -- ^ name length ptr-                 -> Ptr (#{type SQLSMALLINT}) -- ^ data type ptr-                 -> Ptr (#{type SQLULEN}) -- ^ column size ptr-                 -> Ptr (#{type SQLSMALLINT}) -- ^ decimal digits ptr-                 -> Ptr (#{type SQLSMALLINT}) -- ^ nullable ptr-                 -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLGetData"-  sqlGetData :: Ptr CStmt       -- ^ statement handle-             -> #{type SQLUSMALLINT} -- ^ Column number-             -> #{type SQLSMALLINT} -- ^ target type-             -> CString -- ^ target value pointer (void * in C)-             -> #{type SQLLEN} -- ^ buffer len-             -> Ptr (#{type SQLLEN})-             -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLBindCol"-  sqlBindCol :: Ptr CStmt            -- ^ statement handle-             -> #{type SQLUSMALLINT} -- ^ Column number-             -> #{type SQLSMALLINT}  -- ^ target type-             -> Ptr ColBuf           -- ^ target value pointer (void * in C)-             -> #{type SQLLEN}       -- ^ buffer len-             -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr-             -> IO #{type SQLRETURN}--foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleSth_app"-  sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO ()--foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer"-  sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ())--foreign import #{CALLCONV} safe "sql.h SQLPrepare"-  sqlPrepare :: Ptr CStmt -> CString -> #{type SQLINTEGER} -             -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLExecute"-  sqlExecute :: Ptr CStmt -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"-  sqlAllocStmtHandle :: #{type SQLSMALLINT} -> Ptr CConn ->-                        Ptr (Ptr CStmt) -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLNumResultCols"-  sqlNumResultCols :: Ptr CStmt -> Ptr #{type SQLSMALLINT} -                   -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLRowCount"-  sqlRowCount :: Ptr CStmt -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLBindParameter"-  sqlBindParameter :: Ptr CStmt -- ^ Statement handle-                   -> #{type SQLUSMALLINT} -- ^ Parameter Number-                   -> #{type SQLSMALLINT} -- ^ Input or output-                   -> #{type SQLSMALLINT} -- ^ Value type-                   -> #{type SQLSMALLINT} -- ^ Parameter type-                   -> #{type SQLULEN} -- ^ column size-                   -> #{type SQLSMALLINT} -- ^ decimal digits-                   -> CString   -- ^ Parameter value pointer-                   -> #{type SQLLEN} -- ^ buffer length-                   -> Ptr #{type SQLLEN} -- ^ strlen_or_indptr-                   -> IO #{type SQLRETURN}--foreign import ccall safe "hdbc-odbc-helper.h &nullDataHDBC"-  nullDataHDBC :: Ptr #{type SQLLEN}--foreign import #{CALLCONV} safe "sql.h SQLDescribeParam"-  sqlDescribeParam :: Ptr CStmt -                   -> #{type SQLUSMALLINT} -- ^ parameter number-                   -> Ptr #{type SQLSMALLINT} -- ^ data type ptr-                   -> Ptr #{type SQLULEN} -- ^ parameter size ptr-                   -> Ptr #{type SQLSMALLINT} -- ^ dec digits ptr-                   -> Ptr #{type SQLSMALLINT} -- ^ nullable ptr-                   -> IO #{type SQLRETURN}--foreign import #{CALLCONV} safe "sql.h SQLFetch"-  sqlFetch :: Ptr CStmt -> IO #{type SQLRETURN}--foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables"-  simpleSqlTables :: Ptr CStmt -> IO #{type SQLRETURN}--foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns"-  simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> -                      #{type SQLSMALLINT} -> IO #{type SQLRETURN}--fgetparminfo :: Ptr CStmt -> IO [SqlColDesc]-fgetparminfo cstmt =-    do ncols <- getNumParams cstmt-       mapM getname [1..ncols]-    where getname icol = -- alloca $ \colnamelp ->-                         -- allocaBytes 128 $ \cscolname ->-                         alloca $ \datatypeptr ->-                         alloca $ \colsizeptr ->-                         alloca $ \nullableptr ->-              do poke datatypeptr 127 -- to test if sqlDescribeParam actually writes something to the area-                 res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp -                                  datatypeptr colsizeptr nullPtr nullableptr-                 putStrLn $ show res-                 -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam.-                 -- Not supporting SQLDescribeParam is quite allright according to the ODBC standard.-                 datatype <- peek datatypeptr-                 colsize  <- peek colsizeptr-                 nullable <- peek nullableptr-                 return $ snd $ fromOTypeInfo "" datatype colsize nullable--getNumParams :: Ptr CStmt -> IO Int16-getNumParams sthptr = alloca $ \pcount ->-    do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" -                                          (StmtHandle sthptr)-       peek pcount--foreign import #{CALLCONV} safe "sql.h SQLNumParams"-  sqlNumParams :: Ptr CStmt -> Ptr #{type SQLSMALLINT} -               -> IO #{type SQLRETURN}+-- -*- mode: haskell; -*-
+{-# CFILES hdbc-odbc-helper.c #-}
+-- Above line for hugs
+{-# LANGUAGE EmptyDataDecls #-}
+
+module Database.HDBC.ODBC.Statement (
+   fGetQueryInfo,
+   newSth,
+   fgettables,
+   fdescribetable
+ ) where
+
+import Database.HDBC.Types
+import Database.HDBC
+import Database.HDBC.DriverUtils
+import Database.HDBC.ODBC.Types
+import Database.HDBC.ODBC.Utils
+import Database.HDBC.ODBC.TypeConv
+
+import Foreign.C.String (castCUCharToChar)
+import Foreign.C.Types
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Control.Applicative
+import Control.Concurrent.MVar
+import Foreign.C.String
+import Foreign.Marshal
+import Foreign.Storable
+import Control.Monad
+import Data.Word
+import Data.Time.Calendar (fromGregorian)
+import Data.Time.LocalTime (TimeOfDay(TimeOfDay), LocalTime(LocalTime))
+import Data.Int
+import Data.Maybe (catMaybes, fromMaybe)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.UTF8 as BUTF8
+import qualified Data.ByteString.Unsafe as B
+import Unsafe.Coerce (unsafeCoerce)
+
+import System.IO (hPutStrLn, stderr)
+import Debug.Trace
+
+l :: String -> IO ()
+l _ = return ()
+-- l m = hPutStrLn stderr ("\n" ++ m)
+
+#ifdef mingw32_HOST_OS
+#include <windows.h>
+#endif
+#include <sql.h>
+#include <sqlext.h>
+
+#ifdef mingw32_HOST_OS
+#let CALLCONV = "stdcall"
+#else
+#let CALLCONV = "ccall"
+#endif
+
+fGetQueryInfo :: Conn -> ChildList -> String
+              -> IO ([SqlColDesc], [(String, SqlColDesc)])
+fGetQueryInfo iconn children query =
+    do l "in fGetQueryInfo"
+       sstate <- newSState iconn query
+       addChild children (wrapStmt sstate)   -- We get error if we forget this one. Not sure why.
+       fakeExecute' sstate
+
+fakeExecute' :: SState -> IO ([SqlColDesc], [(String, SqlColDesc)])
+fakeExecute' sstate  = withConn (dbo sstate) $ \cconn ->
+                       withCStringLen (squery sstate) $ \(cquery, cqlen) ->
+                       alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
+    do l "in fexecute"
+       -- public_ffinish sstate  
+       rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr
+       sthptr <- peek psthptr
+       wrappedsthptr <- withRawConn (dbo sstate)
+                        (\rawconn -> wrapstmt sthptr rawconn)
+       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
+       checkError "execute allocHandle" (DbcHandle cconn) rc1
+
+       sqlPrepare sthptr cquery (fromIntegral cqlen) >>= 
+            checkError "execute prepare" (StmtHandle sthptr)
+
+       -- parmCount <- getNumParams sthptr
+       parmInfo <- fgetparminfo sthptr
+       
+       -- rc <- getNumResultCols sthptr
+       colInfo <- fgetcolinfo sthptr
+       return (parmInfo, colInfo)
+
+-- | The Stament State
+data SState = SState
+  { stomv      :: MVar (Maybe Stmt)
+  , dbo        :: Conn
+  , squery     :: String
+  , colinfomv  :: MVar [(String, SqlColDesc)]
+  , bindColsMV :: MVar (Maybe [(BindCol, Ptr #{type SQLLEN})])
+  }
+
+-- FIXME: we currently do no prepare optimization whatsoever.
+
+newSState :: Conn -> String -> IO SState
+newSState indbo query =
+    do newstomv     <- newMVar Nothing
+       newcolinfomv <- newMVar []
+       newBindCols  <- newMVar Nothing
+       return SState
+         { stomv      = newstomv
+         , dbo        = indbo
+         , squery     = query
+         , colinfomv  = newcolinfomv
+         , bindColsMV = newBindCols
+         }
+
+wrapStmt :: SState -> Statement
+wrapStmt sstate = Statement
+  { execute        = fexecute sstate
+  , executeRaw     = return ()
+  , executeMany    = fexecutemany sstate
+  , finish         = public_ffinish sstate
+  , fetchRow       = ffetchrow sstate
+  , originalQuery  = (squery sstate)
+  , getColumnNames = readMVar (colinfomv sstate) >>= (return . map fst)
+  , describeResult = readMVar (colinfomv sstate)
+  }
+
+newSth :: Conn -> ChildList -> String -> IO Statement
+newSth indbo mchildren query =
+    do l "in newSth"
+       sstate <- newSState indbo query
+       let retval = wrapStmt sstate
+       addChild mchildren retval
+       return retval
+
+makesth :: Conn -> [Char] -> IO (ForeignPtr WrappedCStmt)
+makesth iconn name = alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
+                     withConn iconn $ \cconn -> 
+                     withCString "" $ \emptycs ->
+    do rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr
+       sthptr <- peek psthptr
+       wrappedsthptr <- withRawConn iconn
+                        (\rawconn -> wrapstmt sthptr rawconn)
+       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
+       checkError (name ++ " allocHandle") (DbcHandle cconn) rc1
+       return fsthptr
+
+wrapTheStmt :: Conn -> Stmt -> IO (Statement, SState)
+wrapTheStmt iconn fsthptr =
+    do sstate <- newSState iconn ""
+       sstate <- newSState iconn ""
+       swapMVar (stomv sstate) (Just fsthptr)
+       let sth = wrapStmt sstate
+       return (sth, sstate)
+
+fgettables :: Conn -> IO [String]
+fgettables iconn =
+    do fsthptr <- makesth iconn "fgettables"
+       l "fgettables: after makesth"
+       withStmt fsthptr (\sthptr ->
+                             simpleSqlTables sthptr >>=
+                                checkError "gettables simpleSqlTables" 
+                                               (StmtHandle sthptr)
+                        )
+       l "fgettables: after withStmt"
+       (sth, sstate) <- wrapTheStmt iconn fsthptr
+       withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))
+       l "fgettables: after wrapTheStmt"
+       results <- fetchAllRows' sth
+       l ("fgettables: results: " ++ (show results))
+       return $ map (\x -> fromSql (x !! 2)) results
+
+fdescribetable :: Conn -> String -> IO [(String, SqlColDesc)]
+fdescribetable iconn tablename = B.useAsCStringLen (BUTF8.fromString tablename) $ 
+                                 \(cs, csl) ->
+    do fsthptr <- makesth iconn "fdescribetable"
+       withStmt fsthptr (\sthptr ->
+                             simpleSqlColumns sthptr cs (fromIntegral csl) >>=
+                               checkError "fdescribetable simpleSqlColumns"
+                                          (StmtHandle sthptr)
+                        )
+       (sth, sstate) <- wrapTheStmt iconn fsthptr
+       withStmt fsthptr (\sthptr -> fgetcolinfo sthptr >>= swapMVar (colinfomv sstate))
+       results <- fetchAllRows' sth
+       l (show results)
+       return $ map fromOTypeCol results
+
+{- For now, we try to just  handle things as simply as possible.
+FIXME lots of room for improvement here (types, etc). -}
+fexecute :: SState -> [SqlValue] -> IO Integer
+fexecute sstate args =
+  withConn (dbo sstate) $ \cconn ->
+  B.useAsCStringLen (BUTF8.fromString (squery sstate)) $ \(cquery, cqlen) ->
+  alloca $ \(psthptr::Ptr (Ptr CStmt)) ->
+    do l $ "in fexecute: " ++ show (squery sstate) ++ show args
+       public_ffinish sstate
+       rc1 <- sqlAllocStmtHandle #{const SQL_HANDLE_STMT} cconn psthptr
+       sthptr <- peek psthptr
+       wrappedsthptr <- withRawConn (dbo sstate)
+                        (\rawconn -> wrapstmt sthptr rawconn)
+       fsthptr <- newForeignPtr sqlFreeHandleSth_ptr wrappedsthptr
+       checkError "execute allocHandle" (DbcHandle cconn) rc1
+
+       sqlPrepare sthptr cquery (fromIntegral cqlen) >>= 
+            checkError "execute prepare" (StmtHandle sthptr)
+
+       bindArgs <- zipWithM (bindParam sthptr) args [1..]
+       l $ "Ready for sqlExecute: " ++ show (squery sstate) ++ show args
+       r <- sqlExecute sthptr
+       mapM_ (\(x, y) -> free x >> free y) (catMaybes bindArgs)
+
+       case r of
+         #{const SQL_NO_DATA} -> return () -- Update that did nothing
+         x -> checkError "execute execute" (StmtHandle sthptr) x
+
+       rc <- getNumResultCols sthptr
+
+       case rc of
+         0 -> do rowcount <- getSqlRowCount sthptr
+                 ffinish fsthptr
+                 swapMVar (colinfomv sstate) []
+                 touchForeignPtr fsthptr
+                 return (fromIntegral rowcount)
+         colcount -> do fgetcolinfo sthptr >>= swapMVar (colinfomv sstate)
+                        swapMVar (stomv sstate) (Just fsthptr)
+                        touchForeignPtr fsthptr
+                        return 0
+
+getNumResultCols :: Ptr CStmt -> IO #{type SQLSMALLINT}
+getNumResultCols sthptr = alloca $ \pcount ->
+    do sqlNumResultCols sthptr pcount >>= checkError "SQLNumResultCols" 
+                                          (StmtHandle sthptr)
+       peek pcount
+
+-- Bind a parameter column before execution.
+bindParam :: Ptr CStmt -> SqlValue -> Word16
+        -> IO (Maybe (Ptr #{type SQLLEN}, Ptr CChar))
+bindParam sthptr arg icol =  alloca $ \pdtype ->
+                           alloca $ \pcolsize ->
+                           alloca $ \pdecdigits ->
+                           alloca $ \pnullable ->
+{- We have to start by getting the SQL type of the column so we can
+   send the correct type back to the server.  Sigh.  If the ODBC
+   backend won't tell us the type, we fake it.
+
+   We've got an annoying situation with error handling.  Must make
+   sure that all data is freed, but if there's an error, we have to raise
+   it and the caller never gets to freed the allocated data to-date.
+   So, make sure we either free of have foreignized everything before
+   control passes out of this function. -}
+
+    do l $ "Binding col " ++ show icol ++ ": " ++ show arg
+       rc1 <- sqlDescribeParam sthptr icol pdtype pcolsize pdecdigits pnullable
+       l $ "rc1 is " ++ show (isOK rc1)
+       coltype <- if isOK rc1 then Just <$> peek pdtype else return Nothing
+       colsize <- if isOK rc1 then Just <$> peek pcolsize else return Nothing
+       decdigits <- if isOK rc1 then Just <$> peek pdecdigits else return Nothing
+       l $ "Results: " ++ show (coltype, colsize, decdigits)
+       case arg of
+         SqlNull -> -- NULL parameter, bind it as such.
+                    do l "Binding null"
+                       rc2 <- sqlBindParameter sthptr (fromIntegral icol)
+                              #{const SQL_PARAM_INPUT}
+                              #{const SQL_C_CHAR} 
+                              (fromMaybe #{const SQL_CHAR} coltype)
+                              (fromMaybe 0 colsize)
+                              (fromMaybe 0 decdigits)
+                              nullPtr 0 nullDataHDBC
+                       checkError ("bindparameter NULL " ++ show icol)
+                                      (StmtHandle sthptr) rc2
+                       return Nothing
+         x -> do -- Otherwise, we have to allocate RAM, make sure it's
+                 -- not freed now, and pass it along...
+                  boundValue <- bindSqlValue x
+                  do pcslen <- malloc 
+                     poke pcslen . fromIntegral $ bvBufferSize boundValue
+                     rc2 <- sqlBindParameter sthptr (fromIntegral icol)
+                       #{const SQL_PARAM_INPUT}
+                       (bvValueType boundValue) 
+                       (fromMaybe (bvDefaultColumnType boundValue) coltype)
+                       (fromMaybe (bvDefaultColumnSize boundValue) colsize) 
+                       (fromMaybe (bvDefaultDecDigits boundValue) decdigits)
+                       (castPtr $ bvBuffer boundValue)
+                       (bvBufferSize boundValue) 
+                       pcslen
+                     if isOK rc2
+                        then do -- We bound it.  Make foreignPtrs and return.
+                                return $ Just (pcslen, castPtr $ bvBuffer boundValue)
+                        else do -- Binding failed.  Free the data and raise
+                                -- error.
+                                free pcslen
+                                free (bvBuffer boundValue)
+                                checkError ("bindparameter " ++ show icol) 
+                                               (StmtHandle sthptr) rc2
+                                return Nothing -- will never get hit
+
+getSqlRowCount :: Ptr CStmt -> IO Int32
+getSqlRowCount cstmt = alloca $ \prows ->
+     do sqlRowCount cstmt prows >>= checkError "SQLRowCount" (StmtHandle cstmt)
+        peek prows
+        --note: As of ODBC-3.52, the row count is only a C int, ie 32bit.
+
+data BoundValue = BoundValue
+  -- | Type of the value in the buffer
+  { bvValueType         :: #{type SQLSMALLINT}
+  -- | Type of the SQL value to use if ODBC driver doesn't report one
+  , bvDefaultColumnType :: #{type SQLSMALLINT}
+  , bvDefaultColumnSize :: #{type SQLULEN}
+  , bvDefaultDecDigits  :: #{type SQLSMALLINT}
+  , bvBuffer            :: Ptr ()
+  , bvBufferSize        :: #{type SQLLEN}
+  } deriving (Show)
+
+-- | Marshals given SqlValue returning intended ValueType, default ColumnType,
+-- and a CStringLen with a buffer containing bound value. Pointer in the CStringLen 
+-- structure must be freed by caller
+bindSqlValue :: SqlValue -> IO BoundValue
+bindSqlValue sqlValue = case sqlValue of
+  SqlString s -> do
+    (wstrPtr, wstrLen) <- newCWStringLen s
+    let result = BoundValue 
+          { bvValueType         = #{const SQL_C_WCHAR}
+          , bvDefaultColumnType = #{const SQL_WCHAR}
+          , bvDefaultColumnSize = fromIntegral wstrLen
+          , bvDefaultDecDigits  = 0
+          , bvBuffer            = castPtr wstrPtr
+          , bvBufferSize        = fromIntegral $ wstrLen * #{size wchar_t}
+          }
+    l $ "bind SqlString " ++ s ++ ": " ++ show result
+    return result
+  SqlByteString bs -> B.unsafeUseAsCStringLen bs $ \(s,len) -> do
+    res <- mallocBytes len
+    copyBytes res s len
+    let result = BoundValue
+          { bvValueType         = #{const SQL_C_BINARY}
+          , bvDefaultColumnType = #{const SQL_BINARY}
+          , bvDefaultColumnSize = fromIntegral len
+          , bvDefaultDecDigits  = 0
+          , bvBuffer            = castPtr res
+          , bvBufferSize        = fromIntegral len
+          }
+    l $ "bind SqlByteString " ++ show bs ++ ": " ++ show result
+    return result
+  -- | This is rather hacky, I just replicate the behaviour of a previous version
+  x -> do
+    l $ "bind other " ++ show x
+    bsResult <- bindSqlValue $ SqlByteString (fromSql x)
+    let result = bsResult
+          { bvValueType         = #{const SQL_C_CHAR}
+          , bvDefaultColumnType = #{const SQL_CHAR}
+          }
+    l $ "bound other " ++ show x ++ ": " ++ show result
+    return result
+
+ffetchrow :: SState -> IO (Maybe [SqlValue])
+ffetchrow sstate = modifyMVar (stomv sstate) $ \stmt -> do
+  l $ "ffetchrow"
+  case stmt of
+    Nothing -> do
+      l "ffetchrow: no statement"
+      return (stmt, Nothing)
+    Just cmstmt -> withStmt cmstmt $ \cstmt -> do
+      bindCols <- getBindCols sstate cstmt
+      l "ffetchrow: fetching"
+      rc <- sqlFetch cstmt
+      if rc == #{const SQL_NO_DATA}
+        then do
+          l "ffetchrow: no more rows"
+          ffinish cmstmt
+          return (Nothing, Nothing)
+        else do
+          l "ffetchrow: fetching data"
+          checkError "sqlFetch" (StmtHandle cstmt) rc
+          sqlValues <- if rc == #{const SQL_SUCCESS} || rc == #{const SQL_SUCCESS_WITH_INFO}
+            then mapM (bindColToSqlValue cstmt) bindCols
+            else raiseError "sqlGetData" rc (StmtHandle cstmt)
+          return (stmt, Just sqlValues)
+
+getBindCols :: SState -> Ptr CStmt -> IO [(BindCol, Ptr #{type SQLLEN})]
+getBindCols sstate cstmt = do
+  l "getBindCols"
+  modifyMVar (bindColsMV sstate) $ \mBindCols ->
+    case mBindCols of
+      Nothing -> do
+        cols <- getNumResultCols cstmt
+        pBindCols <- mapM (mkBindCol sstate cstmt) [1 .. cols]
+        return (Just pBindCols, pBindCols)
+      Just bindCols -> do
+        return (mBindCols, bindCols)
+
+-- This is only for String data. For binary fix should be very easy. Just check the column type and use buflen instead of buflen - 1
+getLongColData cstmt bindCol = do
+   let (BindColString buf bufLen col) = bindCol
+   l $ "buflen: " ++ show bufLen
+   bs <- B.packCStringLen (buf, fromIntegral (bufLen - 1))
+   l $ "sql_no_total col " ++ show (BUTF8.toString bs)
+   bs2 <- getRestLongColData cstmt #{const SQL_CHAR} col bs
+   return $ SqlByteString bs2
+
+
+getRestLongColData cstmt cBinding icol acc = do
+  l "getLongColData"
+  alloca $ \plen ->
+   allocaBytes colBufSizeMaximum $ \buf ->
+     do res <- sqlGetData cstmt (fromIntegral icol) cBinding
+                          buf (fromIntegral colBufSizeMaximum) plen
+        if res == #{const SQL_SUCCESS} || res == #{const SQL_SUCCESS_WITH_INFO}
+           then do
+                len <- peek plen
+                if len == #{const SQL_NO_DATA}
+                   then return acc
+                   else do
+                        let bufmax = fromIntegral $ colBufSizeMaximum - 1
+                        bs <- B.packCStringLen (buf, fromIntegral (if len == #{const SQL_NO_TOTAL} || len > bufmax then bufmax else len))
+                        l $ "sql_no_total col is: " ++ show (BUTF8.toString bs)
+                        let newacc = B.append acc bs
+                        if len /= #{const SQL_NO_TOTAL} && len <= bufmax
+                           then return newacc
+                           else getRestLongColData cstmt cBinding icol newacc
+           else  raiseError "sqlGetData" res (StmtHandle cstmt)
+
+-- TODO: This code does not deal well with data that is extremely large,
+-- where multiple fetches are required.
+getColData cstmt cBinding icol = do
+  alloca $ \plen ->
+   allocaBytes colBufSizeDefault $ \buf ->
+     do res <- sqlGetData cstmt (fromIntegral icol) cBinding
+                          buf (fromIntegral colBufSizeDefault) plen
+        case res of
+          #{const SQL_SUCCESS} ->
+              do len <- peek plen
+                 case len of
+                   #{const SQL_NULL_DATA} -> return SqlNull
+                   #{const SQL_NO_TOTAL} -> fail $ "Unexpected SQL_NO_TOTAL"
+                   _ -> do bs <- B.packCStringLen (buf, fromIntegral len)
+                           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) cBinding
+                                 buf2 (fromIntegral len + 1) plen
+                                 >>= checkError "sqlGetData" (StmtHandle cstmt)
+                      len2 <- peek plen
+                      let firstbuf = case cBinding of
+                                       #{const SQL_C_BINARY} -> colBufSizeDefault
+                                       _ -> colBufSizeDefault - 1 -- strip off NUL
+                      bs <- liftM2 (B.append) (B.packCStringLen (buf, firstbuf))
+                            (B.packCStringLen (buf2, fromIntegral len2))
+                      l $ "col is: " ++ (BUTF8.toString bs)
+                      return (SqlByteString bs)
+          _ -> raiseError "sqlGetData" res (StmtHandle cstmt)
+
+-- | ffetchrowBaseline is used for benchmarking fetches without the
+-- overhead of marshalling values.
+ffetchrowBaseline sstate = do
+  Just cmstmt <- readMVar (stomv sstate)
+  withStmt cmstmt $ \cstmt -> do
+    rc <- sqlFetch cstmt
+    if rc == #{const SQL_NO_DATA}
+      then do ffinish cmstmt
+              return Nothing
+      else do return (Just [])
+
+data ColBuf
+
+-- These correspond to the C type identifiers found here:
+--     http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx
+-- The Ptr values point to the appropriate C types
+data BindCol
+  = BindColString  (Ptr CChar) #{type SQLLEN} #{type SQLUSMALLINT}
+  | BindColWString (Ptr CWchar) #{type SQLLEN} #{type SQLUSMALLINT}
+  | BindColBit     (Ptr CUChar)
+  | BindColTinyInt (Ptr CChar)
+  | BindColShort   (Ptr CShort)
+  | BindColLong    (Ptr CLong)
+  | BindColBigInt  (Ptr #{type SQLBIGINT})
+  | BindColFloat   (Ptr CFloat)
+  | BindColDouble  (Ptr CDouble)
+  | BindColBinary  (Ptr CUChar) #{type SQLLEN} #{type SQLUSMALLINT}
+  | BindColDate    (Ptr StructDate)
+  | BindColTime    (Ptr StructTime)
+  | BindColTimestamp (Ptr StructTimestamp)
+  | BindColGetData #{type SQLUSMALLINT}
+
+
+-- Intervals and GUIDs have not been implemented, since there is no
+-- equivalent SqlValue for these.
+--
+--  | BindColInterval
+--      typedef struct tagSQL_INTERVAL_STRUCT
+--      {
+--         SQLINTERVAL interval_type; 
+--         SQLSMALLINT interval_sign;
+--         union {
+--               SQL_YEAR_MONTH_STRUCT   year_month;
+--               SQL_DAY_SECOND_STRUCT   day_second;
+--               } intval;
+--      } SQL_INTERVAL_STRUCT;
+--      typedef enum 
+--      {
+--         SQL_IS_YEAR = 1,
+--         SQL_IS_MONTH = 2,
+--         SQL_IS_DAY = 3,
+--         SQL_IS_HOUR = 4,
+--         SQL_IS_MINUTE = 5,
+--         SQL_IS_SECOND = 6,
+--         SQL_IS_YEAR_TO_MONTH = 7,
+--         SQL_IS_DAY_TO_HOUR = 8,
+--         SQL_IS_DAY_TO_MINUTE = 9,
+--         SQL_IS_DAY_TO_SECOND = 10,
+--         SQL_IS_HOUR_TO_MINUTE = 11,
+--         SQL_IS_HOUR_TO_SECOND = 12,
+--         SQL_IS_MINUTE_TO_SECOND = 13
+--      } SQLINTERVAL;
+--      
+--      typedef struct tagSQL_YEAR_MONTH
+--      {
+--         SQLUINTEGER year;
+--         SQLUINTEGER month; 
+--      } SQL_YEAR_MONTH_STRUCT;
+--      
+--      typedef struct tagSQL_DAY_SECOND
+--      {
+--         SQLUINTEGER day;
+--         SQLUINTEGER hour;
+--         SQLUINTEGER minute;
+--         SQLUINTEGER second;
+--         SQLUINTEGER fraction;
+--      } SQL_DAY_SECOND_STRUCT;
+-- | BindColGUID (Ptr StructGUID)
+
+
+-- | StructDate is used to marshal the DATE_STRUCT
+-- This struct, and the ones which follow, are described here:
+--     http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx
+data StructDate = StructDate
+  #{type SQLSMALLINT}   -- year
+  #{type SQLUSMALLINT}  -- month
+  #{type SQLUSMALLINT}  -- day
+ deriving Show
+
+instance Storable StructDate where
+  sizeOf _    = #{size DATE_STRUCT}
+  alignment _ = alignment (undefined :: CLong)
+  poke p (StructDate year month day) = do
+    #{poke DATE_STRUCT, year}  p year
+    #{poke DATE_STRUCT, month} p month
+    #{poke DATE_STRUCT, day}   p day
+  peek p = return StructDate
+    `ap` (#{peek DATE_STRUCT, year}  p)
+    `ap` (#{peek DATE_STRUCT, month} p)
+    `ap` (#{peek DATE_STRUCT, day}   p)
+
+
+-- | StructTime is used to marshals the TIME_STRUCT:
+data StructTime = StructTime
+  #{type SQLUSMALLINT} -- hour
+  #{type SQLUSMALLINT} -- minute
+  #{type SQLUSMALLINT} -- second
+
+instance Storable StructTime where
+  sizeOf _    = #{size TIME_STRUCT}
+  alignment _ = alignment (undefined :: CLong)
+  poke p (StructTime hour minute second) = do
+    #{poke TIME_STRUCT, hour}   p hour
+    #{poke TIME_STRUCT, minute} p minute
+    #{poke TIME_STRUCT, second} p second
+  peek p = return StructTime
+    `ap` (#{peek TIME_STRUCT, hour}  p)
+    `ap` (#{peek TIME_STRUCT, minute} p)
+    `ap` (#{peek TIME_STRUCT, second}   p)
+
+-- | StructTimestamp is used to marshal the TIMESTAMP_STRUCT;
+data StructTimestamp = StructTimestamp
+  #{type SQLSMALLINT}   -- year
+  #{type SQLUSMALLINT}  -- month
+  #{type SQLUSMALLINT}  -- day
+  #{type SQLUSMALLINT}  -- hour
+  #{type SQLUSMALLINT}  -- minute
+  #{type SQLUSMALLINT}  -- second
+  #{type SQLUINTEGER}   -- fraction
+
+instance Storable StructTimestamp where
+  sizeOf _    = #{size TIMESTAMP_STRUCT}
+  alignment _ = alignment (undefined :: CLong)
+  poke p (StructTimestamp year month day hour minute second fraction) = do
+    #{poke TIMESTAMP_STRUCT, year}      p year
+    #{poke TIMESTAMP_STRUCT, month}     p month
+    #{poke TIMESTAMP_STRUCT, day}       p day
+    #{poke TIMESTAMP_STRUCT, hour}      p hour
+    #{poke TIMESTAMP_STRUCT, minute}    p minute
+    #{poke TIMESTAMP_STRUCT, second}    p second
+    #{poke TIMESTAMP_STRUCT, fraction}  p fraction
+  peek p = return StructTimestamp
+    `ap` (#{peek TIMESTAMP_STRUCT, year}     p)
+    `ap` (#{peek TIMESTAMP_STRUCT, month}    p)
+    `ap` (#{peek TIMESTAMP_STRUCT, day}      p)
+    `ap` (#{peek TIMESTAMP_STRUCT, hour}     p)
+    `ap` (#{peek TIMESTAMP_STRUCT, minute}   p)
+    `ap` (#{peek TIMESTAMP_STRUCT, second}   p)
+    `ap` (#{peek TIMESTAMP_STRUCT, fraction} p)
+
+-- | StructGUID
+-- data StructGUID = StructGUID
+--   #{type DWORD}     -- ^ Data1
+--   #{type WORD}      -- ^ Data2
+--   #{type WORD}      -- ^ Data3
+--   [#{type BYTE}]    -- ^ Data4[8]
+-- 
+-- instance Storable StructGUID where
+--   sizeOf _ = #{size SQLGUID}
+--   alignment _ = alignment (undefined :: CLong)
+--   poke p (StructGUID data1 data2 data3 data4) = do
+--     #{poke SQLGUID, Data1} p data1
+--     #{poke SQLGUID, Data2} p data2
+--     #{poke SQLGUID, Data3} p data3
+--     pokeArray (p `plusPtr` #{offset SQLGUID, Data4}) data4
+--   peek p = return StructGUID
+--     `ap` (#{peek SQLGUID, Data1} p)
+--     `ap` (#{peek SQLGUID, Data2} p)
+--     `ap` (#{peek SQLGUID, Data3} p)
+--     `ap` (peekArray 8 (p `plusPtr` #{offset SQLGUID, Data4}))
+
+
+-- | This function binds the data in a column to a value of type
+-- BindCol, using the default conversion scheme described here:
+--     http://msdn.microsoft.com/en-us/library/ms716298(v=VS.85).aspx
+-- The corresponding C types are here:
+--     http://msdn.microsoft.com/en-us/library/ms714556(v=VS.85).aspx
+-- These values are then ready for fetching.
+-- Documentation about SQLBindCol can be found here:
+--     http://msdn.microsoft.com/en-us/library/ms711010(v=vs.85).aspx
+--
+-- Our implementation follows this code:
+--     http://publib.boulder.ibm.com/infocenter/iseries/v5r3/index.jsp?topic=%2Fcli%2Frzadpfndecol.htm
+-- We have to make use of the column type and length information.
+-- These are given by SQLDescribeCol, which is stored in colinfomv.
+-- SQLDescribeCol can tell use the data type, and the size of a column (in
+-- characters, so add 1 for the null terminator), or the number of decimal
+-- digits that can be held.
+-- To find out type, and how much memory to allocate, we could also use:
+--    SQLColAttribute( ..., SQL_DESC_TYPE , ... )
+--    SQLColAttribute( ..., SQL_DESC_OCTET_LENGTH , ... )
+--
+-- Further examples of how to use SQLBindCol are here, though these make use
+-- of SQLDescribeCol:
+--     http://msdn.microsoft.com/en-us/library/ms710118(v=vs.85).aspx
+-- This implementation makes use of Column-Wise binding. Further improvements
+-- might be had by using Row-Wise binding.
+mkBindCol :: SState -> Ptr CStmt -> #{type SQLSMALLINT} -> IO (BindCol, Ptr #{type SQLLEN})
+mkBindCol sstate cstmt col = do
+  l "mkBindCol"
+  colInfo <- readMVar (colinfomv sstate)
+  let colDesc = (snd (colInfo !! ((fromIntegral col) -1)))
+  case colType colDesc of
+    SqlCharT          -> mkBindColStringEC  cstmt col' (colSize colDesc)
+    SqlVarCharT       -> mkBindColStringEC  cstmt col' (colSize colDesc)
+    SqlLongVarCharT   -> mkBindColString    cstmt col' (colSize colDesc)
+    SqlWCharT         -> mkBindColWStringEC cstmt col' (colSize colDesc)
+    SqlWVarCharT      -> mkBindColWStringEC cstmt col' (colSize colDesc)
+    SqlWLongVarCharT  -> mkBindColWString   cstmt col' (colSize colDesc)
+    SqlDecimalT       -> mkBindColString    cstmt col' (colSize colDesc)
+    SqlNumericT       -> mkBindColString    cstmt col' (colSize colDesc)
+    SqlBitT           -> mkBindColBit       cstmt col' (colSize colDesc)
+    SqlTinyIntT       -> mkBindColTinyInt   cstmt col' (colSize colDesc)
+    SqlSmallIntT      -> mkBindColShort     cstmt col' (colSize colDesc)
+    SqlIntegerT       -> mkBindColLong      cstmt col' (colSize colDesc)
+    SqlBigIntT        -> mkBindColBigInt    cstmt col' (colSize colDesc)
+    SqlRealT          -> mkBindColFloat     cstmt col' (colSize colDesc)
+    SqlFloatT         -> mkBindColDouble    cstmt col' (colSize colDesc)
+    SqlDoubleT        -> mkBindColDouble    cstmt col' (colSize colDesc)
+    SqlBinaryT        -> mkBindColBinary    cstmt col' (colSize colDesc)
+    SqlVarBinaryT     -> mkBindColBinary    cstmt col' (colSize colDesc)
+    SqlLongVarBinaryT -> mkBindColBinary    cstmt col' (colSize colDesc)
+    SqlDateT          -> mkBindColDate      cstmt col' (colSize colDesc)
+    SqlTimeT          -> mkBindColTime      cstmt col' (colSize colDesc)
+    SqlTimestampT     -> mkBindColTimestamp cstmt col' (colSize colDesc)
+--    SqlIntervalT i    -> mkBindColInterval  cstmt col' (colSize colDesc) i
+--    SqlGUIDT          -> mkBindColGUID      cstmt col' (colSize colDesc)
+    _                 -> mkBindColGetData   col'
+-- The following are not supported by ODBC:
+--    SqlUTCDateTimeT
+--    SqlUTCTimeT
+--    SqlTimeWithZoneT
+--    SqlTimestampWithZoneT
+ where
+  col' = fromIntegral col
+
+colBufSizeDefault = 1024
+colBufSizeMaximum = 4096
+
+utf8EncodingMaximum = 6
+wcSize = 2
+
+-- The functions that follow do the marshalling from C into a Haskell type
+mkBindColString cstmt col mColSize = do
+  l "mkBindCol: BindColString"
+  let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize
+  let bufLen  = sizeOf (undefined :: CChar) * (colSize + 1)
+  buf     <- mallocBytes bufLen
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColString buf (fromIntegral bufLen) col, pStrLen)
+mkBindColStringEC cstmt col = mkBindColString cstmt col . fmap (* utf8EncodingMaximum)
+mkBindColWString cstmt col mColSize = do
+  l "mkBindCol: BindColWString"
+  let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize
+  let bufLen  = sizeOf (undefined :: CWchar) * (colSize + 1)
+  buf     <- mallocBytes bufLen
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_CHAR}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColWString buf (fromIntegral bufLen) col, pStrLen)
+mkBindColWStringEC cstmt col = mkBindColString cstmt col . fmap extendFactor  where
+  extendFactor sz = sz * ((utf8EncodingMaximum + wcSize - 1) `quot` wcSize)
+mkBindColBit cstmt col mColSize = do
+  l "mkBindCol: BindColBit"
+  let bufLen  = sizeOf (undefined :: CChar)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_BIT}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColBit buf, pStrLen)
+mkBindColTinyInt cstmt col mColSize = do
+  l "mkBindCol: BindColTinyInt"
+  let bufLen  = sizeOf (undefined :: CUChar)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_STINYINT}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColTinyInt buf, pStrLen)
+mkBindColShort cstmt col mColSize = do
+  l "mkBindCol: BindColShort"
+  let bufLen  = sizeOf (undefined :: CShort)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_SSHORT}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColShort buf, pStrLen)
+mkBindColLong cstmt col mColSize = do
+  l "mkBindCol: BindColSize"
+  let bufLen  = sizeOf (undefined :: CLong)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_SLONG}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColLong buf, pStrLen)
+mkBindColBigInt cstmt col mColSize = do
+  l "mkBindCol: BindColBigInt"
+  let bufLen  = sizeOf (undefined :: CInt)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_SBIGINT}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColBigInt buf, pStrLen)
+mkBindColFloat cstmt col mColSize = do
+  l "mkBindCol: BindColFloat"
+  let bufLen  = sizeOf (undefined :: CFloat)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_FLOAT}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColFloat buf, pStrLen)
+mkBindColDouble cstmt col mColSize = do
+  l "mkBindCol: BindColDouble"
+  let bufLen  = sizeOf (undefined :: CDouble)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_DOUBLE}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColDouble buf, pStrLen)
+mkBindColBinary cstmt col mColSize = do
+  l "mkBindCol: BindColBinary"
+  let colSize = min colBufSizeMaximum $ fromMaybe colBufSizeDefault mColSize
+  let bufLen  = sizeOf (undefined :: CUChar) * (colSize + 1)
+  buf     <- mallocBytes bufLen
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_BINARY}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColBinary buf (fromIntegral bufLen) col, pStrLen)
+mkBindColDate cstmt col mColSize = do
+  l "mkBindCol: BindColDate"
+  let bufLen = sizeOf (undefined :: StructDate)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_TYPE_DATE}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColDate buf, pStrLen)
+mkBindColTime cstmt col mColSize = do
+  l "mkBindCol: BindColTime"
+  let bufLen = sizeOf (undefined :: StructTime)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_TYPE_TIME}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColTime buf, pStrLen)
+mkBindColTimestamp cstmt col mColSize = do
+  l "mkBindCol: BindColTimestamp"
+  let bufLen = sizeOf (undefined :: StructTimestamp)
+  buf     <- malloc
+  pStrLen <- malloc
+  sqlBindCol cstmt col (#{const SQL_C_TYPE_TIMESTAMP}) (castPtr buf) (fromIntegral bufLen) pStrLen
+  return (BindColTimestamp buf, pStrLen)
+mkBindColGetData col = do
+  l "mkBindCol: BindColGetData"
+  return (BindColGetData col, nullPtr)
+
+freeBindCol :: BindCol -> IO ()
+freeBindCol (BindColString   buf _ _) = free buf
+freeBindCol (BindColWString  buf _ _) = free buf
+freeBindCol (BindColBit      buf) = free buf
+freeBindCol (BindColTinyInt  buf) = free buf
+freeBindCol (BindColShort    buf) = free buf
+freeBindCol (BindColLong     buf) = free buf
+freeBindCol (BindColBigInt   buf) = free buf
+freeBindCol (BindColFloat    buf) = free buf
+freeBindCol (BindColDouble   buf) = free buf
+freeBindCol (BindColBinary   buf _ _) = free buf
+freeBindCol (BindColDate     buf) = free buf
+freeBindCol (BindColTime     buf) = free buf
+freeBindCol (BindColTimestamp buf) = free buf
+freeBindCol (BindColGetData  _ )   = return ()
+
+-- | This assumes that SQL_ATTR_MAX_LENGTH is set to zero, otherwise, we
+-- cannot detect truncated columns. See "returning Data in Bound Columns":
+--     http://msdn.microsoft.com/en-us/library/ms712424(v=vs.85).aspx
+-- Also note that the strLen value of SQL_NTS denotes a null terminated string,
+-- but is only valid as input, so we don't make use of it here:
+--     http://msdn.microsoft.com/en-us/library/ms713532(v=VS.85).aspx
+bindColToSqlValue :: Ptr CStmt -> (BindCol, Ptr #{type SQLLEN}) -> IO SqlValue
+bindColToSqlValue pcstmt (BindColGetData col, _) = do
+  l "bindColToSqlValue: BindColGetData"
+  getColData pcstmt #{const SQL_CHAR} col
+bindColToSqlValue pcstmt (bindCol, pStrLen) = do
+  l "bindColToSqlValue"
+  strLen <- peek pStrLen
+  case strLen of
+    #{const SQL_NULL_DATA} -> return SqlNull
+    #{const SQL_NO_TOTAL}  -> getLongColData pcstmt bindCol    
+    _                      -> bindColToSqlValue' pcstmt bindCol strLen
+
+-- | This is a worker function for `bindcolToSqlValue`. Note that the case
+-- where the data is null should already be handled by this stage.
+bindColToSqlValue' :: Ptr CStmt -> BindCol -> #{type SQLLEN} -> IO SqlValue
+bindColToSqlValue' pcstmt (BindColString buf bufLen col) strLen
+  | bufLen >= strLen = do
+      bs <- B.packCStringLen (buf, fromIntegral strLen)
+      l $ "bindColToSqlValue BindColString " ++ show bs ++ " " ++ show strLen
+      return $ SqlByteString bs
+  | otherwise = getColData pcstmt #{const SQL_CHAR} col
+bindColToSqlValue' pcstmt (BindColWString buf bufLen col) strLen
+  | bufLen >= strLen = do
+      bs <- B.packCStringLen (castPtr buf, fromIntegral strLen)
+      l $ "bindColToSqlValue BindColWString " ++ show bs ++ " " ++ show strLen
+      return $ SqlByteString bs
+  | otherwise = getColData pcstmt #{const SQL_CHAR} col
+bindColToSqlValue' _ (BindColBit     buf) strLen = do
+  bit <- peek buf
+  l $ "bindColToSqlValue BindColBit " ++ show bit
+  return $ SqlChar (castCUCharToChar bit)
+bindColToSqlValue' _ (BindColTinyInt buf) strLen = do
+  tinyInt <- peek buf
+  l $ "bindColToSqlValue BindColTinyInt " ++ show tinyInt
+  return $ SqlChar (castCCharToChar tinyInt)
+bindColToSqlValue' _ (BindColShort   buf) strLen = do
+  short <- peek buf
+  l $ "bindColToSqlValue BindColShort" ++ show short
+  return $ SqlInt32 (fromIntegral short)
+bindColToSqlValue' _ (BindColLong    buf) strLen = do
+  long <- peek buf
+  l $ "bindColToSqlValue BindColLong " ++ show long
+  return $ SqlInt32 (fromIntegral long)
+bindColToSqlValue' _ (BindColBigInt  buf) strLen = do
+  bigInt <- peek buf
+  l $ "bindColToSqlValue BindColBigInt " ++ show bigInt
+  return $ SqlInt64 (fromIntegral bigInt)
+bindColToSqlValue' _ (BindColFloat   buf) strLen = do
+  float <- peek buf
+  l $ "bindColToSqlValue BindColFloat " ++ show float
+  return $ SqlDouble (realToFrac float)
+bindColToSqlValue' _ (BindColDouble  buf) strLen = do
+  double <- peek buf
+  l $ "bindColToSqlValue BindColDouble " ++ show double
+  return $ SqlDouble (realToFrac double)
+bindColToSqlValue' pcstmt (BindColBinary  buf bufLen col) strLen
+  | bufLen >= strLen = do
+      bs <- B.packCStringLen (castPtr buf, fromIntegral strLen)
+      l $ "bindColToSqlValue BindColBinary " ++ show bs
+      return $ SqlByteString bs
+  | otherwise = getColData pcstmt (#{const SQL_C_BINARY}) col
+bindColToSqlValue' _ (BindColDate buf) strLen = do
+  StructDate year month day <- peek buf
+  l $ "bindColToSqlValue BindColDate"
+  return $ SqlLocalDate $ fromGregorian
+    (fromIntegral year) (fromIntegral month) (fromIntegral day)
+bindColToSqlValue' _ (BindColTime buf) strLen = do
+  StructTime hour minute second <- peek buf
+  l $ "bindColToSqlValue BindColTime"
+  return $ SqlLocalTimeOfDay $ TimeOfDay
+    (fromIntegral hour) (fromIntegral minute) (fromIntegral second)
+bindColToSqlValue' _ (BindColTimestamp buf) strLen = do
+  StructTimestamp year month day hour minute second nanosecond <- peek buf
+  l $ "bindColToSqlValue BindColTimestamp"
+  return $ SqlLocalTime $ LocalTime
+    (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))
+    (TimeOfDay (fromIntegral hour) (fromIntegral minute)
+    (fromIntegral second + (fromIntegral nanosecond / 1000000000)))
+bindColToSqlValue' _ (BindColGetData _) _ =
+  error "bindColToSqlValue': unexpected BindColGetData!"
+
+fgetcolinfo :: Ptr CStmt -> IO [(String, SqlColDesc)]
+fgetcolinfo cstmt =
+    do ncols <- getNumResultCols cstmt
+       mapM getname [1..ncols]
+    where getname icol = alloca $ \colnamelp ->
+                         allocaBytes 128 $ \cscolname ->
+                         alloca $ \datatypeptr ->
+                         alloca $ \colsizeptr ->
+                         alloca $ \nullableptr ->
+              do sqlDescribeCol cstmt icol cscolname 127 colnamelp 
+                                datatypeptr colsizeptr nullPtr nullableptr
+                 colnamelen <- peek colnamelp
+                 colnamebs <- B.packCStringLen (cscolname, fromIntegral colnamelen)
+                 let colname = BUTF8.toString colnamebs
+                 datatype <- peek datatypeptr
+                 colsize <- peek colsizeptr
+                 nullable <- peek nullableptr
+                 return $ fromOTypeInfo colname datatype colsize nullable
+
+-- FIXME: needs a faster algorithm.
+fexecutemany :: SState -> [[SqlValue]] -> IO ()
+fexecutemany sstate arglist =
+    mapM_ (fexecute sstate) arglist >> return ()
+
+-- Finish and change state
+public_ffinish :: SState -> IO ()
+public_ffinish sstate = do
+  l "public_ffinish"
+  modifyMVar_ (stomv sstate) freeMStmt
+  modifyMVar_ (bindColsMV sstate) freeBindCols
+ where
+  freeMStmt Nothing    = return Nothing
+  freeMStmt (Just sth) = ffinish sth >> return Nothing
+  freeBindCols Nothing = return Nothing
+  freeBindCols (Just bindCols) = do
+    l "public_ffinish: freeing bindcols"
+    mapM_ (\(bindCol, pSqlLen) -> freeBindCol bindCol >> free pSqlLen) bindCols
+    return Nothing
+
+ffinish :: Stmt -> IO ()
+ffinish stmt = withRawStmt stmt $ sqlFreeHandleSth_app 
+
+
+foreign import ccall safe "hdbc-odbc-helper.h wrapobjodbc"
+  wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt)
+
+foreign import #{CALLCONV} safe "sql.h SQLDescribeCol"
+  sqlDescribeCol :: Ptr CStmt   
+                 -> #{type SQLSMALLINT} -- ^ Column number
+                 -> CString     -- ^ Column name
+                 -> #{type SQLSMALLINT} -- ^ Buffer length
+                 -> Ptr (#{type SQLSMALLINT}) -- ^ name length ptr
+                 -> Ptr (#{type SQLSMALLINT}) -- ^ data type ptr
+                 -> Ptr (#{type SQLULEN}) -- ^ column size ptr
+                 -> Ptr (#{type SQLSMALLINT}) -- ^ decimal digits ptr
+                 -> Ptr (#{type SQLSMALLINT}) -- ^ nullable ptr
+                 -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLGetData"
+  sqlGetData :: Ptr CStmt       -- ^ statement handle
+             -> #{type SQLUSMALLINT} -- ^ Column number
+             -> #{type SQLSMALLINT} -- ^ target type
+             -> CString -- ^ target value pointer (void * in C)
+             -> #{type SQLLEN} -- ^ buffer len
+             -> Ptr (#{type SQLLEN})
+             -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLBindCol"
+  sqlBindCol :: Ptr CStmt            -- ^ statement handle
+             -> #{type SQLUSMALLINT} -- ^ Column number
+             -> #{type SQLSMALLINT}  -- ^ target type
+             -> Ptr ColBuf           -- ^ target value pointer (void * in C)
+             -> #{type SQLLEN}       -- ^ buffer len
+             -> Ptr (#{type SQLLEN}) -- ^ strlen_or_indptr
+             -> IO #{type SQLRETURN}
+
+foreign import ccall safe "hdbc-odbc-helper.h sqlFreeHandleSth_app"
+  sqlFreeHandleSth_app :: Ptr WrappedCStmt -> IO ()
+
+foreign import ccall safe "hdbc-odbc-helper.h &sqlFreeHandleSth_finalizer"
+  sqlFreeHandleSth_ptr :: FunPtr (Ptr WrappedCStmt -> IO ())
+
+foreign import #{CALLCONV} safe "sql.h SQLPrepare"
+  sqlPrepare :: Ptr CStmt -> CString -> #{type SQLINTEGER} 
+             -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLExecute"
+  sqlExecute :: Ptr CStmt -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLAllocHandle"
+  sqlAllocStmtHandle :: #{type SQLSMALLINT} -> Ptr CConn ->
+                        Ptr (Ptr CStmt) -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLNumResultCols"
+  sqlNumResultCols :: Ptr CStmt -> Ptr #{type SQLSMALLINT} 
+                   -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLRowCount"
+  sqlRowCount :: Ptr CStmt -> Ptr #{type SQLINTEGER} -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLBindParameter"
+  sqlBindParameter :: Ptr CStmt -- ^ Statement handle
+                   -> #{type SQLUSMALLINT} -- ^ Parameter Number
+                   -> #{type SQLSMALLINT} -- ^ Input or output
+                   -> #{type SQLSMALLINT} -- ^ Value type
+                   -> #{type SQLSMALLINT} -- ^ Parameter type
+                   -> #{type SQLULEN} -- ^ column size
+                   -> #{type SQLSMALLINT} -- ^ decimal digits
+                   -> CString   -- ^ Parameter value pointer
+                   -> #{type SQLLEN} -- ^ buffer length
+                   -> Ptr #{type SQLLEN} -- ^ strlen_or_indptr
+                   -> IO #{type SQLRETURN}
+
+foreign import ccall safe "hdbc-odbc-helper.h &nullDataHDBC"
+  nullDataHDBC :: Ptr #{type SQLLEN}
+
+foreign import #{CALLCONV} safe "sql.h SQLDescribeParam"
+  sqlDescribeParam :: Ptr CStmt 
+                   -> #{type SQLUSMALLINT} -- ^ parameter number
+                   -> Ptr #{type SQLSMALLINT} -- ^ data type ptr
+                   -> Ptr #{type SQLULEN} -- ^ parameter size ptr
+                   -> Ptr #{type SQLSMALLINT} -- ^ dec digits ptr
+                   -> Ptr #{type SQLSMALLINT} -- ^ nullable ptr
+                   -> IO #{type SQLRETURN}
+
+foreign import #{CALLCONV} safe "sql.h SQLFetch"
+  sqlFetch :: Ptr CStmt -> IO #{type SQLRETURN}
+
+foreign import ccall safe "hdbc-odbc-helper.h simpleSqlTables"
+  simpleSqlTables :: Ptr CStmt -> IO #{type SQLRETURN}
+
+foreign import ccall safe "hdbc-odbc-helper.h simpleSqlColumns"
+  simpleSqlColumns :: Ptr CStmt -> Ptr CChar -> 
+                      #{type SQLSMALLINT} -> IO #{type SQLRETURN}
+
+fgetparminfo :: Ptr CStmt -> IO [SqlColDesc]
+fgetparminfo cstmt =
+    do ncols <- getNumParams cstmt
+       mapM getname [1..ncols]
+    where getname icol = -- alloca $ \colnamelp ->
+                         -- allocaBytes 128 $ \cscolname ->
+                         alloca $ \datatypeptr ->
+                         alloca $ \colsizeptr ->
+                         alloca $ \nullableptr ->
+              do poke datatypeptr 127 -- to test if sqlDescribeParam actually writes something to the area
+                 res <- sqlDescribeParam cstmt (fromInteger $ toInteger icol) -- cscolname 127 colnamelp 
+                                  datatypeptr colsizeptr nullPtr nullableptr
+                 putStrLn $ show res
+                 -- We need proper error handling here. Not all ODBC drivers supports SQLDescribeParam.
+                 -- Not supporting SQLDescribeParam is quite allright according to the ODBC standard.
+                 datatype <- peek datatypeptr
+                 colsize  <- peek colsizeptr
+                 nullable <- peek nullableptr
+                 return $ snd $ fromOTypeInfo "" datatype colsize nullable
+
+getNumParams :: Ptr CStmt -> IO Int16
+getNumParams sthptr = alloca $ \pcount ->
+    do sqlNumParams sthptr pcount >>= checkError "SQLNumResultCols" 
+                                          (StmtHandle sthptr)
+       peek pcount
+
+foreign import #{CALLCONV} safe "sql.h SQLNumParams"
+  sqlNumParams :: Ptr CStmt -> Ptr #{type SQLSMALLINT} 
+               -> IO #{type SQLRETURN}
Database/HDBC/ODBC/TypeConv.hsc view
@@ -1,102 +1,102 @@--- -*- mode: haskell; -*--{-# CFILES hdbc-odbc-helper.c #-}--- Above line for hugs-module Database.HDBC.ODBC.TypeConv(fromOTypeInfo, fromOTypeCol) where-import Database.HDBC.Types-import Database.HDBC-import Database.HDBC.DriverUtils-import Database.HDBC.ODBC.Types-import Database.HDBC.ODBC.Utils-import Foreign.C.Types-import Foreign.ForeignPtr-import Foreign.Ptr-import Control.Concurrent.MVar-import Foreign.C.String-import Foreign.Marshal-import Foreign.Storable-import Control.Monad-import Data.List-import Data.Word-import Data.Int-import Control.Exception-import System.IO-import Data.Maybe--l _ = return ()--- l m = hPutStrLn stderr ("\n" ++ m)--#ifdef mingw32_HOST_OS-#include <windows.h>-#endif-#include <sql.h>-#include <sqlext.h>-#include <sqlucode.h>--fromOTypeInfo :: String         -- ^ Column name-              -> #{type SQLSMALLINT} -- ^ Data type-              -> #{type SQLULEN}     -- ^ Column size-              -> #{type SQLSMALLINT} -- ^ Is it nullable-              -> (String, SqlColDesc)-fromOTypeInfo colname datatype colsize nullable =-    (colname,-     SqlColDesc {colType = convdatatype datatype,-                 colOctetLength = Nothing,-                 colDecDigits = Nothing,-                 colSize = Just (fromIntegral colsize),-                 colNullable = case nullable of-                                 #{const SQL_NO_NULLS} -> Just False-                                 #{const SQL_NULLABLE} -> Just True-                                 _ -> Nothing-                }-    )--fromOTypeCol (_:_:_:colname:datatype:_:colsize:buflen:decdig:precrad:nullable:_:_:_:subtype:octetlen:_) =-    fromOTypeInfo (fromSql colname)-                  (fromIntegral ((fromSql datatype)::Int))-                  (fromSql colsize)-                  (fromIntegral ((fromSql nullable)::Int))-fromOTypeCol x = error $ "fromOTypeCol: unexpected result set: " ++ show x--convdatatype :: #{type SQLSMALLINT} -> SqlTypeId-convdatatype intype =-    case intype of-      #{const SQL_CHAR} -> SqlCharT-      #{const SQL_VARCHAR} -> SqlVarCharT-      #{const SQL_LONGVARCHAR} -> SqlLongVarCharT-      #{const SQL_WCHAR} -> SqlWCharT-      #{const SQL_WVARCHAR} -> SqlWVarCharT-      #{const SQL_WLONGVARCHAR} -> SqlWLongVarCharT-      #{const SQL_DECIMAL} -> SqlDecimalT-      #{const SQL_NUMERIC} -> SqlNumericT-      #{const SQL_SMALLINT} -> SqlSmallIntT-      #{const SQL_INTEGER} -> SqlIntegerT-      #{const SQL_REAL} -> SqlRealT-      #{const SQL_FLOAT} -> SqlFloatT-      #{const SQL_DOUBLE} -> SqlDoubleT-      #{const SQL_BIT} -> SqlBitT-      #{const SQL_TINYINT} -> SqlTinyIntT-      #{const SQL_BIGINT} -> SqlBigIntT-      #{const SQL_BINARY} -> SqlBinaryT-      #{const SQL_VARBINARY} -> SqlVarBinaryT-      #{const SQL_LONGVARBINARY} -> SqlLongVarBinaryT-      #{const SQL_TYPE_DATE} -> SqlDateT-      #{const SQL_TYPE_TIME} -> SqlTimeT-      #{const SQL_TYPE_TIMESTAMP} -> SqlTimestampT-      -- ODBC libraries don't seem to define the UTC items-       -- {const SQL_TYPE_UTCDATETIME} -> SqlUTCDateTimeT-       -- {const SQL_TYPE_UTCTIME} -> SqlUTCTimeT-      #{const SQL_INTERVAL_MONTH} -> SqlIntervalT SqlIntervalMonthT-      #{const SQL_INTERVAL_YEAR} -> SqlIntervalT SqlIntervalYearT-      #{const SQL_INTERVAL_YEAR_TO_MONTH} -> SqlIntervalT SqlIntervalYearToMonthT-      #{const SQL_INTERVAL_DAY} -> SqlIntervalT SqlIntervalDayT-      #{const SQL_INTERVAL_HOUR} -> SqlIntervalT SqlIntervalHourT-      #{const SQL_INTERVAL_MINUTE} -> SqlIntervalT SqlIntervalMinuteT-      #{const SQL_INTERVAL_SECOND} -> SqlIntervalT SqlIntervalSecondT-      #{const SQL_INTERVAL_DAY_TO_HOUR} -> SqlIntervalT SqlIntervalDayToHourT-      #{const SQL_INTERVAL_DAY_TO_MINUTE} -> SqlIntervalT SqlIntervalDayToMinuteT-      #{const SQL_INTERVAL_DAY_TO_SECOND} -> SqlIntervalT SqlIntervalDayToSecondT-      #{const SQL_INTERVAL_HOUR_TO_MINUTE} -> SqlIntervalT SqlIntervalHourToMinuteT-      #{const SQL_INTERVAL_HOUR_TO_SECOND} -> SqlIntervalT SqlIntervalHourToSecondT-      #{const SQL_INTERVAL_MINUTE_TO_SECOND} -> SqlIntervalT SqlIntervalMinuteToSecondT-      #{const SQL_GUID} -> SqlGUIDT-      x -> SqlUnknownT (show x)+-- -*- mode: haskell; -*-
+{-# CFILES hdbc-odbc-helper.c #-}
+-- Above line for hugs
+module Database.HDBC.ODBC.TypeConv(fromOTypeInfo, fromOTypeCol) where
+import Database.HDBC.Types
+import Database.HDBC
+import Database.HDBC.DriverUtils
+import Database.HDBC.ODBC.Types
+import Database.HDBC.ODBC.Utils
+import Foreign.C.Types
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Control.Concurrent.MVar
+import Foreign.C.String
+import Foreign.Marshal
+import Foreign.Storable
+import Control.Monad
+import Data.List
+import Data.Word
+import Data.Int
+import Control.Exception
+import System.IO
+import Data.Maybe
+
+l _ = return ()
+-- l m = hPutStrLn stderr ("\n" ++ m)
+
+#ifdef mingw32_HOST_OS
+#include <windows.h>
+#endif
+#include <sql.h>
+#include <sqlext.h>
+#include <sqlucode.h>
+
+fromOTypeInfo :: String         -- ^ Column name
+              -> #{type SQLSMALLINT} -- ^ Data type
+              -> #{type SQLULEN}     -- ^ Column size
+              -> #{type SQLSMALLINT} -- ^ Is it nullable
+              -> (String, SqlColDesc)
+fromOTypeInfo colname datatype colsize nullable =
+    (colname,
+     SqlColDesc {colType = convdatatype datatype,
+                 colOctetLength = Nothing,
+                 colDecDigits = Nothing,
+                 colSize = Just (fromIntegral colsize),
+                 colNullable = case nullable of
+                                 #{const SQL_NO_NULLS} -> Just False
+                                 #{const SQL_NULLABLE} -> Just True
+                                 _ -> Nothing
+                }
+    )
+
+fromOTypeCol (_:_:_:colname:datatype:_:colsize:buflen:decdig:precrad:nullable:_:_:_:subtype:octetlen:_) =
+    fromOTypeInfo (fromSql colname)
+                  (fromIntegral ((fromSql datatype)::Int))
+                  (fromSql colsize)
+                  (fromIntegral ((fromSql nullable)::Int))
+fromOTypeCol x = error $ "fromOTypeCol: unexpected result set: " ++ show x
+
+convdatatype :: #{type SQLSMALLINT} -> SqlTypeId
+convdatatype intype =
+    case intype of
+      #{const SQL_CHAR} -> SqlCharT
+      #{const SQL_VARCHAR} -> SqlVarCharT
+      #{const SQL_LONGVARCHAR} -> SqlLongVarCharT
+      #{const SQL_WCHAR} -> SqlWCharT
+      #{const SQL_WVARCHAR} -> SqlWVarCharT
+      #{const SQL_WLONGVARCHAR} -> SqlWLongVarCharT
+      #{const SQL_DECIMAL} -> SqlDecimalT
+      #{const SQL_NUMERIC} -> SqlNumericT
+      #{const SQL_SMALLINT} -> SqlSmallIntT
+      #{const SQL_INTEGER} -> SqlIntegerT
+      #{const SQL_REAL} -> SqlRealT
+      #{const SQL_FLOAT} -> SqlFloatT
+      #{const SQL_DOUBLE} -> SqlDoubleT
+      #{const SQL_BIT} -> SqlBitT
+      #{const SQL_TINYINT} -> SqlTinyIntT
+      #{const SQL_BIGINT} -> SqlBigIntT
+      #{const SQL_BINARY} -> SqlBinaryT
+      #{const SQL_VARBINARY} -> SqlVarBinaryT
+      #{const SQL_LONGVARBINARY} -> SqlLongVarBinaryT
+      #{const SQL_TYPE_DATE} -> SqlDateT
+      #{const SQL_TYPE_TIME} -> SqlTimeT
+      #{const SQL_TYPE_TIMESTAMP} -> SqlTimestampT
+      -- ODBC libraries don't seem to define the UTC items
+       -- {const SQL_TYPE_UTCDATETIME} -> SqlUTCDateTimeT
+       -- {const SQL_TYPE_UTCTIME} -> SqlUTCTimeT
+      #{const SQL_INTERVAL_MONTH} -> SqlIntervalT SqlIntervalMonthT
+      #{const SQL_INTERVAL_YEAR} -> SqlIntervalT SqlIntervalYearT
+      #{const SQL_INTERVAL_YEAR_TO_MONTH} -> SqlIntervalT SqlIntervalYearToMonthT
+      #{const SQL_INTERVAL_DAY} -> SqlIntervalT SqlIntervalDayT
+      #{const SQL_INTERVAL_HOUR} -> SqlIntervalT SqlIntervalHourT
+      #{const SQL_INTERVAL_MINUTE} -> SqlIntervalT SqlIntervalMinuteT
+      #{const SQL_INTERVAL_SECOND} -> SqlIntervalT SqlIntervalSecondT
+      #{const SQL_INTERVAL_DAY_TO_HOUR} -> SqlIntervalT SqlIntervalDayToHourT
+      #{const SQL_INTERVAL_DAY_TO_MINUTE} -> SqlIntervalT SqlIntervalDayToMinuteT
+      #{const SQL_INTERVAL_DAY_TO_SECOND} -> SqlIntervalT SqlIntervalDayToSecondT
+      #{const SQL_INTERVAL_HOUR_TO_MINUTE} -> SqlIntervalT SqlIntervalHourToMinuteT
+      #{const SQL_INTERVAL_HOUR_TO_SECOND} -> SqlIntervalT SqlIntervalHourToSecondT
+      #{const SQL_INTERVAL_MINUTE_TO_SECOND} -> SqlIntervalT SqlIntervalMinuteToSecondT
+      #{const SQL_GUID} -> SqlGUIDT
+      x -> SqlUnknownT (show x)
Database/HDBC/ODBC/Types.hs view
@@ -1,24 +1,24 @@-module Database.HDBC.ODBC.Types-where--import Foreign.ForeignPtr-import Foreign---- This may be wrong -- is SqlHandle always a pointer to something?--- but it works with hsql so I'm going to use it here until I hear of it--- breaking.---newtype SqlHandle = Ptr ()--data CEnv = CEnv-type WrappedCEnv = Ptr CEnv-type Env = ForeignPtr WrappedCEnv--data CConn = CConn-type WrappedCConn = Ptr CConn-type Conn = ForeignPtr WrappedCConn--data CStmt = CStmt-type WrappedCStmt = Ptr CStmt-type Stmt = ForeignPtr WrappedCStmt--+module Database.HDBC.ODBC.Types
+where
+
+import Foreign.ForeignPtr
+import Foreign
+
+-- This may be wrong -- is SqlHandle always a pointer to something?
+-- but it works with hsql so I'm going to use it here until I hear of it
+-- breaking.
+--newtype SqlHandle = Ptr ()
+
+data CEnv = CEnv
+type WrappedCEnv = Ptr CEnv
+type Env = ForeignPtr WrappedCEnv
+
+data CConn = CConn
+type WrappedCConn = Ptr CConn
+type Conn = ForeignPtr WrappedCConn
+
+data CStmt = CStmt
+type WrappedCStmt = Ptr CStmt
+type Stmt = ForeignPtr WrappedCStmt
+
+
Database/HDBC/ODBC/Utils.hsc view
@@ -1,127 +1,127 @@-{- -*- mode: haskell; -*- --}--module Database.HDBC.ODBC.Utils where-import Foreign.C.String-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-import Control.Exception-import Foreign.Storable-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 <windows.h>-#endif-#include "hdbc-odbc-helper.h"--#ifdef mingw32_HOST_OS-#let CALLCONV = "stdcall"-#else-#let CALLCONV = "ccall"-#endif--data SqlHandleT = EnvHandle (Ptr CEnv)-               | DbcHandle (Ptr CConn)-               | StmtHandle (Ptr CStmt)--checkError :: String -> SqlHandleT -> #{type SQLRETURN} -> IO ()-checkError msg o res =-        do let rc = sqlSucceeded res-           if rc == 0-               then raiseError msg res o-               else return ()--raiseError :: String -> #{type SQLRETURN} -> SqlHandleT -> IO a-raiseError msg code cconn =-    do info <- getdiag ht hp 1 -       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)-                          DbcHandle c -> (#{const SQL_HANDLE_DBC}, castPtr c)-                          StmtHandle c -> (#{const SQL_HANDLE_STMT}, castPtr c)-             getdiag ht hp irow = allocaBytes 6 $ \csstate ->-                                  alloca $ \pnaterr ->-                                  allocaBytes 1025 $ \csmsg ->-                                  alloca $ \pmsglen ->-                 do ret <- sqlGetDiagRec ht hp irow csstate pnaterr-                           csmsg 1024 pmsglen-                    if sqlSucceeded ret == 0-                       then return []-                       else do state <- peekCStringLen (csstate, 5)-                               nat <- peek pnaterr-                               msglen <- peek pmsglen-                               msgbs <- B.packCStringLen (csmsg,-                                                          fromIntegral msglen)-                               let msg = BUTF8.toString msgbs-                               next <- getdiag ht hp (irow + 1)-                               return $ (state, -                                         (show nat) ++ ": " ++ msg) : next--{- This is a little hairy.--We have a Conn object that is actually a finalizeonce wrapper around-the real object.  We use withConn to dereference the foreign pointer,-and then extract the pointer to the real object from the finalizeonce struct.--But, when we close the connection, we need the finalizeonce struct, so that's-done by withRawConn.--Ditto for statements. -}--withConn :: Conn -> (Ptr CConn -> IO b) -> IO b-withConn = genericUnwrap--withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b-withRawConn = withForeignPtr--withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b-withStmt = genericUnwrap--withRawStmt :: Stmt -> (Ptr WrappedCStmt -> IO b) -> IO b-withRawStmt = withForeignPtr--withEnv :: Env -> (Ptr CEnv -> IO b) -> IO b-withEnv = genericUnwrap--withRawEnv :: Env -> (Ptr WrappedCEnv -> IO b) -> IO b-withRawEnv = withForeignPtr--withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer-            -> (Ptr b -> IO ())  -- ^ Function that frees generated data-            -> [a]               -- ^ List of input data-            -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array-            -> IO c             -- ^ Return value-withAnyArr0 input2ptract freeact inp action =-    bracket (mapM input2ptract inp)-            (\clist -> mapM_ freeact clist)-            (\clist -> withArray0 nullPtr clist action)---genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b-genericUnwrap fptr action = withForeignPtr fptr (\structptr ->-    do objptr <- #{peek finalizeonce, encapobj} structptr-       action objptr-                                                )-isOK :: #{type SQLRETURN} -> Bool-isOK r = sqlSucceeded r /= 0--foreign import ccall safe "sqlSucceeded"-  sqlSucceeded :: #{type SQLRETURN} -> CInt--foreign import #{CALLCONV} safe "sql.h SQLGetDiagRec"-  sqlGetDiagRec :: #{type SQLSMALLINT} -> Ptr () -> -                   #{type SQLSMALLINT} -> CString -> Ptr (#{type SQLINTEGER})-                   -> CString -> #{type SQLSMALLINT} -                   -> Ptr (#{type SQLSMALLINT}) -> IO #{type SQLRETURN}+{- -*- mode: haskell; -*- 
+-}
+
+module Database.HDBC.ODBC.Utils where
+import Foreign.C.String
+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
+import Control.Exception
+import Foreign.Storable
+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 <windows.h>
+#endif
+#include "hdbc-odbc-helper.h"
+
+#ifdef mingw32_HOST_OS
+#let CALLCONV = "stdcall"
+#else
+#let CALLCONV = "ccall"
+#endif
+
+data SqlHandleT = EnvHandle (Ptr CEnv)
+               | DbcHandle (Ptr CConn)
+               | StmtHandle (Ptr CStmt)
+
+checkError :: String -> SqlHandleT -> #{type SQLRETURN} -> IO ()
+checkError msg o res =
+        do let rc = sqlSucceeded res
+           if rc == 0
+               then raiseError msg res o
+               else return ()
+
+raiseError :: String -> #{type SQLRETURN} -> SqlHandleT -> IO a
+raiseError msg code cconn =
+    do info <- getdiag ht hp 1 
+       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)
+                          DbcHandle c -> (#{const SQL_HANDLE_DBC}, castPtr c)
+                          StmtHandle c -> (#{const SQL_HANDLE_STMT}, castPtr c)
+             getdiag ht hp irow = allocaBytes 6 $ \csstate ->
+                                  alloca $ \pnaterr ->
+                                  allocaBytes 1025 $ \csmsg ->
+                                  alloca $ \pmsglen ->
+                 do ret <- sqlGetDiagRec ht hp irow csstate pnaterr
+                           csmsg 1024 pmsglen
+                    if sqlSucceeded ret == 0
+                       then return []
+                       else do state <- peekCStringLen (csstate, 5)
+                               nat <- peek pnaterr
+                               msglen <- peek pmsglen
+                               msgbs <- B.packCStringLen (csmsg,
+                                                          fromIntegral msglen)
+                               let msg = BUTF8.toString msgbs
+                               next <- getdiag ht hp (irow + 1)
+                               return $ (state, 
+                                         (show nat) ++ ": " ++ msg) : next
+
+{- This is a little hairy.
+
+We have a Conn object that is actually a finalizeonce wrapper around
+the real object.  We use withConn to dereference the foreign pointer,
+and then extract the pointer to the real object from the finalizeonce struct.
+
+But, when we close the connection, we need the finalizeonce struct, so that's
+done by withRawConn.
+
+Ditto for statements. -}
+
+withConn :: Conn -> (Ptr CConn -> IO b) -> IO b
+withConn = genericUnwrap
+
+withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b
+withRawConn = withForeignPtr
+
+withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b
+withStmt = genericUnwrap
+
+withRawStmt :: Stmt -> (Ptr WrappedCStmt -> IO b) -> IO b
+withRawStmt = withForeignPtr
+
+withEnv :: Env -> (Ptr CEnv -> IO b) -> IO b
+withEnv = genericUnwrap
+
+withRawEnv :: Env -> (Ptr WrappedCEnv -> IO b) -> IO b
+withRawEnv = withForeignPtr
+
+withAnyArr0 :: (a -> IO (Ptr b)) -- ^ Function that transforms input data into pointer
+            -> (Ptr b -> IO ())  -- ^ Function that frees generated data
+            -> [a]               -- ^ List of input data
+            -> (Ptr (Ptr b) -> IO c) -- ^ Action to run with the C array
+            -> IO c             -- ^ Return value
+withAnyArr0 input2ptract freeact inp action =
+    bracket (mapM input2ptract inp)
+            (\clist -> mapM_ freeact clist)
+            (\clist -> withArray0 nullPtr clist action)
+
+
+genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b
+genericUnwrap fptr action = withForeignPtr fptr (\structptr ->
+    do objptr <- #{peek finalizeonce, encapobj} structptr
+       action objptr
+                                                )
+isOK :: #{type SQLRETURN} -> Bool
+isOK r = sqlSucceeded r /= 0
+
+foreign import ccall safe "sqlSucceeded"
+  sqlSucceeded :: #{type SQLRETURN} -> CInt
+
+foreign import #{CALLCONV} safe "sql.h SQLGetDiagRec"
+  sqlGetDiagRec :: #{type SQLSMALLINT} -> Ptr () -> 
+                   #{type SQLSMALLINT} -> CString -> Ptr (#{type SQLINTEGER})
+                   -> CString -> #{type SQLSMALLINT} 
+                   -> Ptr (#{type SQLSMALLINT}) -> IO #{type SQLRETURN}
HDBC-odbc.cabal view
@@ -1,92 +1,107 @@-Name: HDBC-odbc-Version: 2.3.1.1-Cabal-Version: >=1.2.3-Build-type: Simple-License: BSD3-Maintainer: Nicolas Wu <nicolas.wu@gmail.com>-Author: John Goerzen-Copyright: Copyright (c) 2005-2011 John Goerzen-license-file: LICENSE-extra-source-files: LICENSE, hdbc-odbc-helper.h,-                    Makefile,-                    README.md,-                    testsrc/TestTime.hs-homepage: https://github.com/hdbc/hdbc-odbc-Category: Database-synopsis: ODBC driver for HDBC-Description: This package provides an ODBC database backend for HDBC.- It is cross-platform and supports unixODBC on Unix/Linux/POSIX platforms- and Microsoft ODBC on Windows.  It is also the preferred way to access- MySQL databases from Haskell.-Stability: Beta-Cabal-Version: >=1.6--Flag buildtests-  description: Build the executable to run unit tests-  default: False--source-repository head-  type:     git-  location: https://github.com/hdbc/hdbc-odbc.git--Library-  Exposed-Modules: Database.HDBC.ODBC-  Other-Modules: Database.HDBC.ODBC.Connection,-    Database.HDBC.ODBC.Statement,-    Database.HDBC.ODBC.Types,-    Database.HDBC.ODBC.Utils,-    Database.HDBC.ODBC.TypeConv,-    Database.HDBC.ODBC.ConnectionImpl-  Extensions: -    ExistentialQuantification,-    ForeignFunctionInterface,-    ScopedTypeVariables-  Build-Depends: base >= 4.3.1.0 && < 5-               , mtl-               , HDBC>=2.1.0-               , time>=1.2.0.3-               , utf8-string-               , bytestring-  GHC-Options: -O2-  C-Sources: hdbc-odbc-helper.c-  if os(mingw32) || os(win32)-    Extra-Libraries: odbc32-  else-    Extra-Libraries: odbc-  include-dirs: .-  -- extra-lib-dirs: --Executable runtests-  if flag(buildtests)-    Buildable: True-    Build-Depends: HUnit, QuickCheck, testpack, containers, old-time,-                   time, old-locale, convertible-  else-    Buildable: False-  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+Name: HDBC-odbc
+Version: 2.4.0.0
+Cabal-Version: >=1.8
+Build-type: Simple
+License: BSD3
+Maintainer: Anton Dessiatov <anton.dessiatov@gmail.com>
+            Nicolas Wu <nicolas.wu@gmail.com>
+Author: John Goerzen
+Copyright: Copyright (c) 2005-2011 John Goerzen
+license-file: LICENSE
+extra-source-files: LICENSE, hdbc-odbc-helper.h,
+                    Makefile,
+                    README.md,
+                    testsrc/TestTime.hs
+                    changelog.txt
+homepage: https://github.com/hdbc/hdbc-odbc
+Category: Database
+synopsis: ODBC driver for HDBC
+Description: This package provides an ODBC database backend for HDBC.
+ It is cross-platform and supports unixODBC on Unix/Linux/POSIX platforms
+ and Microsoft ODBC on Windows.  It is also the preferred way to access
+ MySQL databases from Haskell.
+Stability: Beta
+
+Flag buildtests
+  description: Build the executable to run unit tests
+  default: False
+
+Flag buildstresstest
+  description: Build the stress testing executable
+  default: False
+
+Library
+  Exposed-Modules: Database.HDBC.ODBC
+  Other-Modules: Database.HDBC.ODBC.Connection,
+    Database.HDBC.ODBC.Statement,
+    Database.HDBC.ODBC.Types,
+    Database.HDBC.ODBC.Utils,
+    Database.HDBC.ODBC.TypeConv,
+    Database.HDBC.ODBC.ConnectionImpl
+  Extensions:
+    ExistentialQuantification,
+    ForeignFunctionInterface,
+    ScopedTypeVariables
+  Build-Depends: base >= 4.3.1.0 && < 5
+               , mtl
+               , HDBC>=2.1.0
+               , time>=1.2.0.3
+               , utf8-string
+               , bytestring
+  C-Sources: hdbc-odbc-helper.c
+  if os(mingw32) || os(win32)
+    Extra-Libraries: odbc32
+  else
+    Extra-Libraries: odbc
+  include-dirs: .
+  -- extra-lib-dirs:
+
+Executable runtests
+  if flag(buildtests)
+    Buildable: True
+    Build-Depends: HUnit, QuickCheck, testpack, containers, old-time,
+                   time, old-locale, convertible
+  else
+    Buildable: False
+  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
+
+Executable stresstest
+  if flag(buildstresstest)
+    Buildable: True
+    Build-Depends:
+        base
+      , HDBC
+      , HDBC-odbc
+      , random
+      , resource-pool
+  else
+    Buildable: False
+  Main-Is: stresstest.hs
+  Hs-Source-Dirs: stresstest
+  GHC-Options: -threaded -rtsopts
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) 2005-2011, John Goerzen-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--* Redistributions of source code must retain the above copyright notice, this-  list of conditions and the following disclaimer.--* Redistributions in binary form must reproduce the above copyright notice, this-  list of conditions and the following disclaimer in the documentation and/or-  other materials provided with the distribution.--* Neither the name of John Goerzen nor the names of its-  contributors may be used to endorse or promote products derived from this-  software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND-ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,-OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2005-2011, John Goerzen
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice, this
+  list of conditions and the following disclaimer in the documentation and/or
+  other materials provided with the distribution.
+
+* Neither the name of John Goerzen nor the names of its
+  contributors may be used to endorse or promote products derived from this
+  software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Makefile view
@@ -1,36 +1,36 @@-all: setup-	@echo "Please use Cabal to build this package; not make."-	./setup configure-	./setup build--setup: Setup.hs-	ghc --make -package Cabal -o setup Setup.hs--install: setup-	./setup install--clean:-	-runghc Setup.hs clean-	-rm -rf html `find . -name "*.o"` `find . -name "*.hi" | grep -v debian` \-		`find . -name "*~" | grep -v debian` *.a setup dist testsrc/runtests \-		local-pkg doctmp-	-rm -rf testtmp/* testtmp*--.PHONY: test-test: test-ghc test-hugs-	@echo ""-	@echo "All tests pass."--test-hugs: setup-	@echo " ****** Running hugs tests"-	./setup configure -f buildtests --hugs --extra-include-dirs=/usr/lib/hugs/include-	./setup build-	runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \-		dist/scratch/programs/runtests/Main.hs--test-ghc: setup-	@echo " ****** Building GHC tests"-	./setup configure -f buildtests-	./setup build-	@echo " ****** Running GHC tests"-	./dist/build/runtests/runtests+all: setup
+	@echo "Please use Cabal to build this package; not make."
+	./setup configure
+	./setup build
+
+setup: Setup.hs
+	ghc --make -package Cabal -o setup Setup.hs
+
+install: setup
+	./setup install
+
+clean:
+	-runghc Setup.hs clean
+	-rm -rf html `find . -name "*.o"` `find . -name "*.hi" | grep -v debian` \
+		`find . -name "*~" | grep -v debian` *.a setup dist testsrc/runtests \
+		local-pkg doctmp
+	-rm -rf testtmp/* testtmp*
+
+.PHONY: test
+test: test-ghc test-hugs
+	@echo ""
+	@echo "All tests pass."
+
+test-hugs: setup
+	@echo " ****** Running hugs tests"
+	./setup configure -f buildtests --hugs --extra-include-dirs=/usr/lib/hugs/include
+	./setup build
+	runhugs -98 +o -P$(PWD)/dist/scratch:$(PWD)/dist/scratch/programs/runtests: \
+		dist/scratch/programs/runtests/Main.hs
+
+test-ghc: setup
+	@echo " ****** Building GHC tests"
+	./setup configure -f buildtests
+	./setup build
+	@echo " ****** Running GHC tests"
+	./dist/build/runtests/runtests
README.md view
@@ -1,103 +1,103 @@-HDBC-ODBC-=========--Welcome to HDBC, Haskell Database Connectivity.--This package provides a database backend driver for ODBC.  You should-be able to use any ODBC front-end with it.--Please see HDBC itself for documentation on use.--This package provides one function in module Database.HDBC.ODBC:--    -- | Connect to an ODBC server.-    --   For information on the meaning of the passed string, please see:-    -- <http://msdn.microsoft.com/library/default.asp?url=/library/en-us/odbc/htm/odbcsqldrivers.asp>-    connectODBC :: String -> IO Connection--For example, you might use `connectODBC` as follows:--    connectODBC "DSN=hdbctest1"--For more information about HDBC-ODBC,-please visit the [wiki](https://github.com/hdbc/hdbc-odbc/wiki).--Differences from HDBC standard---------------------------------None known at this time.--MySQL note-------------Important note for MySQL users:--Unless you are going to use InnoDB tables, you are strongly encouraged to set--    Option = 262144--in your odbc.ini (for Unix users), or to disable transaction support in your-DSN setup for Windows users.--If you fail to do this, the MySQL ODBC driver will incorrectly state that it-supports transactions.  dbTransactionSupport will incorrectly return True.-commit and rollback will then silently fail.  This is certainly *NOT* what you-want.  It is a bug (or misfeature) in the MySQL driver, not in HDBC.--You should ignore this advice if you are using InnoDB tables.--For the error "2013: Mysql server has gone away" error message, you'll have to-use withRTSSignalsBlocked from the HDBC-mysql package.--query conn stmStr binds = withRTSSignalsBlocked $ quickQuery conn stmStr binds--Getting Started------------------Here are some instructions to set up ODBC with a sqlite3 backend, and how-to communicate with that database with HDBC-ODBC.-These instructions are written to work with Ubuntu 11.10.--First, we'll need to install the appropriate libraries:--    sudo apt-get install unixodbc unixodbc-dev unixodbc-bin-    sudo apt-get install libsqliteodbc--Verify that the sqlite ODBC drivers have been set up correctly:--    odbcinst -q -d-This should return:--    [SQLite]-    [SQLite3]--Next, fire up the `ODBCConfig` too to set up a new DSN:--    ODBCConfig--If you want to run the HDBC test suite, then set your DSN to `hdbctest`,-and set up to connect to a database of your choice, such as an empty file-in the `hdbc-odbc/testsrc` directory:--    touch hdbc-odbc/testsrc/hdbctest.db--You can check that everything is working appropriately in ghci:--    ghci> :m + Database.HDBC Database.HDBC.ODBC-    ghci> conn <- connectODBC "DSN=hdbctest"-    ghci> hdbcDriverName conn-    "odbc"-    ghci> hdbcClientVer conn-    "03.52"--You can then run some tests on your database:--    cd testsrc-    runhaskell runtests.hs--Contributing---------------Contributions are welcome! If you would like to contribute, please fork the the-[github repository](https://github.com/hdbc/hdbc-odbc), and submit a pull-request.+HDBC-ODBC
+=========
+
+Welcome to HDBC, Haskell Database Connectivity.
+
+This package provides a database backend driver for ODBC.  You should
+be able to use any ODBC front-end with it.
+
+Please see HDBC itself for documentation on use.
+
+This package provides one function in module Database.HDBC.ODBC:
+
+    -- | Connect to an ODBC server.
+    --   For information on the meaning of the passed string, please see:
+    -- <http://msdn.microsoft.com/library/default.asp?url=/library/en-us/odbc/htm/odbcsqldrivers.asp>
+    connectODBC :: String -> IO Connection
+
+For example, you might use `connectODBC` as follows:
+
+    connectODBC "DSN=hdbctest1"
+
+For more information about HDBC-ODBC,
+please visit the [wiki](https://github.com/hdbc/hdbc-odbc/wiki).
+
+Differences from HDBC standard
+------------------------------
+
+None known at this time.
+
+MySQL note
+----------
+
+Important note for MySQL users:
+
+Unless you are going to use InnoDB tables, you are strongly encouraged to set
+
+    Option = 262144
+
+in your odbc.ini (for Unix users), or to disable transaction support in your
+DSN setup for Windows users.
+
+If you fail to do this, the MySQL ODBC driver will incorrectly state that it
+supports transactions.  dbTransactionSupport will incorrectly return True.
+commit and rollback will then silently fail.  This is certainly *NOT* what you
+want.  It is a bug (or misfeature) in the MySQL driver, not in HDBC.
+
+You should ignore this advice if you are using InnoDB tables.
+
+For the error "2013: Mysql server has gone away" error message, you'll have to
+use withRTSSignalsBlocked from the HDBC-mysql package.
+
+query conn stmStr binds = withRTSSignalsBlocked $ quickQuery conn stmStr binds
+
+Getting Started
+---------------
+
+Here are some instructions to set up ODBC with a sqlite3 backend, and how
+to communicate with that database with HDBC-ODBC.
+These instructions are written to work with Ubuntu 11.10.
+
+First, we'll need to install the appropriate libraries:
+
+    sudo apt-get install unixodbc unixodbc-dev unixodbc-bin
+    sudo apt-get install libsqliteodbc
+
+Verify that the sqlite ODBC drivers have been set up correctly:
+
+    odbcinst -q -d
+This should return:
+
+    [SQLite]
+    [SQLite3]
+
+Next, fire up the `ODBCConfig` too to set up a new DSN:
+
+    ODBCConfig
+
+If you want to run the HDBC test suite, then set your DSN to `hdbctest`,
+and set up to connect to a database of your choice, such as an empty file
+in the `hdbc-odbc/testsrc` directory:
+
+    touch hdbc-odbc/testsrc/hdbctest.db
+
+You can check that everything is working appropriately in ghci:
+
+    ghci> :m + Database.HDBC Database.HDBC.ODBC
+    ghci> conn <- connectODBC "DSN=hdbctest"
+    ghci> hdbcDriverName conn
+    "odbc"
+    ghci> hdbcClientVer conn
+    "03.52"
+
+You can then run some tests on your database:
+
+    cd testsrc
+    runhaskell runtests.hs
+
+Contributing
+------------
+
+Contributions are welcome! If you would like to contribute, please fork the the
+[github repository](https://github.com/hdbc/hdbc-odbc), and submit a pull
+request.
Setup.hs view
@@ -1,5 +1,5 @@-#!/usr/bin/env runhaskell--import Distribution.Simple--main = defaultMain+#!/usr/bin/env runhaskell
+
+import Distribution.Simple
+
+main = defaultMain
+ changelog.txt view
@@ -0,0 +1,10 @@+2.4.0.0 - 12 Nov 2014
+
+  * Changed parameter binding implementation to fix bugs with wide character strings and binary
+    data not handled well with Microsoft SQL Server on Windows.
+
+  * Implemented atomic reference counting to avoid race conditions in native code when running
+    with -threaded
+
+  * Implemented workaround for the SQL Server ODBC Driver deadlock, which occured if cursor over a
+    statement that was in the process of fetching data over the network got closed.
hdbc-odbc-helper.c view
@@ -1,137 +1,157 @@-#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)-#include <windows.h>-#include <winnt.h>-#endif-#include <sql.h>-#include <sqlext.h>-#include <stdio.h>-#include <stdlib.h>-#include "hdbc-odbc-helper.h"--SQLLEN nullDataHDBC = SQL_NULL_DATA;--int sqlSucceeded(SQLRETURN ret) {-  return SQL_SUCCEEDED(ret);-}--/* Things can't finalize more than once.  -We'd like to let people call them from the app.-Yet we'd also like to be able to have a ForeignPtr finalize them.--So, here's a little wrapper for things. */--void dbc_conditional_finalizer(finalizeonce *conn);--finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj) {-  finalizeonce *newobj;-  newobj = malloc(sizeof(finalizeonce));-  if (newobj == NULL) {-    fprintf(stderr, "\nHDBC: could not allocate wrapper!\n");-    return NULL;-  }-  newobj->isfinalized = 0;-  newobj -> refcount = 1;-  newobj->encapobj = obj;-  newobj->extrainfo = NULL;-  newobj->parent = parentobj;-  if (parentobj != NULL)-    (parentobj->refcount)++;-#ifdef HDBC_DEBUG-  fprintf(stderr, "\nWrapped %p at %p\n", obj, newobj);-#endif-  return newobj;-}--finalizeonce *wrapobjodbc_extra(void *obj, void *extra, finalizeonce *parentobj) {-  finalizeonce *newobj = wrapobjodbc(obj, parentobj);-  if (newobj != NULL)-    newobj->extrainfo = extra;-  return newobj;-}-  -void sqlFreeHandleSth_app(finalizeonce *res) {-#ifdef HDBC_DEBUG-  fprintf(stderr, "\nApp cleanup of sth %p requested: %d\n", -          res->encapobj, res->isfinalized);-#endif-  if (res->isfinalized)-    return;-  SQLCloseCursor((SQLHSTMT) (res->encapobj));-  SQLFreeHandle(SQL_HANDLE_STMT, (SQLHANDLE) (res->encapobj));-  res->isfinalized = 1;-  res->encapobj = NULL;-}--void sqlFreeHandleSth_finalizer(finalizeonce *res) {-#ifdef HDBC_DEBUG-  fprintf(stderr, "\nFinalizer cleanup of sth %p requested: %d\n", -          res->encapobj, res->isfinalized);-#endif-  sqlFreeHandleSth_app(res);-  (res->refcount)--;            /* Not really important since this is never a -                                   parent */-  (res->parent->refcount)--;-  dbc_conditional_finalizer(res->parent);-  free(res);-}--SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res) {-  SQLRETURN retval;-#ifdef HDBC_DEBUG-  fprintf(stderr, "\nApp cleanup of dbc %p requested: %d\n", -          res->encapobj, res->isfinalized);-#endif-  if (res->isfinalized)-    return 0;-  retval = SQLDisconnect((SQLHDBC) (res->encapobj));-  if (SQL_SUCCEEDED(retval)) {-    SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj));-    SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo));-    res->isfinalized = 1;-    res->encapobj = NULL;-  }-  return retval;-}--void sqlFreeHandleDbc_finalizer(finalizeonce *res) {-#ifdef HDBC_DEBUG-  fprintf(stderr, "\nFinalizer cleanup of dbc %p requested: %d\n", -          res->encapobj, res->isfinalized);-#endif-  (res->refcount)--;-  dbc_conditional_finalizer(res);-}--void dbc_conditional_finalizer(finalizeonce *res) {-  if (res->refcount < 1) {-  /* Don't use sqlFreeHandleDbc_app here, because we want to clear it out-     regardless of the success or failues of SQLDisconnect. */-    if (! (res->isfinalized)) {-      SQLDisconnect((SQLHDBC) (res->encapobj));-      SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj));-      SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo));-      res->encapobj = NULL;-      res->isfinalized = 1;-    }-    free(res);-  }-}--void *getSqlOvOdbc3(void) {-  return (void *)SQL_OV_ODBC3;-}--SQLRETURN disableAutoCommit(SQLHDBC conn) {-  return SQLSetConnectAttr(conn, SQL_ATTR_AUTOCOMMIT, -                           (SQLPOINTER) SQL_AUTOCOMMIT_OFF,-                           SQL_IS_UINTEGER);-}--SQLRETURN simpleSqlTables(SQLHSTMT stmt) {-  return SQLTables(stmt, NULL, 0, NULL, 0, "%", 1, "TABLE", 5);-}--SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, -                           SQLSMALLINT tnlen) {-  return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, "%", 1);-}+#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)
+#define ON_WINDOWS
+#include <windows.h>
+#include <winnt.h>
+#endif
+#include <sql.h>
+#include <sqlext.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include "hdbc-odbc-helper.h"
+
+SQLLEN nullDataHDBC = SQL_NULL_DATA;
+
+int sqlSucceeded(SQLRETURN ret) {
+  return SQL_SUCCEEDED(ret);
+}
+
+#ifdef ON_WINDOWS
+#define odbc_sync_val_compare_and_swap(ptr, oldval, newval) InterlockedCompareExchange((volatile LONG*)(ptr), (newval), (oldval))
+#define odbc_atomic_increment(ptr) InterlockedIncrement((volatile LONG*)(ptr))
+#define odbc_atomic_decrement(ptr) InterlockedDecrement((volatile LONG*)(ptr))
+#else
+#define odbc_sync_val_compare_and_swap(ptr, oldval, newval) __sync_val_compare_and_swap((ptr), (oldval), (newval))
+#define odbc_atomic_increment(ptr) __sync_add_and_fetch((ptr), 1)
+#define odbc_atomic_decrement(ptr) __sync_sub_and_fetch((ptr), 1)
+#endif
+
+/* Things can't finalize more than once.
+We'd like to let people call them from the app.
+Yet we'd also like to be able to have a ForeignPtr finalize them.
+
+So, here's a little wrapper for things. */
+
+void dbc_conditional_finalizer(finalizeonce *conn, int refCount);
+
+finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj) {
+  // parentobj might not get finalized during running this function
+  // from other thread because of the way it is called from Haskell
+  // side.
+  finalizeonce *newobj;
+  newobj = malloc(sizeof(finalizeonce));
+  if (newobj == NULL) {
+    fprintf(stderr, "\nHDBC: could not allocate wrapper!\n");
+    return NULL;
+  }
+  newobj->isfinalized = 0;
+  newobj -> refcount = 1;
+  newobj->encapobj = obj;
+  newobj->extrainfo = NULL;
+  newobj->parent = parentobj;
+  if (parentobj != NULL) {
+    __sync_add_and_fetch(&parentobj->refcount, 1);
+  }
+#ifdef HDBC_DEBUG
+  fprintf(stderr, "\nWrapped %p at %p\n", obj, newobj);
+#endif
+  return newobj;
+}
+
+finalizeonce *wrapobjodbc_extra(void *obj, void *extra, finalizeonce *parentobj) {
+  finalizeonce *newobj = wrapobjodbc(obj, parentobj);
+  if (newobj != NULL)
+    newobj->extrainfo = extra;
+  return newobj;
+}
+
+void sqlFreeHandleSth_app(finalizeonce *res) {
+#ifdef HDBC_DEBUG
+  fprintf(stderr, "\nApp cleanup of sth %p requested: %d\n",
+          res->encapobj, res->isfinalized);
+#endif
+  int isFinalized = odbc_sync_val_compare_and_swap(&res->isfinalized, 0, 1);
+  if (isFinalized)
+    return;
+  // Microsoft SQL Server driver might deadlock if calling SQLCloseCursor on a statement that is in the
+  // process of fetching data via network. So we cancel it first.
+  SQLCancel((SQLHSTMT) (res->encapobj));
+  SQLCloseCursor((SQLHSTMT) (res->encapobj));
+  SQLFreeHandle(SQL_HANDLE_STMT, (SQLHANDLE) (res->encapobj));
+  res->encapobj = NULL;
+}
+
+void sqlFreeHandleSth_finalizer(finalizeonce *res) {
+#ifdef HDBC_DEBUG
+  fprintf(stderr, "\nFinalizer cleanup of sth %p requested: %d\n",
+          res->encapobj, res->isfinalized);
+#endif
+  sqlFreeHandleSth_app(res);
+
+  /* Not really important since this is never a parent */
+  odbc_atomic_decrement(&res->refcount);
+
+  int parentRefCount = odbc_atomic_decrement(&res->parent->refcount);
+  dbc_conditional_finalizer(res->parent, parentRefCount);
+  free(res);
+}
+
+SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res) {
+  SQLRETURN retval;
+#ifdef HDBC_DEBUG
+  fprintf(stderr, "\nApp cleanup of dbc %p requested: %d\n",
+          res->encapobj, res->isfinalized);
+#endif
+  int isFinalized = odbc_sync_val_compare_and_swap(&res->isfinalized, 0, 1);
+  if (isFinalized)
+    return 0;
+  retval = SQLDisconnect((SQLHDBC) (res->encapobj));
+  if (SQL_SUCCEEDED(retval)) {
+    SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj));
+    SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo));
+    res->encapobj = NULL;
+  }
+  return retval;
+}
+
+void sqlFreeHandleDbc_finalizer(finalizeonce *res) {
+#ifdef HDBC_DEBUG
+  fprintf(stderr, "\nFinalizer cleanup of dbc %p requested: %d\n",
+          res->encapobj, res->isfinalized);
+#endif
+  int refCount = odbc_atomic_decrement(&res->refcount);
+  dbc_conditional_finalizer(res, refCount);
+}
+
+void dbc_conditional_finalizer(finalizeonce *res, int refcount) {
+  if (refcount < 1) {
+  /* Don't use sqlFreeHandleDbc_app here, because we want to clear it out
+     regardless of the success or failues of SQLDisconnect. */
+    int isFinalized = odbc_sync_val_compare_and_swap(&res->isfinalized, 0, 1);
+    if (!isFinalized) {
+      SQLDisconnect((SQLHDBC) (res->encapobj));
+      SQLFreeHandle(SQL_HANDLE_DBC, (SQLHANDLE) (res->encapobj));
+      SQLFreeHandle(SQL_HANDLE_ENV, (SQLHANDLE) (res->extrainfo));
+      res->encapobj = NULL;
+    }
+    free(res);
+  }
+}
+
+void *getSqlOvOdbc3(void) {
+  return (void *)SQL_OV_ODBC3;
+}
+
+SQLRETURN disableAutoCommit(SQLHDBC conn) {
+  return SQLSetConnectAttr(conn, SQL_ATTR_AUTOCOMMIT,
+                           (SQLPOINTER) SQL_AUTOCOMMIT_OFF,
+                           SQL_IS_UINTEGER);
+}
+
+SQLRETURN simpleSqlTables(SQLHSTMT stmt) {
+  return SQLTables(stmt, NULL, 0, NULL, 0, "%", 1, "TABLE", 5);
+}
+
+SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename,
+                           SQLSMALLINT tnlen) {
+  return SQLColumns(stmt, NULL, 0, NULL, 0, tablename, tnlen, "%", 1);
+}
hdbc-odbc-helper.h view
@@ -1,35 +1,35 @@-#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)-#include <windows.h>-#include <winnt.h>-#endif-#include <sql.h>--extern int sqlSucceeded(SQLRETURN ret);-extern SQLRETURN sqlFreeHandleEnv(SQLHANDLE hdl);--typedef struct TAG_finalizeonce {-  void *encapobj;-  int refcount;-  int isfinalized;-  void *extrainfo;-  struct TAG_finalizeonce *parent;-} finalizeonce;--extern finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj);-extern finalizeonce *wrapobjodbc_extra(void *obj, void *extra,-                                       finalizeonce *parentobj);--extern SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res);-extern void sqlFreeHandleDbc_finalizer(finalizeonce *res);--extern void sqlFreeHandleSth_app(finalizeonce *res);-extern void sqlFreeHandleSth_finalizer(finalizeonce *res);--extern SQLLEN nullDataHDBC;-extern void *getSqlOvOdbc3(void);--extern SQLRETURN disableAutoCommit(SQLHDBC conn);-extern SQLRETURN simpleSqlTables(SQLHSTMT stmt);-extern SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, -                                  SQLSMALLINT tnlen);-+#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)
+#include <windows.h>
+#include <winnt.h>
+#endif
+#include <sql.h>
+
+extern int sqlSucceeded(SQLRETURN ret);
+extern SQLRETURN sqlFreeHandleEnv(SQLHANDLE hdl);
+
+typedef struct TAG_finalizeonce {
+  void *encapobj;
+  int refcount;
+  int isfinalized;
+  void *extrainfo;
+  struct TAG_finalizeonce *parent;
+} finalizeonce;
+
+extern finalizeonce *wrapobjodbc(void *obj, finalizeonce *parentobj);
+extern finalizeonce *wrapobjodbc_extra(void *obj, void *extra,
+                                       finalizeonce *parentobj);
+
+extern SQLRETURN sqlFreeHandleDbc_app(finalizeonce *res);
+extern void sqlFreeHandleDbc_finalizer(finalizeonce *res);
+
+extern void sqlFreeHandleSth_app(finalizeonce *res);
+extern void sqlFreeHandleSth_finalizer(finalizeonce *res);
+
+extern SQLLEN nullDataHDBC;
+extern void *getSqlOvOdbc3(void);
+
+extern SQLRETURN disableAutoCommit(SQLHDBC conn);
+extern SQLRETURN simpleSqlTables(SQLHSTMT stmt);
+extern SQLRETURN simpleSqlColumns(SQLHSTMT stmt, SQLCHAR *tablename, 
+                                  SQLSMALLINT tnlen);
+
+ stresstest/stresstest.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns #-}
+module Main where
+
+import Control.Applicative
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Database.HDBC
+import Data.Pool
+import System.IO
+import System.Random
+
+import Database.HDBC.ODBC
+
+connectionString :: String
+connectionString = "DSN=hdbctest"
+
+threadNumber :: Int
+threadNumber = 4
+
+prepareDatabase :: Pool ConnWrapper -> IO ()
+prepareDatabase pool = withResource pool $ \conn -> withTransaction conn $ \tran ->
+  void $ run tran
+    "if not exists (select * from sysobjects where name='test_table' and xtype='U') \
+    \create table test_table ( \
+      \id int identity not null, \
+      \value nvarchar(64) not null \
+    \)" []
+
+writerThread :: Pool ConnWrapper -> IO ()
+writerThread pool = forever $ withResource pool $ \conn -> do
+  len <- randomRIO (1, 64)
+  value <- replicateM len $ randomRIO ('a', 'z')
+  void $ do
+    run conn "insert into test_table (value) values (?)" [SqlString value]
+    commit conn
+
+readerThread :: Pool ConnWrapper -> IO ()
+readerThread pool = forever $ withResource pool $ \conn -> forever $ do
+  !offset <- randomRIO (1, 100000) :: IO Int
+  !limit <- randomRIO (1, 60) :: IO Int
+  sth <- prepare conn $ "select * from test_table order by id offset " ++ show offset ++ " rows fetch next " ++ show limit ++ " rows only"
+  execute sth []
+  results <- fetchAllRows' sth
+  finish sth
+  return ()
+
+main :: IO ()
+main = handleSqlError $ bracket (createPool (ConnWrapper <$> connectODBC connectionString) disconnect 1 20 2) destroyAllResources $ \pool -> do
+  prepareDatabase pool
+  forkIO $ writerThread pool
+  replicateM_ threadNumber . forkIO $
+    readerThread pool
+  hSetBuffering stdin NoBuffering
+  void getChar
testsrc/SpecificDB.hs view
@@ -1,24 +1,24 @@-module SpecificDB where-import Database.HDBC-import Database.HDBC.ODBC-import Test.HUnit--connectDB = -    handleSqlError (connectODBC "DSN=hdbctest")----- These are copied from PostgreSQL for now, except for interval-dateTimeTypeOfSqlValue :: SqlValue -> String-dateTimeTypeOfSqlValue (SqlLocalDate _) = "date"-dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone"-dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone"-dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone"-dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone"-dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone"-dateTimeTypeOfSqlValue (SqlDiffTime _) = "numeric"-dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric"-dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer"-dateTimeTypeOfSqlValue (SqlTimeDiff _) = "numeric"-dateTimeTypeOfSqlValue _ = "text"--supportsFracTime = True+module SpecificDB where
+import Database.HDBC
+import Database.HDBC.ODBC
+import Test.HUnit
+
+connectDB = 
+    handleSqlError (connectODBC "DSN=hdbctest")
+
+
+-- These are copied from PostgreSQL for now, except for interval
+dateTimeTypeOfSqlValue :: SqlValue -> String
+dateTimeTypeOfSqlValue (SqlLocalDate _) = "date"
+dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone"
+dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone"
+dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone"
+dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone"
+dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone"
+dateTimeTypeOfSqlValue (SqlDiffTime _) = "numeric"
+dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric"
+dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer"
+dateTimeTypeOfSqlValue (SqlTimeDiff _) = "numeric"
+dateTimeTypeOfSqlValue _ = "text"
+
+supportsFracTime = True
testsrc/SpecificDBTests.hs view
@@ -1,5 +1,5 @@-module SpecificDBTests where-import Database.HDBC-import Test.HUnit--tests = TestList []+module SpecificDBTests where
+import Database.HDBC
+import Test.HUnit
+
+tests = TestList []
testsrc/TestMisc.hs view
@@ -1,181 +1,181 @@-module TestMisc(tests, setup) where-import Test.HUnit-import Database.HDBC-import TestUtils-import System.IO-import Control.Exception-import Data.Char-import Control.Monad-import qualified Data.Map as Map--rowdata = -    [[SqlInt32 0, toSql "Testing", SqlNull],-     [SqlInt32 1, toSql "Foo", SqlInt32 5],-     [SqlInt32 2, toSql "Bar", SqlInt32 9]]--colnames = ["testid", "teststring", "testint"]-alrows :: [[(String, SqlValue)]]-alrows = map (zip colnames) rowdata--setup f = dbTestCase $ \dbh ->-   do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" []-      sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"-      executeMany sth rowdata-      commit dbh-      finally (f dbh)-              (do run dbh "DROP TABLE hdbctest2" []-                  commit dbh-              )--cloneTest dbh a =-    do dbh2 <- clone dbh-       finally (handleSqlError (a dbh2))-               (handleSqlError (disconnect dbh2))--testgetColumnNames = setup $ \dbh ->-   do sth <- prepare dbh "SELECT * from hdbctest2"-      execute sth []-      cols <- getColumnNames sth-      finish sth-      ["testid", "teststring", "testint"] @=? map (map toLower) cols--testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`-                                               ["sqlite3"])) $-   do sth <- prepare dbh "SELECT * from hdbctest2"-      execute sth []-      cols <- describeResult sth-      ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols-      let coldata = map snd cols-      assertBool "r0 type" (colType (coldata !! 0) `elem`-                            [SqlBigIntT, SqlIntegerT])-      assertBool "r1 type" (colType (coldata !! 1) `elem`-                            [SqlVarCharT, SqlLongVarCharT])-      assertBool "r2 type" (colType (coldata !! 2) `elem`-                            [SqlBigIntT, SqlIntegerT])-      finish sth--testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`-                                               ["sqlite3"])) $-   do cols <- describeTable dbh "hdbctest2"-      ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols-      let coldata = map snd cols-      assertBool "r0 type" (colType (coldata !! 0) `elem`-                            [SqlBigIntT, SqlIntegerT])-      assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0))-      assertBool "r1 type" (colType (coldata !! 1) `elem`-                            [SqlVarCharT, SqlLongVarCharT])-      assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1))-      assertBool "r2 type" (colType (coldata !! 2) `elem`-                           [SqlBigIntT, SqlIntegerT])-      assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2))--testquickQuery = setup $ \dbh ->-    do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []-       rowdata @=? results--testfetchRowAL = setup $ \dbh ->-    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" -       execute sth []-       fetchRowAL sth >>= (Just (head alrows) @=?)-       fetchRowAL sth >>= (Just (alrows !! 1) @=?)-       fetchRowAL sth >>= (Just (alrows !! 2) @=?)-       fetchRowAL sth >>= (Nothing @=?)-       finish sth--testfetchRowMap = setup $ \dbh ->-    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" -       execute sth []-       fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?)-       fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?)-       fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?)-       fetchRowMap sth >>= (Nothing @=?)-       finish sth--testfetchAllRowsAL = setup $ \dbh ->-    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"-       execute sth []-       fetchAllRowsAL sth >>= (alrows @=?)--testfetchAllRowsMap = setup $ \dbh ->-    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"-       execute sth []-       fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?)--testexception = setup $ \dbh ->-    catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2"-                 execute sth []-                 assertFailure "No exception was raised"-             )-             (\e -> commit dbh)--testrowcount = setup $ \dbh ->-    do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" []-       assertEqual "UPDATE with no change" 0 r-       r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" []-       assertEqual "UPDATE with 1 change" 1 r-       r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" []-       assertEqual "UPDATE with 2 changes" 2 r-       commit dbh-       res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []-       assertEqual "final results"-         [[SqlInt32 0, toSql "Testing", SqlInt32 26],-          [SqlInt32 1, toSql "Foo", SqlInt32 27],-          [SqlInt32 2, toSql "Bar", SqlInt32 27]] res-                       -{- Since we might be running against a live DB, we can't look at a specific-list here (though a SpecificDB test case may be able to).  We can ensure-that our test table is, or is not, present, as appropriate. -}-                                      -testgetTables1 = setup $ \dbh ->-    do r <- getTables dbh-       True @=? "hdbctest2" `elem` r--testgetTables2 = dbTestCase $ \dbh ->-    do r <- getTables dbh-       False @=? "hdbctest2" `elem` r--testclone = setup $ \dbho -> cloneTest dbho $ \dbh ->-    do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []-       rowdata @=? results--testnulls = setup $ \dbh ->-    do let dn = hdbcDriverName dbh-       when (not (dn `elem` ["postgresql", "odbc"])) (-          do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"-             executeMany sth rows-             finish sth-             res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []-             seq (length res) rows @=? res-                                             )-    where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull],-                  [SqlInt32 101, SqlString "bar\NUL", SqlNull],-                  [SqlInt32 102, SqlString "\NUL", SqlNull],-                  [SqlInt32 103, SqlString "\xFF", SqlNull],-                  [SqlInt32 104, SqlString "regular", SqlNull]]-       -testunicode = setup $ \dbh ->-      do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"-         executeMany sth rows-         finish sth-         res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []-         seq (length res) rows @=? res-    where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull],-                  [SqlInt32 101, SqlString "bar\x00A3", SqlNull],-                  [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]]--tests = TestList [-                  TestLabel "getColumnNames" testgetColumnNames,-                  TestLabel "describeResult" testdescribeResult,-                  TestLabel "describeTable" testdescribeTable,-                  TestLabel "quickQuery" testquickQuery,-                  TestLabel "fetchRowAL" testfetchRowAL,-                  TestLabel "fetchRowMap" testfetchRowMap,-                  TestLabel "fetchAllRowsAL" testfetchAllRowsAL,-                  TestLabel "fetchAllRowsMap" testfetchAllRowsMap,-                  TestLabel "sql exception" testexception,-                  TestLabel "clone" testclone,-                  TestLabel "update rowcount" testrowcount,-                  TestLabel "get tables1" testgetTables1,-                  TestLabel "get tables2" testgetTables2,-                  TestLabel "nulls" testnulls,-                  TestLabel "unicode" testunicode]+module TestMisc(tests, setup) where
+import Test.HUnit
+import Database.HDBC
+import TestUtils
+import System.IO
+import Control.Exception
+import Data.Char
+import Control.Monad
+import qualified Data.Map as Map
+
+rowdata = 
+    [[SqlInt32 0, toSql "Testing", SqlNull],
+     [SqlInt32 1, toSql "Foo", SqlInt32 5],
+     [SqlInt32 2, toSql "Bar", SqlInt32 9]]
+
+colnames = ["testid", "teststring", "testint"]
+alrows :: [[(String, SqlValue)]]
+alrows = map (zip colnames) rowdata
+
+setup f = dbTestCase $ \dbh ->
+   do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" []
+      sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"
+      executeMany sth rowdata
+      commit dbh
+      finally (f dbh)
+              (do run dbh "DROP TABLE hdbctest2" []
+                  commit dbh
+              )
+
+cloneTest dbh a =
+    do dbh2 <- clone dbh
+       finally (handleSqlError (a dbh2))
+               (handleSqlError (disconnect dbh2))
+
+testgetColumnNames = setup $ \dbh ->
+   do sth <- prepare dbh "SELECT * from hdbctest2"
+      execute sth []
+      cols <- getColumnNames sth
+      finish sth
+      ["testid", "teststring", "testint"] @=? map (map toLower) cols
+
+testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`
+                                               ["sqlite3"])) $
+   do sth <- prepare dbh "SELECT * from hdbctest2"
+      execute sth []
+      cols <- describeResult sth
+      ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols
+      let coldata = map snd cols
+      assertBool "r0 type" (colType (coldata !! 0) `elem`
+                            [SqlBigIntT, SqlIntegerT])
+      assertBool "r1 type" (colType (coldata !! 1) `elem`
+                            [SqlVarCharT, SqlLongVarCharT])
+      assertBool "r2 type" (colType (coldata !! 2) `elem`
+                            [SqlBigIntT, SqlIntegerT])
+      finish sth
+
+testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`
+                                               ["sqlite3"])) $
+   do cols <- describeTable dbh "hdbctest2"
+      ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols
+      let coldata = map snd cols
+      assertBool "r0 type" (colType (coldata !! 0) `elem`
+                            [SqlBigIntT, SqlIntegerT])
+      assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0))
+      assertBool "r1 type" (colType (coldata !! 1) `elem`
+                            [SqlVarCharT, SqlLongVarCharT])
+      assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1))
+      assertBool "r2 type" (colType (coldata !! 2) `elem`
+                           [SqlBigIntT, SqlIntegerT])
+      assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2))
+
+testquickQuery = setup $ \dbh ->
+    do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []
+       rowdata @=? results
+
+testfetchRowAL = setup $ \dbh ->
+    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 
+       execute sth []
+       fetchRowAL sth >>= (Just (head alrows) @=?)
+       fetchRowAL sth >>= (Just (alrows !! 1) @=?)
+       fetchRowAL sth >>= (Just (alrows !! 2) @=?)
+       fetchRowAL sth >>= (Nothing @=?)
+       finish sth
+
+testfetchRowMap = setup $ \dbh ->
+    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" 
+       execute sth []
+       fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?)
+       fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?)
+       fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?)
+       fetchRowMap sth >>= (Nothing @=?)
+       finish sth
+
+testfetchAllRowsAL = setup $ \dbh ->
+    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"
+       execute sth []
+       fetchAllRowsAL sth >>= (alrows @=?)
+
+testfetchAllRowsMap = setup $ \dbh ->
+    do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"
+       execute sth []
+       fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?)
+
+testexception = setup $ \dbh ->
+    catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2"
+                 execute sth []
+                 assertFailure "No exception was raised"
+             )
+             (\e -> commit dbh)
+
+testrowcount = setup $ \dbh ->
+    do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" []
+       assertEqual "UPDATE with no change" 0 r
+       r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" []
+       assertEqual "UPDATE with 1 change" 1 r
+       r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" []
+       assertEqual "UPDATE with 2 changes" 2 r
+       commit dbh
+       res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []
+       assertEqual "final results"
+         [[SqlInt32 0, toSql "Testing", SqlInt32 26],
+          [SqlInt32 1, toSql "Foo", SqlInt32 27],
+          [SqlInt32 2, toSql "Bar", SqlInt32 27]] res
+                       
+{- Since we might be running against a live DB, we can't look at a specific
+list here (though a SpecificDB test case may be able to).  We can ensure
+that our test table is, or is not, present, as appropriate. -}
+                                      
+testgetTables1 = setup $ \dbh ->
+    do r <- getTables dbh
+       True @=? "hdbctest2" `elem` r
+
+testgetTables2 = dbTestCase $ \dbh ->
+    do r <- getTables dbh
+       False @=? "hdbctest2" `elem` r
+
+testclone = setup $ \dbho -> cloneTest dbho $ \dbh ->
+    do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []
+       rowdata @=? results
+
+testnulls = setup $ \dbh ->
+    do let dn = hdbcDriverName dbh
+       when (not (dn `elem` ["postgresql", "odbc"])) (
+          do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"
+             executeMany sth rows
+             finish sth
+             res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []
+             seq (length res) rows @=? res
+                                             )
+    where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull],
+                  [SqlInt32 101, SqlString "bar\NUL", SqlNull],
+                  [SqlInt32 102, SqlString "\NUL", SqlNull],
+                  [SqlInt32 103, SqlString "\xFF", SqlNull],
+                  [SqlInt32 104, SqlString "regular", SqlNull]]
+       
+testunicode = setup $ \dbh ->
+      do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"
+         executeMany sth rows
+         finish sth
+         res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []
+         seq (length res) rows @=? res
+    where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull],
+                  [SqlInt32 101, SqlString "bar\x00A3", SqlNull],
+                  [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]]
+
+tests = TestList [
+                  TestLabel "getColumnNames" testgetColumnNames,
+                  TestLabel "describeResult" testdescribeResult,
+                  TestLabel "describeTable" testdescribeTable,
+                  TestLabel "quickQuery" testquickQuery,
+                  TestLabel "fetchRowAL" testfetchRowAL,
+                  TestLabel "fetchRowMap" testfetchRowMap,
+                  TestLabel "fetchAllRowsAL" testfetchAllRowsAL,
+                  TestLabel "fetchAllRowsMap" testfetchAllRowsMap,
+                  TestLabel "sql exception" testexception,
+                  TestLabel "clone" testclone,
+                  TestLabel "update rowcount" testrowcount,
+                  TestLabel "get tables1" testgetTables1,
+                  TestLabel "get tables2" testgetTables2,
+                  TestLabel "nulls" testnulls,
+                  TestLabel "unicode" testunicode]
testsrc/TestSbasics.hs view
@@ -1,156 +1,156 @@-module TestSbasics(tests) where-import Test.HUnit-import Database.HDBC-import TestUtils-import System.IO-import Control.Exception hiding (catch)--openClosedb = sqlTestCase $ -    do dbh <- connectDB-       disconnect dbh--singleFinish = dbTestCase $ \dbh ->-    do sth <- prepare dbh "SELECT 1 + 1"-       sExecute sth []-       finish sth--multiFinish = dbTestCase (\dbh ->-    do sth <- prepare dbh "SELECT 1 + 1"-       sExecute sth []-       finish sth-       finish sth-       finish sth-                          )--basicQueries = dbTestCase (\dbh ->-    do sth <- prepare dbh "SELECT 1 + 1"-       sExecute sth []-       sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"]))-       sFetchRow sth >>= (assertEqual "last row" Nothing)-                          )-    -createTable = dbTestCase (\dbh ->-    do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []-       commit dbh-                         )--dropTable = dbTestCase (\dbh ->-    do sRun dbh "DROP TABLE hdbctest1" []-       commit dbh-                       )--runReplace = dbTestCase (\dbh ->-    do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1-       sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2-       commit dbh-       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"-       sExecute sth []-       sFetchRow sth >>= (assertEqual "r1" (Just r1))-       sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2",-                                                 Just "2", Nothing]))-       sFetchRow sth >>= (assertEqual "lastrow" Nothing)-                       )-    where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"]-          r2 = [Just "runReplace", Just "2", Nothing]--executeReplace = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"-       sExecute sth [Just "1", Just "1234", Just "Foo"]-       sExecute sth [Just "2", Nothing, Just "Bar"]-       commit dbh-       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"-       sExecute sth [Just "executeReplace"]-       sFetchRow sth >>= (assertEqual "r1" -                         (Just $ map Just ["executeReplace", "1", "1234", -                                           "Foo"]))-       sFetchRow sth >>= (assertEqual "r2"-                         (Just [Just "executeReplace", Just "2", Nothing,-                                Just "Bar"]))-       sFetchRow sth >>= (assertEqual "lastrow" Nothing)-                            )--testExecuteMany = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"-       sExecuteMany sth rows-       commit dbh-       sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"-       sExecute sth []-       mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows-       sFetchRow sth >>= (assertEqual "lastrow" Nothing)-                          )-    where rows = [map Just ["1", "1234", "foo"],-                  map Just ["2", "1341", "bar"],-                  [Just "3", Nothing, Nothing]]--testsFetchAllRows = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"-       sExecuteMany sth rows-       commit dbh-       sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"-       sExecute sth []-       results <- sFetchAllRows sth-       assertEqual "" rows results-                               )-    where rows = map (\x -> [Just . show $ x]) [1..9]--basicTransactions = dbTestCase (\dbh ->-    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)-       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"-       sExecute sth [Just "0"]-       commit dbh-       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"-       sExecute qrysth []-       sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])--       -- Now try a rollback-       sExecuteMany sth rows-       rollback dbh-       sExecute qrysth []-       sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])--       -- Now try another commit-       sExecuteMany sth rows-       commit dbh-       sExecute qrysth []-       sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))-                               )-    where rows = map (\x -> [Just . show $ x]) [1..9]--testWithTransaction = dbTestCase (\dbh ->-    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)-       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"-       sExecute sth [Just "0"]-       commit dbh-       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"-       sExecute qrysth []-       sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])-       -       -- Let's try a rollback.-       catch (withTransaction dbh (\_ -> do sExecuteMany sth rows-                                            fail "Foo"))-             (\_ -> return ())-       sExecute qrysth []-       sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])--       -- And now a commit.-       withTransaction dbh (\_ -> sExecuteMany sth rows)-       sExecute qrysth []-       sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))-                               )-    where rows = map (\x -> [Just . show $ x]) [1..9]-       -tests = TestList-        [-         TestLabel "openClosedb" openClosedb,-         TestLabel "singleFinish" singleFinish,-         TestLabel "multiFinish" multiFinish,-         TestLabel "basicQueries" basicQueries,-         TestLabel "createTable" createTable,-         TestLabel "runReplace" runReplace,-         TestLabel "executeReplace" executeReplace,-         TestLabel "executeMany" testExecuteMany,-         TestLabel "sFetchAllRows" testsFetchAllRows,-         TestLabel "basicTransactions" basicTransactions,-         TestLabel "withTransaction" testWithTransaction,-         TestLabel "dropTable" dropTable-         ]+module TestSbasics(tests) where
+import Test.HUnit
+import Database.HDBC
+import TestUtils
+import System.IO
+import Control.Exception hiding (catch)
+
+openClosedb = sqlTestCase $ 
+    do dbh <- connectDB
+       disconnect dbh
+
+singleFinish = dbTestCase $ \dbh ->
+    do sth <- prepare dbh "SELECT 1 + 1"
+       sExecute sth []
+       finish sth
+
+multiFinish = dbTestCase (\dbh ->
+    do sth <- prepare dbh "SELECT 1 + 1"
+       sExecute sth []
+       finish sth
+       finish sth
+       finish sth
+                          )
+
+basicQueries = dbTestCase (\dbh ->
+    do sth <- prepare dbh "SELECT 1 + 1"
+       sExecute sth []
+       sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"]))
+       sFetchRow sth >>= (assertEqual "last row" Nothing)
+                          )
+    
+createTable = dbTestCase (\dbh ->
+    do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []
+       commit dbh
+                         )
+
+dropTable = dbTestCase (\dbh ->
+    do sRun dbh "DROP TABLE hdbctest1" []
+       commit dbh
+                       )
+
+runReplace = dbTestCase (\dbh ->
+    do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1
+       sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2
+       commit dbh
+       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"
+       sExecute sth []
+       sFetchRow sth >>= (assertEqual "r1" (Just r1))
+       sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2",
+                                                 Just "2", Nothing]))
+       sFetchRow sth >>= (assertEqual "lastrow" Nothing)
+                       )
+    where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"]
+          r2 = [Just "runReplace", Just "2", Nothing]
+
+executeReplace = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"
+       sExecute sth [Just "1", Just "1234", Just "Foo"]
+       sExecute sth [Just "2", Nothing, Just "Bar"]
+       commit dbh
+       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"
+       sExecute sth [Just "executeReplace"]
+       sFetchRow sth >>= (assertEqual "r1" 
+                         (Just $ map Just ["executeReplace", "1", "1234", 
+                                           "Foo"]))
+       sFetchRow sth >>= (assertEqual "r2"
+                         (Just [Just "executeReplace", Just "2", Nothing,
+                                Just "Bar"]))
+       sFetchRow sth >>= (assertEqual "lastrow" Nothing)
+                            )
+
+testExecuteMany = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"
+       sExecuteMany sth rows
+       commit dbh
+       sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"
+       sExecute sth []
+       mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows
+       sFetchRow sth >>= (assertEqual "lastrow" Nothing)
+                          )
+    where rows = [map Just ["1", "1234", "foo"],
+                  map Just ["2", "1341", "bar"],
+                  [Just "3", Nothing, Nothing]]
+
+testsFetchAllRows = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"
+       sExecuteMany sth rows
+       commit dbh
+       sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"
+       sExecute sth []
+       results <- sFetchAllRows sth
+       assertEqual "" rows results
+                               )
+    where rows = map (\x -> [Just . show $ x]) [1..9]
+
+basicTransactions = dbTestCase (\dbh ->
+    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)
+       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"
+       sExecute sth [Just "0"]
+       commit dbh
+       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"
+       sExecute qrysth []
+       sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])
+
+       -- Now try a rollback
+       sExecuteMany sth rows
+       rollback dbh
+       sExecute qrysth []
+       sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])
+
+       -- Now try another commit
+       sExecuteMany sth rows
+       commit dbh
+       sExecute qrysth []
+       sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))
+                               )
+    where rows = map (\x -> [Just . show $ x]) [1..9]
+
+testWithTransaction = dbTestCase (\dbh ->
+    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)
+       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"
+       sExecute sth [Just "0"]
+       commit dbh
+       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"
+       sExecute qrysth []
+       sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])
+       
+       -- Let's try a rollback.
+       catch (withTransaction dbh (\_ -> do sExecuteMany sth rows
+                                            fail "Foo"))
+             (\_ -> return ())
+       sExecute qrysth []
+       sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])
+
+       -- And now a commit.
+       withTransaction dbh (\_ -> sExecuteMany sth rows)
+       sExecute qrysth []
+       sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))
+                               )
+    where rows = map (\x -> [Just . show $ x]) [1..9]
+       
+tests = TestList
+        [
+         TestLabel "openClosedb" openClosedb,
+         TestLabel "singleFinish" singleFinish,
+         TestLabel "multiFinish" multiFinish,
+         TestLabel "basicQueries" basicQueries,
+         TestLabel "createTable" createTable,
+         TestLabel "runReplace" runReplace,
+         TestLabel "executeReplace" executeReplace,
+         TestLabel "executeMany" testExecuteMany,
+         TestLabel "sFetchAllRows" testsFetchAllRows,
+         TestLabel "basicTransactions" basicTransactions,
+         TestLabel "withTransaction" testWithTransaction,
+         TestLabel "dropTable" dropTable
+         ]
testsrc/TestTime.hs view
@@ -1,99 +1,99 @@-module TestTime(tests) where-import Test.HUnit-import Database.HDBC-import TestUtils-import Control.Exception-import Data.Time-import Data.Time.LocalTime-import Data.Time.Clock.POSIX-import Data.Maybe-import Data.Convertible-import SpecificDB-import System.Locale-import qualified System.Time as ST--instance Eq ZonedTime where-    a == b = zonedTimeToUTC a == zonedTimeToUTC b &&-             zonedTimeZone a == zonedTimeZone b--testZonedTime :: ZonedTime-testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z"))-                 "1989-08-01 15:33:01 -0500"--testZonedTimeFrac :: ZonedTime-testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z"))-                    "1989-08-01 15:33:01.536 -0500"---rowdata t = [[SqlInt32 100, toSql t, SqlNull]]--testDTType inputdata convToSqlValue = dbTestCase $ \dbh ->-    do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \-                \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") []-       finally (testIt dbh) (do commit dbh-                                run dbh "DROP TABLE hdbctesttime" []-                                commit dbh-                            )-    where testIt dbh =-              do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)"-                     [iToSql 5, value]-                 commit dbh-                 r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" []-                 case r of-                   [[testidsv, testvaluesv]] -> -                       do assertEqual "testid" (5::Int) (fromSql testidsv)-                          assertEqual "testvalue" inputdata (fromSql testvaluesv)-          value = convToSqlValue inputdata--mkTest label inputdata convfunc =-    TestLabel label (testDTType inputdata convfunc)--tests = TestList $-    ((TestLabel "Non-frac" $ testIt testZonedTime) :-     if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else [])--testIt baseZonedTime = -    TestList [mkTest "Day" baseDay toSql,-              mkTest "TimeOfDay" baseTimeOfDay toSql,-              mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql,-              mkTest "LocalTime" baseLocalTime toSql,-              mkTest "ZonedTime" baseZonedTime toSql,-              mkTest "UTCTime" baseUTCTime toSql,-              mkTest "DiffTime" baseDiffTime toSql,-              mkTest "POSIXTime" basePOSIXTime posixToSql,-              mkTest "ClockTime" baseClockTime toSql,-              mkTest "CalendarTime" baseCalendarTime toSql,-              mkTest "TimeDiff" baseTimeDiff toSql-             ]-    where -      baseDay :: Day-      baseDay = localDay baseLocalTime--      baseTimeOfDay :: TimeOfDay-      baseTimeOfDay = localTimeOfDay baseLocalTime--      baseZonedTimeOfDay :: (TimeOfDay, TimeZone)-      baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime)--      baseLocalTime :: LocalTime-      baseLocalTime = zonedTimeToLocalTime baseZonedTime--      baseUTCTime :: UTCTime-      baseUTCTime = convert baseZonedTime--      baseDiffTime :: NominalDiffTime-      baseDiffTime = basePOSIXTime--      basePOSIXTime :: POSIXTime-      basePOSIXTime = convert baseZonedTime--      baseTimeDiff :: ST.TimeDiff-      baseTimeDiff = convert baseDiffTime--      -- No fractional parts for these two--      baseClockTime :: ST.ClockTime-      baseClockTime = convert testZonedTime--      baseCalendarTime :: ST.CalendarTime-      baseCalendarTime = convert testZonedTime+module TestTime(tests) where
+import Test.HUnit
+import Database.HDBC
+import TestUtils
+import Control.Exception
+import Data.Time
+import Data.Time.LocalTime
+import Data.Time.Clock.POSIX
+import Data.Maybe
+import Data.Convertible
+import SpecificDB
+import System.Locale
+import qualified System.Time as ST
+
+instance Eq ZonedTime where
+    a == b = zonedTimeToUTC a == zonedTimeToUTC b &&
+             zonedTimeZone a == zonedTimeZone b
+
+testZonedTime :: ZonedTime
+testZonedTime = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T %z"))
+                 "1989-08-01 15:33:01 -0500"
+
+testZonedTimeFrac :: ZonedTime
+testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z"))
+                    "1989-08-01 15:33:01.536 -0500"
+
+
+rowdata t = [[SqlInt32 100, toSql t, SqlNull]]
+
+testDTType inputdata convToSqlValue = dbTestCase $ \dbh ->
+    do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, \
+                \testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") []
+       finally (testIt dbh) (do commit dbh
+                                run dbh "DROP TABLE hdbctesttime" []
+                                commit dbh
+                            )
+    where testIt dbh =
+              do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)"
+                     [iToSql 5, value]
+                 commit dbh
+                 r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" []
+                 case r of
+                   [[testidsv, testvaluesv]] -> 
+                       do assertEqual "testid" (5::Int) (fromSql testidsv)
+                          assertEqual "testvalue" inputdata (fromSql testvaluesv)
+          value = convToSqlValue inputdata
+
+mkTest label inputdata convfunc =
+    TestLabel label (testDTType inputdata convfunc)
+
+tests = TestList $
+    ((TestLabel "Non-frac" $ testIt testZonedTime) :
+     if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else [])
+
+testIt baseZonedTime = 
+    TestList [mkTest "Day" baseDay toSql,
+              mkTest "TimeOfDay" baseTimeOfDay toSql,
+              mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql,
+              mkTest "LocalTime" baseLocalTime toSql,
+              mkTest "ZonedTime" baseZonedTime toSql,
+              mkTest "UTCTime" baseUTCTime toSql,
+              mkTest "DiffTime" baseDiffTime toSql,
+              mkTest "POSIXTime" basePOSIXTime posixToSql,
+              mkTest "ClockTime" baseClockTime toSql,
+              mkTest "CalendarTime" baseCalendarTime toSql,
+              mkTest "TimeDiff" baseTimeDiff toSql
+             ]
+    where 
+      baseDay :: Day
+      baseDay = localDay baseLocalTime
+
+      baseTimeOfDay :: TimeOfDay
+      baseTimeOfDay = localTimeOfDay baseLocalTime
+
+      baseZonedTimeOfDay :: (TimeOfDay, TimeZone)
+      baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime)
+
+      baseLocalTime :: LocalTime
+      baseLocalTime = zonedTimeToLocalTime baseZonedTime
+
+      baseUTCTime :: UTCTime
+      baseUTCTime = convert baseZonedTime
+
+      baseDiffTime :: NominalDiffTime
+      baseDiffTime = basePOSIXTime
+
+      basePOSIXTime :: POSIXTime
+      basePOSIXTime = convert baseZonedTime
+
+      baseTimeDiff :: ST.TimeDiff
+      baseTimeDiff = convert baseDiffTime
+
+      -- No fractional parts for these two
+
+      baseClockTime :: ST.ClockTime
+      baseClockTime = convert testZonedTime
+
+      baseCalendarTime :: ST.CalendarTime
+      baseCalendarTime = convert testZonedTime
testsrc/TestUtils.hs view
@@ -1,25 +1,25 @@-module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where-import Database.HDBC-import Test.HUnit-import Control.Exception-import SpecificDB(connectDB)--sqlTestCase a = -    TestCase (handleSqlError a)--dbTestCase a =-    TestCase (do dbh <- connectDB-                 finally (handleSqlError (a dbh))-                         (handleSqlError (disconnect dbh))-             )--printDBInfo = handleSqlError $-    do dbh <- connectDB-       putStrLn "+-------------------------------------------------------------------------"-       putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++-                ", bound to client: " ++ hdbcClientVer dbh-       putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++-                ", bound to version: " ++ proxiedClientVer dbh-       putStrLn $ "| Connected to server version: " ++ dbServerVer dbh-       putStrLn "+-------------------------------------------------------------------------\n"-       disconnect dbh+module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where
+import Database.HDBC
+import Test.HUnit
+import Control.Exception
+import SpecificDB(connectDB)
+
+sqlTestCase a = 
+    TestCase (handleSqlError a)
+
+dbTestCase a =
+    TestCase (do dbh <- connectDB
+                 finally (handleSqlError (a dbh))
+                         (handleSqlError (disconnect dbh))
+             )
+
+printDBInfo = handleSqlError $
+    do dbh <- connectDB
+       putStrLn "+-------------------------------------------------------------------------"
+       putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh ++
+                ", bound to client: " ++ hdbcClientVer dbh
+       putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh ++
+                ", bound to version: " ++ proxiedClientVer dbh
+       putStrLn $ "| Connected to server version: " ++ dbServerVer dbh
+       putStrLn "+-------------------------------------------------------------------------\n"
+       disconnect dbh
testsrc/Testbasics.hs view
@@ -1,168 +1,168 @@-module Testbasics(tests) where-import Test.HUnit-import Database.HDBC-import TestUtils-import System.IO-import Control.Exception hiding (catch)--openClosedb = sqlTestCase $ -    do dbh <- connectDB-       disconnect dbh--multiFinish = dbTestCase (\dbh ->-    do sth <- prepare dbh "SELECT 1 + 1"-       r <- execute sth []-       assertEqual "basic count" 0 r-       finish sth-       finish sth-       finish sth-                          )--basicQueries = dbTestCase (\dbh ->-    do sth <- prepare dbh "SELECT 1 + 1"-       execute sth [] >>= (0 @=?)-       r <- fetchAllRows sth-       assertEqual "converted from" [["2"]] (map (map fromSql) r)-       assertEqual "int32 compare" [[SqlInt32 2]] r-       assertEqual "iToSql compare" [[iToSql 2]] r-       assertEqual "num compare" [[toSql (2::Int)]] r-       assertEqual "nToSql compare" [[nToSql (2::Int)]] r-       assertEqual "string compare" [[SqlString "2"]] r-                          )-    -createTable = dbTestCase (\dbh ->-    do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []-       commit dbh-                         )--dropTable = dbTestCase (\dbh ->-    do run dbh "DROP TABLE hdbctest1" []-       commit dbh-                       )--runReplace = dbTestCase (\dbh ->-    do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1-       assertEqual "insert retval" 1 r-       run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2-       commit dbh-       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"-       rv2 <- execute sth []-       assertEqual "select retval" 0 rv2-       r <- fetchAllRows sth-       assertEqual "" [r1, r2] r-                       )-    where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] -          r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull]--executeReplace = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"-       execute sth [iToSql 1, iToSql 1234, toSql "Foo"]-       execute sth [SqlInt32 2, SqlNull, toSql "Bar"]-       commit dbh-       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"-       execute sth [SqlString "executeReplace"]-       r <- fetchAllRows sth-       assertEqual "result"-                   [[toSql "executeReplace", iToSql 1, toSql "1234",-                     toSql "Foo"],-                    [toSql "executeReplace", iToSql 2, SqlNull,-                     toSql "Bar"]]-                   r-                            )--testExecuteMany = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"-       executeMany sth rows-       commit dbh-       sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"-       execute sth []-       r <- fetchAllRows sth-       assertEqual "" rows r-                          )-    where rows = [map toSql ["1", "1234", "foo"],-                  map toSql ["2", "1341", "bar"],-                  [toSql "3", SqlNull, SqlNull]]--testFetchAllRows = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"-       executeMany sth rows-       commit dbh-       sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"-       execute sth []-       results <- fetchAllRows sth-       assertEqual "" rows results-                               )-    where rows = map (\x -> [iToSql x]) [1..9]--testFetchAllRows' = dbTestCase (\dbh ->-    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)"-       executeMany sth rows-       commit dbh-       sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid"-       execute sth []-       results <- fetchAllRows' sth-       assertEqual "" rows results-                               )-    where rows = map (\x -> [iToSql x]) [1..9]--basicTransactions = dbTestCase (\dbh ->-    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)-       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"-       execute sth [iToSql 0]-       commit dbh-       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"-       execute qrysth []-       fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])--       -- Now try a rollback-       executeMany sth rows-       rollback dbh-       execute qrysth []-       fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]])--       -- Now try another commit-       executeMany sth rows-       commit dbh-       execute qrysth []-       fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows))-                               )-    where rows = map (\x -> [iToSql $ x]) [1..9]--testWithTransaction = dbTestCase (\dbh ->-    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)-       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"-       execute sth [toSql "0"]-       commit dbh-       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"-       execute qrysth []-       fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])-       -       -- Let's try a rollback.-       catch (withTransaction dbh (\_ -> do executeMany sth rows-                                            fail "Foo"))-             (\_ -> return ())-       execute qrysth []-       fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]])--       -- And now a commit.-       withTransaction dbh (\_ -> executeMany sth rows)-       execute qrysth []-       fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows))-                               )-    where rows = map (\x -> [iToSql x]) [1..9]-       -tests = TestList-        [-         TestLabel "openClosedb" openClosedb,-         TestLabel "multiFinish" multiFinish,-         TestLabel "basicQueries" basicQueries,-         TestLabel "createTable" createTable,-         TestLabel "runReplace" runReplace,-         TestLabel "executeReplace" executeReplace,-         TestLabel "executeMany" testExecuteMany,-         TestLabel "fetchAllRows" testFetchAllRows,-         TestLabel "fetchAllRows'" testFetchAllRows',-         TestLabel "basicTransactions" basicTransactions,-         TestLabel "withTransaction" testWithTransaction,-         TestLabel "dropTable" dropTable-         ]+module Testbasics(tests) where
+import Test.HUnit
+import Database.HDBC
+import TestUtils
+import System.IO
+import Control.Exception hiding (catch)
+
+openClosedb = sqlTestCase $ 
+    do dbh <- connectDB
+       disconnect dbh
+
+multiFinish = dbTestCase (\dbh ->
+    do sth <- prepare dbh "SELECT 1 + 1"
+       r <- execute sth []
+       assertEqual "basic count" 0 r
+       finish sth
+       finish sth
+       finish sth
+                          )
+
+basicQueries = dbTestCase (\dbh ->
+    do sth <- prepare dbh "SELECT 1 + 1"
+       execute sth [] >>= (0 @=?)
+       r <- fetchAllRows sth
+       assertEqual "converted from" [["2"]] (map (map fromSql) r)
+       assertEqual "int32 compare" [[SqlInt32 2]] r
+       assertEqual "iToSql compare" [[iToSql 2]] r
+       assertEqual "num compare" [[toSql (2::Int)]] r
+       assertEqual "nToSql compare" [[nToSql (2::Int)]] r
+       assertEqual "string compare" [[SqlString "2"]] r
+                          )
+    
+createTable = dbTestCase (\dbh ->
+    do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []
+       commit dbh
+                         )
+
+dropTable = dbTestCase (\dbh ->
+    do run dbh "DROP TABLE hdbctest1" []
+       commit dbh
+                       )
+
+runReplace = dbTestCase (\dbh ->
+    do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1
+       assertEqual "insert retval" 1 r
+       run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2
+       commit dbh
+       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"
+       rv2 <- execute sth []
+       assertEqual "select retval" 0 rv2
+       r <- fetchAllRows sth
+       assertEqual "" [r1, r2] r
+                       )
+    where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] 
+          r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull]
+
+executeReplace = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"
+       execute sth [iToSql 1, iToSql 1234, toSql "Foo"]
+       execute sth [SqlInt32 2, SqlNull, toSql "Bar"]
+       commit dbh
+       sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"
+       execute sth [SqlString "executeReplace"]
+       r <- fetchAllRows sth
+       assertEqual "result"
+                   [[toSql "executeReplace", iToSql 1, toSql "1234",
+                     toSql "Foo"],
+                    [toSql "executeReplace", iToSql 2, SqlNull,
+                     toSql "Bar"]]
+                   r
+                            )
+
+testExecuteMany = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"
+       executeMany sth rows
+       commit dbh
+       sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"
+       execute sth []
+       r <- fetchAllRows sth
+       assertEqual "" rows r
+                          )
+    where rows = [map toSql ["1", "1234", "foo"],
+                  map toSql ["2", "1341", "bar"],
+                  [toSql "3", SqlNull, SqlNull]]
+
+testFetchAllRows = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"
+       executeMany sth rows
+       commit dbh
+       sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"
+       execute sth []
+       results <- fetchAllRows sth
+       assertEqual "" rows results
+                               )
+    where rows = map (\x -> [iToSql x]) [1..9]
+
+testFetchAllRows' = dbTestCase (\dbh ->
+    do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)"
+       executeMany sth rows
+       commit dbh
+       sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid"
+       execute sth []
+       results <- fetchAllRows' sth
+       assertEqual "" rows results
+                               )
+    where rows = map (\x -> [iToSql x]) [1..9]
+
+basicTransactions = dbTestCase (\dbh ->
+    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)
+       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"
+       execute sth [iToSql 0]
+       commit dbh
+       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"
+       execute qrysth []
+       fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])
+
+       -- Now try a rollback
+       executeMany sth rows
+       rollback dbh
+       execute qrysth []
+       fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]])
+
+       -- Now try another commit
+       executeMany sth rows
+       commit dbh
+       execute qrysth []
+       fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows))
+                               )
+    where rows = map (\x -> [iToSql $ x]) [1..9]
+
+testWithTransaction = dbTestCase (\dbh ->
+    do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)
+       sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"
+       execute sth [toSql "0"]
+       commit dbh
+       qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"
+       execute qrysth []
+       fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])
+       
+       -- Let's try a rollback.
+       catch (withTransaction dbh (\_ -> do executeMany sth rows
+                                            fail "Foo"))
+             (\_ -> return ())
+       execute qrysth []
+       fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]])
+
+       -- And now a commit.
+       withTransaction dbh (\_ -> executeMany sth rows)
+       execute qrysth []
+       fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows))
+                               )
+    where rows = map (\x -> [iToSql x]) [1..9]
+       
+tests = TestList
+        [
+         TestLabel "openClosedb" openClosedb,
+         TestLabel "multiFinish" multiFinish,
+         TestLabel "basicQueries" basicQueries,
+         TestLabel "createTable" createTable,
+         TestLabel "runReplace" runReplace,
+         TestLabel "executeReplace" executeReplace,
+         TestLabel "executeMany" testExecuteMany,
+         TestLabel "fetchAllRows" testFetchAllRows,
+         TestLabel "fetchAllRows'" testFetchAllRows',
+         TestLabel "basicTransactions" basicTransactions,
+         TestLabel "withTransaction" testWithTransaction,
+         TestLabel "dropTable" dropTable
+         ]
testsrc/Tests.hs view
@@ -1,17 +1,17 @@-{- arch-tag: Tests main file--}--module Tests(tests) where-import Test.HUnit-import qualified Testbasics-import qualified TestSbasics-import qualified SpecificDBTests-import qualified TestMisc-import qualified TestTime--tests = TestList [TestLabel "String basics" TestSbasics.tests,-                  TestLabel "SqlValue basics" Testbasics.tests,-                  TestLabel "SpecificDB" SpecificDBTests.tests,-                  TestLabel "Misc tests" TestMisc.tests,-                  TestLabel "Time tests" TestTime.tests-                 ]+{- arch-tag: Tests main file
+-}
+
+module Tests(tests) where
+import Test.HUnit
+import qualified Testbasics
+import qualified TestSbasics
+import qualified SpecificDBTests
+import qualified TestMisc
+import qualified TestTime
+
+tests = TestList [TestLabel "String basics" TestSbasics.tests,
+                  TestLabel "SqlValue basics" Testbasics.tests,
+                  TestLabel "SpecificDB" SpecificDBTests.tests,
+                  TestLabel "Misc tests" TestMisc.tests,
+                  TestLabel "Time tests" TestTime.tests
+                 ]
testsrc/runtests.hs view
@@ -1,12 +1,12 @@-{- arch-tag: Test runner--}--module Main where --import Test.HUnit-import Tests-import TestUtils--main = do printDBInfo-          runTestTT tests-+{- arch-tag: Test runner
+-}
+
+module Main where 
+
+import Test.HUnit
+import Tests
+import TestUtils
+
+main = do printDBInfo
+          runTestTT tests
+