HDBC-odbc-2.3.1.1/0000755000000000000000000000000012056444212011447 5ustar0000000000000000HDBC-odbc-2.3.1.1/hdbc-odbc-helper.c0000644000000000000000000000763212056444212014705 0ustar0000000000000000#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) #include #include #endif #include #include #include #include #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); } HDBC-odbc-2.3.1.1/LICENSE0000644000000000000000000000271712056444212012463 0ustar0000000000000000Copyright (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. HDBC-odbc-2.3.1.1/hdbc-odbc-helper.h0000644000000000000000000000213212056444212014700 0ustar0000000000000000#if defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__) #include #include #endif #include 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); HDBC-odbc-2.3.1.1/Makefile0000644000000000000000000000165512056444212013116 0ustar0000000000000000all: 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 HDBC-odbc-2.3.1.1/Setup.hs0000644000000000000000000000011212056444212013075 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain HDBC-odbc-2.3.1.1/README.md0000644000000000000000000000567512056444212012743 0ustar0000000000000000HDBC-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: -- 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-2.3.1.1/HDBC-odbc.cabal0000644000000000000000000000472612056444212014051 0ustar0000000000000000Name: HDBC-odbc Version: 2.3.1.1 Cabal-Version: >=1.2.3 Build-type: Simple License: BSD3 Maintainer: Nicolas Wu 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 HDBC-odbc-2.3.1.1/testsrc/0000755000000000000000000000000012056444212013136 5ustar0000000000000000HDBC-odbc-2.3.1.1/testsrc/SpecificDBTests.hs0000644000000000000000000000013112056444212016443 0ustar0000000000000000module SpecificDBTests where import Database.HDBC import Test.HUnit tests = TestList [] HDBC-odbc-2.3.1.1/testsrc/TestMisc.hs0000644000000000000000000001704312056444212015232 0ustar0000000000000000module 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] HDBC-odbc-2.3.1.1/testsrc/TestUtils.hs0000644000000000000000000000174112056444212015435 0ustar0000000000000000module 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 HDBC-odbc-2.3.1.1/testsrc/runtests.hs0000644000000000000000000000022312056444212015356 0ustar0000000000000000{- arch-tag: Test runner -} module Main where import Test.HUnit import Tests import TestUtils main = do printDBInfo runTestTT tests HDBC-odbc-2.3.1.1/testsrc/TestTime.hs0000644000000000000000000000667412056444212015245 0ustar0000000000000000module 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 HDBC-odbc-2.3.1.1/testsrc/Tests.hs0000644000000000000000000000103712056444212014575 0ustar0000000000000000{- 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 ] HDBC-odbc-2.3.1.1/testsrc/SpecificDB.hs0000644000000000000000000000164512056444212015433 0ustar0000000000000000module 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 HDBC-odbc-2.3.1.1/testsrc/Testbasics.hs0000644000000000000000000001504112056444212015577 0ustar0000000000000000module 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 ] HDBC-odbc-2.3.1.1/testsrc/TestSbasics.hs0000644000000000000000000001431012056444212015720 0ustar0000000000000000module 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 ] HDBC-odbc-2.3.1.1/Database/0000755000000000000000000000000012056444212013153 5ustar0000000000000000HDBC-odbc-2.3.1.1/Database/HDBC/0000755000000000000000000000000012056444212013653 5ustar0000000000000000HDBC-odbc-2.3.1.1/Database/HDBC/ODBC.hs0000644000000000000000000000100312056444212014710 0ustar0000000000000000{- | Module : Database.HDBC.ODBC Copyright : Copyright (C) 2005 John Goerzen License : BSD3 Maintainer : John Goerzen 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) HDBC-odbc-2.3.1.1/Database/HDBC/ODBC/0000755000000000000000000000000012056444212014362 5ustar0000000000000000HDBC-odbc-2.3.1.1/Database/HDBC/ODBC/Connection.hsc0000644000000000000000000002175212056444212017167 0ustar0000000000000000-- -*- 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 #endif #include #include #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: 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} HDBC-odbc-2.3.1.1/Database/HDBC/ODBC/Utils.hsc0000644000000000000000000001121012056444212016154 0ustar0000000000000000{- -*- 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 #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-2.3.1.1/Database/HDBC/ODBC/TypeConv.hsc0000644000000000000000000001005612056444212016632 0ustar0000000000000000-- -*- 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 #endif #include #include #include 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) HDBC-odbc-2.3.1.1/Database/HDBC/ODBC/Statement.hsc0000644000000000000000000012366112056444212017036 0ustar0000000000000000-- -*- 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 #endif #include #include #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} HDBC-odbc-2.3.1.1/Database/HDBC/ODBC/ConnectionImpl.hs0000644000000000000000000000257212056444212017645 0ustar0000000000000000module 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 HDBC-odbc-2.3.1.1/Database/HDBC/ODBC/Types.hs0000644000000000000000000000100612056444212016017 0ustar0000000000000000module 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