HDBC-sqlite3-2.3.3.1/0000755000000000000000000000000012516406577012143 5ustar0000000000000000HDBC-sqlite3-2.3.3.1/CHANGELOG.md0000644000000000000000000000007312516406577013754 0ustar0000000000000000 # Changelog #### 2.3.3.1 * Compatibility with GHC 7.10. HDBC-sqlite3-2.3.3.1/hdbc-sqlite3-helper.c0000644000000000000000000001007312516406577016047 0ustar0000000000000000#include #include #include #include "hdbc-sqlite3-helper.h" int sqlite3_bind_text2(sqlite3_stmt* a, int b, const char *c, int d) { return sqlite3_bind_text(a, b, c, d, SQLITE_TRANSIENT); } /* Sqlite things can't finalize more than once. We'd like to let people call them from the app to get the error, if any. Yet we'd also like to be able to have a ForeignPtr finalize them. So, here's a little wrapper for things. */ int sqlite3_open2(const char *filename, finalizeonce **ppo) { sqlite3 *ppDb; finalizeonce *newobj; int res; res = sqlite3_open(filename, &ppDb); newobj = malloc(sizeof(finalizeonce)); if (newobj == NULL) { fprintf(stderr, "\nhdbc sqlite internal error: couldn't malloc memory for newobj\n"); return -999; } newobj->encapobj = (void *) ppDb; newobj->isfinalized = 0; newobj->refcount = 1; newobj->parent = NULL; *ppo = newobj; #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nAllocated db at %p %p\n", newobj, newobj->encapobj); #endif return res; } int sqlite3_close_app(finalizeonce *ppdb) { int res; if (ppdb->isfinalized) { #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nclose_app on already finalized %p\n", ppdb); #endif return SQLITE_OK; } #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nclose_app on non-finalized %p\n", ppdb); #endif res = sqlite3_close((sqlite3 *) (ppdb->encapobj)); ppdb->isfinalized = 1; return res; } void sqlite3_close_finalizer(finalizeonce *ppdb) { #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nclose_finalizer on %p: %d\n", ppdb, ppdb->isfinalized); #endif (ppdb->refcount)--; sqlite3_conditional_finalizer(ppdb); } void sqlite3_conditional_finalizer(finalizeonce *ppdb) { #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\ncond finalizer on %p: refcount %d\n", ppdb, ppdb->refcount); #endif if (ppdb->refcount < 1) { sqlite3_close_app(ppdb); free(ppdb); } } void sqlite3_busy_timeout2(finalizeonce *ppdb, int ms) { sqlite3 *db; db = (sqlite3 *) ppdb->encapobj; sqlite3_busy_timeout(db, ms); } int sqlite3_prepare2(finalizeonce *fdb, const char *zSql, int nBytes, finalizeonce **ppo, const char **pzTail) { sqlite3_stmt *ppst; sqlite3 *db; finalizeonce *newobj; int res; db = (sqlite3 *) fdb->encapobj; #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nCalling prepare on %p", db); #endif #if SQLITE_VERSION_NUMBER > 3003011 res = sqlite3_prepare_v2(db, zSql, nBytes, &ppst, pzTail); #else res = sqlite3_prepare(db, zSql, nBytes, &ppst, pzTail); #endif /* We don't try to deallocate this in Haskell if there was an error. */ if (res != SQLITE_OK) { if (ppst != NULL) { sqlite3_finalize(ppst); } return res; } newobj = malloc(sizeof(finalizeonce)); if (newobj == NULL) { fprintf(stderr, "\nhdbc sqlite3 internal error: couldn't malloc memory for newobj\n"); return -999; } newobj->encapobj = (void *) ppst; newobj->isfinalized = 0; newobj->parent = fdb; newobj->refcount = 1; (fdb->refcount)++; *ppo = newobj; #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nAllocated stmt at %p %p\n", newobj, newobj->encapobj); #endif return res; } int sqlite3_finalize_app(finalizeonce *ppst) { int res; if (ppst->isfinalized) { #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nfinalize_app on already finalized %p\n", ppst); #endif return SQLITE_OK; } #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nfinalize_app on non-finalized %p\n", ppst); #endif res = sqlite3_finalize((sqlite3_stmt *) (ppst->encapobj)); ppst->isfinalized = 1; return res; } void sqlite3_finalize_finalizer(finalizeonce *ppst) { #ifdef DEBUG_HDBC_SQLITE3 fprintf(stderr, "\nfinalize_finalizer on %p: %d\n", ppst, ppst->isfinalized); #endif sqlite3_finalize_app(ppst); (ppst->refcount)--; /* Not really important since no children use us */ /* Now decrement the refcount for the parent */ (ppst->parent->refcount)--; sqlite3_conditional_finalizer(ppst->parent); free(ppst); } HDBC-sqlite3-2.3.3.1/hdbc-sqlite3-helper.h0000644000000000000000000000171012516406577016052 0ustar0000000000000000#include extern int sqlite3_bind_text2(sqlite3_stmt* a, int b, const char *c, int d); /* Clever trick: the obj is the first element in the struct, so the pointer to the struct is the same as the pointer to the obj. */ typedef struct TAG_finalizeonce { void *encapobj; int refcount; int isfinalized; struct TAG_finalizeonce *parent; } finalizeonce; extern int sqlite3_open2(const char *filename, finalizeonce **ppo); extern int sqlite3_close_app(finalizeonce *ppdb); extern void sqlite3_close_finalizer(finalizeonce *ppdb); extern void sqlite3_conditional_finalizer(finalizeonce *ppdb); extern void sqlite3_busy_timeout2(finalizeonce *ppdb, int ms); extern int sqlite3_prepare2(finalizeonce *fdb, const char *zSql, int nBytes, finalizeonce **ppo, const char **pzTail); extern int sqlite3_finalize_app(finalizeonce *ppst); extern void sqlite3_finalize_finalizer(finalizeonce *ppst); HDBC-sqlite3-2.3.3.1/HDBC-sqlite3.cabal0000644000000000000000000000457012516406577015217 0ustar0000000000000000Name: HDBC-sqlite3 Version: 2.3.3.1 License: BSD3 Maintainer: Erik Hesselink Author: John Goerzen Copyright: Copyright (c) 2005-2011 John Goerzen license-file: LICENSE extra-source-files: LICENSE, hdbc-sqlite3-helper.h, Makefile homepage: https://github.com/hdbc/hdbc-sqlite3 Category: Database synopsis: Sqlite v3 driver for HDBC Description: This is the Sqlite v3 driver for HDBC, the generic database access system for Haskell Stability: Stable Build-Type: Simple Cabal-Version: >=1.2.3 extra-source-files: LICENSE, Makefile, README.txt, CHANGELOG.md Flag splitBase description: Choose the new smaller, split-up package. Flag buildtests description: Build the executable to run unit tests default: False Library Build-Depends: base>=4 && < 5, bytestring, mtl, HDBC>=2.3.0.0, utf8-string C-Sources: hdbc-sqlite3-helper.c include-dirs: . Extra-Libraries: sqlite3 Exposed-Modules: Database.HDBC.Sqlite3 Other-Modules: Database.HDBC.Sqlite3.Connection, Database.HDBC.Sqlite3.ConnectionImpl, Database.HDBC.Sqlite3.Statement, Database.HDBC.Sqlite3.Types, Database.HDBC.Sqlite3.Utils, Database.HDBC.Sqlite3.Consts GHC-Options: -O2 Extensions: ExistentialQuantification, ForeignFunctionInterface, EmptyDataDecls, ScopedTypeVariables, ScopedTypeVariables Executable runtests if flag(buildtests) Buildable: True Build-Depends: HUnit, testpack, containers, convertible, old-time, time, old-locale else Buildable: False Main-Is: runtests.hs Other-Modules: SpecificDB, SpecificDBTests, TestMisc, TestSbasics, TestUtils, Testbasics, Tests, Database.HDBC.Sqlite3.Connection, Database.HDBC.Sqlite3.ConnectionImpl, Database.HDBC.Sqlite3.Statement, Database.HDBC.Sqlite3.Types, Database.HDBC.Sqlite3.Utils, Database.HDBC.Sqlite3.Consts C-Sources: hdbc-sqlite3-helper.c include-dirs: . Extra-Libraries: sqlite3 Hs-Source-Dirs: ., testsrc GHC-Options: -O2 Extensions: ExistentialQuantification, ForeignFunctionInterface, EmptyDataDecls, ScopedTypeVariables, ScopedTypeVariables HDBC-sqlite3-2.3.3.1/LICENSE0000644000000000000000000000271712516406577013157 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-sqlite3-2.3.3.1/Makefile0000644000000000000000000000167512516406577013614 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 # for GHC 6.10: --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-sqlite3-2.3.3.1/README.txt0000644000000000000000000000331012516406577013636 0ustar0000000000000000Welcome to HDBC, Haskell Database Connectivity. This package provides a database backend driver for Sqlite version 3. Please see HDBC itself for documentation on use. If you don't already have it, you can browse this documentation at http://software.complete.org/hdbc This package provides one function in module Database.HDBC.Sqlite3: {- | Connect to an Sqlite version 3 database. The only parameter needed is the filename of the database to connect to. All database accessor functions are provided in the main HDBC module. -} connectSqlite3 :: FilePath -> IO Connection DIFFERENCES FROM HDBC STANDARD ------------------------------ SQLite is unable to return the number of modified rows from a table when you run a "DELETE FROM" command with no WHERE clause. On the topic of thread safety, SQLite has some limitations, and thus HDBC programs that use SQLite will share those limitations. Please see http://www.sqlite.org/faq.html#q8 for more details. describeTable and describeResult are not supported by this module. PREREQUISITES ------------- Before installing this package, you'll need to have HDBC 0.99.0 or above installed. You can download HDBC from http://quux.org/devel/hdbc. You'll need either GHC 6.8.x or above, or Hugs 2006xx or above. INSTALLATION ------------ The steps to install are: 1) ghc --make -o setup Setup.lhs 2) ./setup configure 3) ./setup build 4) ./setup install (as root) If you're on Windows, you can omit the leading "./". USAGE ----- To use with hugs, you'll want to use hugs -98. To use with GHC, you'll want to use: -package HDBC -package HDBC-sqlite3 Or, with Cabal, use: Build-Depends: HDBC>=2.0.0, HDBC-sqlite3 -- John Goerzen January 2009 December 2005 HDBC-sqlite3-2.3.3.1/Setup.hs0000644000000000000000000000011012516406577013567 0ustar0000000000000000#!/usr/bin/env runhugs import Distribution.Simple main = defaultMain HDBC-sqlite3-2.3.3.1/Database/0000755000000000000000000000000012516406577013647 5ustar0000000000000000HDBC-sqlite3-2.3.3.1/Database/HDBC/0000755000000000000000000000000012516406577014347 5ustar0000000000000000HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3.hs0000644000000000000000000000131212516406577016224 0ustar0000000000000000{- | Module : Database.HDBC.Sqlite3 Copyright : Copyright (C) 2005-2011 John Goerzen License : BSD3 Maintainer : John Goerzen Stability : provisional Portability: portable HDBC driver interface for Sqlite 3.x. Written by John Goerzen, jgoerzen\@complete.org -} module Database.HDBC.Sqlite3 ( -- * Sqlite3 Basics connectSqlite3, connectSqlite3Raw, Connection(), setBusyTimeout, -- * Sqlite3 Error Consts module Database.HDBC.Sqlite3.Consts ) where import Database.HDBC.Sqlite3.Connection(connectSqlite3, connectSqlite3Raw, Connection()) import Database.HDBC.Sqlite3.ConnectionImpl(setBusyTimeout) import Database.HDBC.Sqlite3.Consts HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/0000755000000000000000000000000012516406577015673 5ustar0000000000000000HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/Connection.hs0000644000000000000000000001441412516406577020332 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# CFILES hdbc-sqlite3-helper.c #-} -- above line for hugs module Database.HDBC.Sqlite3.Connection (connectSqlite3, connectSqlite3Raw, Impl.Connection()) where import Database.HDBC.Types import Database.HDBC import Database.HDBC.DriverUtils import qualified Database.HDBC.Sqlite3.ConnectionImpl as Impl import Database.HDBC.Sqlite3.Types import Database.HDBC.Sqlite3.Statement import Foreign.C.Types import Foreign.C.String import Foreign.Marshal import Foreign.Storable import Database.HDBC.Sqlite3.Utils import Foreign.ForeignPtr import Foreign.Ptr import Control.Concurrent.MVar import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import qualified Data.Char {- | Connect to an Sqlite version 3 database. The only parameter needed is the filename of the database to connect to. All database accessor functions are provided in the main HDBC module. -} connectSqlite3 :: FilePath -> IO Impl.Connection connectSqlite3 = genericConnect (B.useAsCString . BUTF8.fromString) {- | Connects to a Sqlite v3 database as with 'connectSqlite3', but instead of converting the supplied 'FilePath' to a C String by performing a conversion to Unicode, instead converts it by simply dropping all bits past the eighth. This may be useful in rare situations if your application or filesystemare not running in Unicode space. -} connectSqlite3Raw :: FilePath -> IO Impl.Connection connectSqlite3Raw = genericConnect withCString genericConnect :: (String -> (CString -> IO Impl.Connection) -> IO Impl.Connection) -> FilePath -> IO Impl.Connection genericConnect strAsCStrFunc fp = strAsCStrFunc fp (\cs -> alloca (\(p::Ptr (Ptr CSqlite3)) -> do res <- sqlite3_open cs p o <- peek p fptr <- newForeignPtr sqlite3_closeptr o newconn <- mkConn fp fptr checkError ("connectSqlite3 " ++ fp) fptr res return newconn ) ) mkConn :: FilePath -> Sqlite3 -> IO Impl.Connection mkConn fp obj = do children <- newMVar [] begin_transaction obj children ver <- (sqlite3_libversion >>= peekCString) return $ Impl.Connection { Impl.disconnect = fdisconnect obj children, Impl.commit = fcommit obj children, Impl.rollback = frollback obj children, Impl.run = frun obj children, Impl.runRaw = frunRaw obj children, Impl.prepare = newSth obj children True, Impl.clone = connectSqlite3 fp, Impl.hdbcDriverName = "sqlite3", Impl.hdbcClientVer = ver, Impl.proxiedClientName = "sqlite3", Impl.proxiedClientVer = ver, Impl.dbTransactionSupport = True, Impl.dbServerVer = ver, Impl.getTables = fgettables obj children, Impl.describeTable = fdescribeTable obj children, Impl.setBusyTimeout = fsetbusy obj} fgettables o mchildren = do sth <- newSth o mchildren True "SELECT name FROM sqlite_master WHERE type='table' ORDER BY name" execute sth [] res1 <- fetchAllRows' sth let res = map fromSql $ concat res1 return $ seq (length res) res fdescribeTable o mchildren name = do sth <- newSth o mchildren True $ "PRAGMA table_info(" ++ name ++ ")" execute sth [] res1 <- fetchAllRows' sth return $ map describeCol res1 where describeCol (_:name:typ:notnull:df:pk:_) = (fromSql name, describeType typ notnull df pk) describeType name notnull df pk = SqlColDesc (typeId name) Nothing Nothing Nothing (nullable notnull) nullable SqlNull = Nothing nullable (SqlString "0") = Just True nullable (SqlString "1") = Just False nullable (SqlByteString x) | BUTF8.toString x == "0" = Just True | BUTF8.toString x == "1" = Just False nullable _ = Nothing typeId SqlNull = SqlUnknownT "Any" typeId (SqlString t) = typeId' t typeId (SqlByteString t) = typeId' $ BUTF8.toString t typeId _ = SqlUnknownT "Unknown" typeId' t = case map Data.Char.toLower t of ('i':'n':'t':_) -> SqlIntegerT "text" -> SqlVarCharT "real" -> SqlRealT "blob" -> SqlVarBinaryT "" -> SqlUnknownT "Any" other -> SqlUnknownT other fsetbusy o ms = withRawSqlite3 o $ \ppdb -> sqlite3_busy_timeout ppdb ms -------------------------------------------------- -- Guts here -------------------------------------------------- begin_transaction :: Sqlite3 -> ChildList -> IO () begin_transaction o children = frun o children "BEGIN" [] >> return () frun o mchildren query args = do sth <- newSth o mchildren False query res <- execute sth args finish sth return res frunRaw :: Sqlite3 -> ChildList -> String -> IO () frunRaw o mchildren query = do sth <- newSth o mchildren False query executeRaw sth finish sth fcommit o children = do frun o children "COMMIT" [] begin_transaction o children frollback o children = do frun o children "ROLLBACK" [] begin_transaction o children fdisconnect :: Sqlite3 -> ChildList -> IO () fdisconnect o mchildren = withRawSqlite3 o $ \p -> do closeAllChildren mchildren r <- sqlite3_close p checkError "disconnect" o r foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_open2" sqlite3_open :: CString -> (Ptr (Ptr CSqlite3)) -> IO CInt foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_close_finalizer" sqlite3_closeptr :: FunPtr ((Ptr CSqlite3) -> IO ()) foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_close_app" sqlite3_close :: Ptr CSqlite3 -> IO CInt foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_busy_timeout2" sqlite3_busy_timeout :: Ptr CSqlite3 -> CInt -> IO () foreign import ccall unsafe "sqlite3.h sqlite3_libversion" sqlite3_libversion :: IO CString HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/ConnectionImpl.hs0000644000000000000000000000305712516406577021155 0ustar0000000000000000module Database.HDBC.Sqlite3.ConnectionImpl where import qualified Database.HDBC.Statement as Types import qualified Database.HDBC.Types as Types import Database.HDBC.ColTypes as ColTypes import Foreign.C.Types data Connection = Connection { disconnect :: IO (), commit :: IO (), rollback :: IO (), run :: String -> [Types.SqlValue] -> IO Integer, runRaw :: String -> IO (), 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)], -- | Sets the timeout for a lock before returning a busy error. -- Give the time in milliseconds. setBusyTimeout :: CInt -> IO () } instance Types.IConnection Connection where disconnect = disconnect commit = commit rollback = rollback run = run runRaw = runRaw prepare = prepare clone = clone hdbcDriverName = hdbcDriverName hdbcClientVer = hdbcClientVer proxiedClientName = proxiedClientName proxiedClientVer = proxiedClientVer dbServerVer = dbServerVer dbTransactionSupport = dbTransactionSupport getTables = getTables describeTable = describeTable HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/Consts.hsc0000644000000000000000000000610012516406577017640 0ustar0000000000000000{- -*- mode: haskell; -*- vim: set filetype=haskell: -} module Database.HDBC.Sqlite3.Consts (sqlite_OK, sqlite_ERROR, sqlite_INTERNAL, sqlite_PERM, sqlite_ABORT, sqlite_BUSY, sqlite_LOCKED, sqlite_NOMEM, sqlite_READONLY, sqlite_INTERRUPT, sqlite_IOERR, sqlite_CORRUPT, sqlite_NOTFOUND, sqlite_FULL, sqlite_CANTOPEN, sqlite_PROTOCOL, sqlite_EMPTY, sqlite_SCHEMA, sqlite_TOOBIG, sqlite_CONSTRAINT, sqlite_MISMATCH, sqlite_MISUSE, sqlite_NOLFS, sqlite_AUTH, sqlite_ROW, sqlite_DONE) where import Foreign.C.Types #include -- | Successful result sqlite_OK :: Int sqlite_OK = #{const SQLITE_OK} -- | SQL error or missing database sqlite_ERROR :: Int sqlite_ERROR = #{const SQLITE_ERROR} -- | An internal logic error in SQLite sqlite_INTERNAL :: Int sqlite_INTERNAL = #{const SQLITE_INTERNAL} -- | Access permission denied sqlite_PERM :: Int sqlite_PERM = #{const SQLITE_PERM} -- | Callback routine requested an abort sqlite_ABORT :: Int sqlite_ABORT = #{const SQLITE_ABORT} -- | The database file is locked sqlite_BUSY :: Int sqlite_BUSY = #{const SQLITE_BUSY} -- | A table in the database is locked sqlite_LOCKED :: Int sqlite_LOCKED = #{const SQLITE_LOCKED} -- | A malloc() failed sqlite_NOMEM :: Int sqlite_NOMEM = #{const SQLITE_NOMEM} -- | Attempt to write a readonly database sqlite_READONLY :: Int sqlite_READONLY = #{const SQLITE_READONLY} -- | Operation terminated by sqlite_interrupt() sqlite_INTERRUPT :: Int sqlite_INTERRUPT = #{const SQLITE_INTERRUPT} -- | Some kind of disk I\/O error occurred sqlite_IOERR :: Int sqlite_IOERR = #{const SQLITE_IOERR} -- | The database disk image is malformed sqlite_CORRUPT :: Int sqlite_CORRUPT = #{const SQLITE_CORRUPT} -- | (Internal Only) Table or record not found sqlite_NOTFOUND :: Int sqlite_NOTFOUND = #{const SQLITE_NOTFOUND} -- | Insertion failed because database is full sqlite_FULL :: Int sqlite_FULL = #{const SQLITE_FULL} -- | Unable to open the database file sqlite_CANTOPEN :: Int sqlite_CANTOPEN = #{const SQLITE_CANTOPEN} -- | Database lock protocol error sqlite_PROTOCOL :: Int sqlite_PROTOCOL = #{const SQLITE_PROTOCOL} -- | (Internal Only) Database table is empty sqlite_EMPTY :: Int sqlite_EMPTY = #{const SQLITE_EMPTY} -- | The database schema changed sqlite_SCHEMA :: Int sqlite_SCHEMA = #{const SQLITE_SCHEMA} -- | Too much data for one row of a table sqlite_TOOBIG :: Int sqlite_TOOBIG = #{const SQLITE_TOOBIG} -- | Abort due to constraint violation sqlite_CONSTRAINT :: Int sqlite_CONSTRAINT = #{const SQLITE_CONSTRAINT} -- | Data type mismatch sqlite_MISMATCH :: Int sqlite_MISMATCH = #{const SQLITE_MISMATCH} -- | Library used incorrectly sqlite_MISUSE :: Int sqlite_MISUSE = #{const SQLITE_MISUSE} -- | Uses OS features not supported on host sqlite_NOLFS :: Int sqlite_NOLFS = #{const SQLITE_NOLFS} -- | Authorization denied sqlite_AUTH :: Int sqlite_AUTH = #{const SQLITE_AUTH} -- | sqlite_step() has another row ready sqlite_ROW :: Int sqlite_ROW = #{const SQLITE_ROW} -- | sqlite_step() has finished executing sqlite_DONE :: Int sqlite_DONE = #{const SQLITE_DONE} HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/Statement.hsc0000644000000000000000000003157512516406577020351 0ustar0000000000000000-- -*- mode: haskell; -*- {-# CFILES hdbc-sqlite3-helper.c #-} -- Above line for Hugs module Database.HDBC.Sqlite3.Statement where import Database.HDBC.Types import Database.HDBC import Database.HDBC.Sqlite3.Types import Database.HDBC.Sqlite3.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 qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import Data.List import Control.Exception import Database.HDBC.DriverUtils #include {- One annoying thing about Sqlite is that a disconnect operation will actually fail if there are any active statements. This is highly annoying, and makes for some somewhat complex algorithms. -} data StoState = Empty -- ^ Not initialized or last execute\/fetchrow had no results | Prepared Stmt -- ^ Prepared but not executed | Executed Stmt -- ^ Executed and more rows are expected | Exhausted Stmt -- ^ Executed and at end of rows instance Show StoState where show Empty = "Empty" show (Prepared _) = "Prepared" show (Executed _) = "Executed" show (Exhausted _) = "Exhausted" data SState = SState {dbo :: Sqlite3, stomv :: MVar StoState, querys :: String, colnamesmv :: MVar [String], autoFinish :: Bool} newSth :: Sqlite3 -> ChildList -> Bool -> String -> IO Statement newSth indbo mchildren autoFinish str = do newstomv <- newMVar Empty newcolnamesmv <- newMVar [] let sstate = SState{dbo = indbo, stomv = newstomv, querys = str, colnamesmv = newcolnamesmv, autoFinish = autoFinish} modifyMVar_ (stomv sstate) (\_ -> (fprepare sstate >>= return . Prepared)) let retval = Statement {execute = fexecute sstate, executeRaw = fexecuteRaw indbo str, executeMany = fexecutemany sstate, finish = public_ffinish sstate, fetchRow = ffetchrow sstate, originalQuery = str, getColumnNames = readMVar (colnamesmv sstate), describeResult = fail "Sqlite3 backend does not support describeResult"} addChild mchildren retval return retval {- The deal with adding the \0 below is in response to an apparent bug in sqlite3. See debian bug #343736. This function assumes that any existing query in the state has already been terminated. (FIXME: should check this at runtime.... never run fprepare unless state is Empty) -} fprepare :: SState -> IO Stmt fprepare sstate = withRawSqlite3 (dbo sstate) (\p -> B.useAsCStringLen (BUTF8.fromString ((querys sstate) ++ "\0")) (\(cs, cslen) -> alloca (\(newp::Ptr (Ptr CStmt)) -> (do res <- sqlite3_prepare p cs (fromIntegral cslen) newp nullPtr checkError ("prepare " ++ (show cslen) ++ ": " ++ (querys sstate)) (dbo sstate) res newo <- peek newp newForeignPtr sqlite3_finalizeptr newo ) ) ) ) {- General algorithm: find out how many columns we have, check the type of each to see if it's NULL. If it's not, fetch it as text and return that. Note that execute() will have already loaded up the first row -- and we do that each time. so this function returns the row that is already in sqlite, then loads the next row. -} ffetchrow :: SState -> IO (Maybe [SqlValue]) ffetchrow sstate = modifyMVar (stomv sstate) dofetchrow where dofetchrow Empty = return (Empty, Nothing) dofetchrow (Prepared _) = throwSqlError $ SqlError {seState = "HDBC Sqlite3 fetchrow", seNativeError = (-1), seErrorMsg = "Attempt to fetch row from Statement that has not been executed. Query was: " ++ (querys sstate)} dofetchrow (Executed sto) = withStmt sto (\p -> do ccount <- sqlite3_column_count p -- fetch the data res <- mapM (getCol p) [0..(ccount - 1)] r <- fstep (dbo sstate) p if r then return (Executed sto, Just res) else if (autoFinish sstate) then do ffinish (dbo sstate) sto return (Empty, Just res) else return (Exhausted sto, Just res) ) dofetchrow (Exhausted sto) = return (Exhausted sto, Nothing) getCol p icol = do t <- sqlite3_column_type p icol if t == #{const SQLITE_NULL} then return SqlNull else do text <- sqlite3_column_text p icol len <- sqlite3_column_bytes p icol s <- B.packCStringLen (text, fromIntegral len) case t of #{const SQLITE_INTEGER} -> return $ SqlInt64 (read $ BUTF8.toString s) #{const SQLITE_FLOAT} -> return $ SqlDouble (read $ BUTF8.toString s) #{const SQLITE_BLOB} -> return $ SqlByteString s #{const SQLITE_TEXT} -> return $ SqlByteString s _ -> return $ SqlByteString s fstep :: Sqlite3 -> Ptr CStmt -> IO Bool fstep dbo p = do r <- sqlite3_step p case r of #{const SQLITE_ROW} -> return True #{const SQLITE_DONE} -> return False #{const SQLITE_ERROR} -> checkError "step" dbo #{const SQLITE_ERROR} >> (throwSqlError $ SqlError {seState = "", seNativeError = 0, seErrorMsg = "In HDBC step, internal processing error (got SQLITE_ERROR with no error)"}) x -> checkError "step" dbo x >> (throwSqlError $ SqlError {seState = "", seNativeError = fromIntegral x, seErrorMsg = "In HDBC step, internal processing error (got error code with no error)"}) fexecute sstate args = modifyMVar (stomv sstate) doexecute where doexecute (Executed sto) = doexecute (Prepared sto) doexecute (Exhausted sto) = doexecute (Prepared sto) doexecute Empty = -- already cleaned up from last time do sto <- fprepare sstate doexecute (Prepared sto) doexecute (Prepared sto) = withStmt sto (\p -> do c <- sqlite3_bind_parameter_count p when (c /= genericLength args) (throwSqlError $ SqlError {seState = "", seNativeError = (-1), seErrorMsg = "In HDBC execute, received " ++ (show args) ++ " but expected " ++ (show c) ++ " args."}) sqlite3_reset p >>= checkError "execute (reset)" (dbo sstate) zipWithM_ (bindArgs p) [1..c] args {- Logic for handling counts of changes: look at the total changes before and after the query. If they differ, then look at the local changes. (The local change counter appears to not be updated unless really running a query that makes a change, according to the docs.) This is OK thread-wise because SQLite doesn't support using a given dbh in more than one thread anyway. -} origtc <- withSqlite3 (dbo sstate) sqlite3_total_changes r <- fstep (dbo sstate) p newtc <- withSqlite3 (dbo sstate) sqlite3_total_changes changes <- if origtc == newtc then return 0 else withSqlite3 (dbo sstate) sqlite3_changes fgetcolnames p >>= swapMVar (colnamesmv sstate) if r then return (Executed sto, fromIntegral changes) else if (autoFinish sstate) then do ffinish (dbo sstate) sto return (Empty, fromIntegral changes) else return (Exhausted sto, fromIntegral changes) ) bindArgs p i SqlNull = sqlite3_bind_null p i >>= checkError ("execute (binding NULL column " ++ (show i) ++ ")") (dbo sstate) bindArgs p i (SqlByteString bs) = B.useAsCStringLen bs (bindCStringArgs p i) bindArgs p i arg = bindArgs p i (SqlByteString (fromSql arg)) bindCStringArgs p i (cs, len) = do r <- sqlite3_bind_text2 p i cs (fromIntegral len) checkError ("execute (binding column " ++ (show i) ++ ")") (dbo sstate) r fexecuteRaw :: Sqlite3 -> String -> IO () fexecuteRaw dbo query = withSqlite3 dbo (\p -> B.useAsCStringLen (BUTF8.fromString (query ++ "\0")) (\(cs, cslen) -> do result <- sqlite3_exec p cs nullFunPtr nullPtr nullPtr case result of #{const SQLITE_OK} -> return () s -> do checkError "exec" dbo s throwSqlError $ SqlError {seState = "", seNativeError = fromIntegral s, seErrorMsg = "In sqlite3_exec, internal error"} ) ) fgetcolnames csth = do count <- sqlite3_column_count csth mapM (getCol csth) [0..(count -1)] where getCol csth i = do cstr <- sqlite3_column_name csth i bs <- B.packCString cstr return (BUTF8.toString bs) fexecutemany _ [] = return () fexecutemany sstate (args:[]) = do fexecute sstate args return () fexecutemany sstate (args:arglist) = do fexecute (sstate { autoFinish = False }) args fexecutemany sstate arglist --ffinish o = withForeignPtr o (\p -> sqlite3_finalize p >>= checkError "finish") -- Finish and change state public_ffinish sstate = modifyMVar_ (stomv sstate) worker where worker (Empty) = return Empty worker (Prepared sto) = ffinish (dbo sstate) sto >> return Empty worker (Executed sto) = ffinish (dbo sstate) sto >> return Empty worker (Exhausted sto) = ffinish (dbo sstate) sto >> return Empty ffinish dbo o = withRawStmt o (\p -> do r <- sqlite3_finalize p checkError "finish" dbo r) foreign import ccall unsafe "hdbc-sqlite3-helper.h &sqlite3_finalize_finalizer" sqlite3_finalizeptr :: FunPtr ((Ptr CStmt) -> IO ()) foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_finalize_app" sqlite3_finalize :: (Ptr CStmt) -> IO CInt foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_prepare2" sqlite3_prepare :: (Ptr CSqlite3) -> CString -> CInt -> Ptr (Ptr CStmt) -> Ptr (Ptr CString) -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_bind_parameter_count" sqlite3_bind_parameter_count :: (Ptr CStmt) -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_step" sqlite3_step :: (Ptr CStmt) -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_exec" sqlite3_exec :: (Ptr CSqlite3) -> CString -> FunPtr (Ptr () -> CInt -> Ptr CString -> Ptr CString) -> Ptr () -> Ptr CString -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_reset" sqlite3_reset :: (Ptr CStmt) -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_column_count" sqlite3_column_count :: (Ptr CStmt) -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_column_name" sqlite3_column_name :: Ptr CStmt -> CInt -> IO CString foreign import ccall unsafe "sqlite3.h sqlite3_column_type" sqlite3_column_type :: (Ptr CStmt) -> CInt -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_column_text" sqlite3_column_text :: (Ptr CStmt) -> CInt -> IO CString foreign import ccall unsafe "sqlite3.h sqlite3_column_bytes" sqlite3_column_bytes :: (Ptr CStmt) -> CInt -> IO CInt foreign import ccall unsafe "hdbc-sqlite3-helper.h sqlite3_bind_text2" sqlite3_bind_text2 :: (Ptr CStmt) -> CInt -> CString -> CInt -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_bind_null" sqlite3_bind_null :: (Ptr CStmt) -> CInt -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_changes" sqlite3_changes :: Ptr CSqlite3 -> IO CInt foreign import ccall unsafe "sqlite3.h sqlite3_total_changes" sqlite3_total_changes :: Ptr CSqlite3 -> IO CInt HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/Types.hs0000644000000000000000000000024012516406577017327 0ustar0000000000000000module Database.HDBC.Sqlite3.Types where import Foreign.ForeignPtr data CSqlite3 type Sqlite3 = ForeignPtr CSqlite3 data CStmt type Stmt = ForeignPtr CStmt HDBC-sqlite3-2.3.3.1/Database/HDBC/Sqlite3/Utils.hsc0000644000000000000000000000371712516406577017502 0ustar0000000000000000{- -*- mode: haskell; -*- vim: set filetype=haskell: -} module Database.HDBC.Sqlite3.Utils where import Foreign.C.String import Foreign.ForeignPtr import Foreign.Ptr import Database.HDBC(throwSqlError) import Database.HDBC.Types import Database.HDBC.Sqlite3.Types import qualified Data.ByteString as B import qualified Data.ByteString.UTF8 as BUTF8 import Foreign.C.Types import Control.Exception import Foreign.Storable #include "hdbc-sqlite3-helper.h" checkError :: String -> Sqlite3 -> CInt -> IO () checkError _ _ 0 = return () checkError msg o res = withSqlite3 o (\p -> do rc <- sqlite3_errmsg p bs <- B.packCString rc let str = BUTF8.toString bs throwSqlError $ SqlError {seState = "", seNativeError = fromIntegral res, seErrorMsg = msg ++ ": " ++ str} ) {- This is a little hairy. We have a CSqlite3 object that is actually a finalizeonce wrapper around the real object. We use withSqlite3 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 withRawSqlite3. Ditto for statements. -} withSqlite3 :: Sqlite3 -> (Ptr CSqlite3 -> IO b) -> IO b withSqlite3 = genericUnwrap withRawSqlite3 :: Sqlite3 -> (Ptr CSqlite3 -> IO b) -> IO b withRawSqlite3 = withForeignPtr withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b withStmt = genericUnwrap withRawStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b withRawStmt = withForeignPtr genericUnwrap :: ForeignPtr a -> (Ptr a -> IO b) -> IO b genericUnwrap fptr action = withForeignPtr fptr (\structptr -> do objptr <- #{peek finalizeonce, encapobj} structptr action objptr ) foreign import ccall unsafe "sqlite3.h sqlite3_errmsg" sqlite3_errmsg :: (Ptr CSqlite3) -> IO CString HDBC-sqlite3-2.3.3.1/testsrc/0000755000000000000000000000000012516406577013632 5ustar0000000000000000HDBC-sqlite3-2.3.3.1/testsrc/runtests.hs0000644000000000000000000000022312516406577016052 0ustar0000000000000000{- arch-tag: Test runner -} module Main where import Test.HUnit import Tests import TestUtils main = do printDBInfo runTestTT tests HDBC-sqlite3-2.3.3.1/testsrc/SpecificDB.hs0000644000000000000000000000055212516406577016123 0ustar0000000000000000module SpecificDB where import Database.HDBC import Database.HDBC.Sqlite3 import Test.HUnit connectDB = handleSqlError (connectSqlite3 "testtmp.sql3") dateTimeTypeOfSqlValue :: SqlValue -> String dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "TEXT" dateTimeTypeOfSqlValue (SqlEpochTime _) = "INTEGER" dateTimeTypeOfSqlValue _ = "TEXT" supportsFracTime = TrueHDBC-sqlite3-2.3.3.1/testsrc/SpecificDBTests.hs0000644000000000000000000000040612516406577017144 0ustar0000000000000000module SpecificDBTests where import Database.HDBC import Database.HDBC.Sqlite3 import Test.HUnit import TestMisc(setup) testgetTables = setup $ \dbh -> do r <- getTables dbh ["hdbctest2"] @=? r tests = TestList [TestLabel "getTables" testgetTables] HDBC-sqlite3-2.3.3.1/testsrc/Testbasics.hs0000644000000000000000000001503512516406577016276 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 ('fetchAllRows', ?, NULL, NULL)" executeMany sth rows commit dbh sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows' 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 ('fetchAllRows2', ?, NULL, NULL)" executeMany sth rows commit dbh sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'fetchAllRows2' 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-sqlite3-2.3.3.1/testsrc/TestMisc.hs0000644000000000000000000001702012516406577015721 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-sqlite3-2.3.3.1/testsrc/Tests.hs0000644000000000000000000000113012516406577015263 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 test1 = TestCase ("x" @=? "x") tests = TestList [TestLabel "test1" test1, 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-sqlite3-2.3.3.1/testsrc/TestSbasics.hs0000644000000000000000000001551412516406577016423 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 multiFinish = dbTestCase (\dbh -> do sth <- prepare dbh "SELECT 1 + 1" sExecute sth [] finish sth finish sth finish sth ) runRawTest = dbTestCase (\dbh -> do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)" tables <- getTables dbh assertBool "valid1 table not created!" ("valid1" `elem` tables) assertBool "valid2 table not created!" ("valid2" `elem` tables) ) runRawErrorTest = dbTestCase (\dbh -> do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql` (return . seErrorMsg) assertEqual "exception text" "exec: near \"INVALID\": syntax error" err rollback dbh tables <- getTables dbh assertBool "valid1 table created!" (not $ "valid1" `elem` tables) ) 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 "multiFinish" multiFinish, TestLabel "runRawTest" runRawTest, TestLabel "runRawErrorTest" runRawErrorTest, 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-sqlite3-2.3.3.1/testsrc/TestUtils.hs0000644000000000000000000000174112516406577016131 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