Menu
▾
▴
htoolkit-cvs — HToolkit CVS commit messages
You can subscribe to this list here.
| 2003 |
Jan
(30) |
Feb
(20) |
Mar
(151) |
Apr
(86) |
May
(23) |
Jun
(25) |
Jul
(107) |
Aug
(141) |
Sep
(55) |
Oct
(85) |
Nov
(65) |
Dec
(2) |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| 2004 |
Jan
(22) |
Feb
(18) |
Mar
(3) |
Apr
(16) |
May
(69) |
Jun
(3) |
Jul
(1) |
Aug
(3) |
Sep
(1) |
Oct
|
Nov
(6) |
Dec
(1) |
| 2005 |
Jan
(2) |
Feb
(16) |
Mar
|
Apr
|
May
|
Jun
(47) |
Jul
(1) |
Aug
|
Sep
(6) |
Oct
(4) |
Nov
|
Dec
(34) |
| 2006 |
Jan
(39) |
Feb
|
Mar
(2) |
Apr
|
May
|
Jun
(1) |
Jul
|
Aug
|
Sep
(5) |
Oct
|
Nov
(4) |
Dec
|
| 2007 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
|
Nov
|
Dec
(1) |
| 2008 |
Jan
|
Feb
|
Mar
(26) |
Apr
(1) |
May
(1) |
Jun
|
Jul
(5) |
Aug
(2) |
Sep
(8) |
Oct
(8) |
Nov
(22) |
Dec
(30) |
| 2009 |
Jan
(10) |
Feb
(13) |
Mar
(14) |
Apr
(14) |
May
(32) |
Jun
(25) |
Jul
(36) |
Aug
(10) |
Sep
(2) |
Oct
|
Nov
|
Dec
(10) |
| 2010 |
Jan
(9) |
Feb
(4) |
Mar
(2) |
Apr
(1) |
May
(2) |
Jun
(2) |
Jul
(1) |
Aug
(4) |
Sep
|
Oct
(1) |
Nov
|
Dec
|
|
From: <kr_...@us...> - 2005-06-16 18:14:45
|
Update of /cvsroot/htoolkit/HSQL/SQLite3 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12539/SQLite3 Log Message: Directory /cvsroot/htoolkit/HSQL/SQLite3 added to the repository |
|
From: <kr_...@us...> - 2005-06-16 18:09:01
|
Update of /cvsroot/htoolkit/HSQL/SQLite In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv8511 Modified Files: Setup.lhs Log Message: Use pkg-config in the sqlite setup. Index: Setup.lhs =================================================================== RCS file: /cvsroot/htoolkit/HSQL/SQLite/Setup.lhs,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** Setup.lhs 9 Jun 2005 12:12:43 -0000 1.2 --- Setup.lhs 16 Jun 2005 18:08:52 -0000 1.3 *************** *** 1,62 **** ! #! runghc ! ! \begin{code} ! import Distribution.PackageDescription ! import Distribution.Setup ! import Distribution.Simple ! import Distribution.Simple.LocalBuildInfo ! import Distribution.Simple.Utils(rawSystemVerbose) ! import System.Info ! import System.Exit ! import System.Directory ! import Control.Monad(when) ! import Control.Exception(try) ! ! main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf} ! where ! preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo ! preConf args flags = do ! try (removeFile "SQLite.buildinfo") ! return emptyHookedBuildInfo ! postConf :: [String] -> ConfigFlags -> LocalBuildInfo -> IO ExitCode ! postConf args flags localbuildinfo = do ! testCompileRes <- testForSqlite localbuildinfo 0 ! case testCompileRes of ! ExitSuccess -> do ! message "sqlite library and headers are found" ! return testCompileRes ! ExitFailure n -> do ! message "sqlite library or headers aren't found" ! message "The package will not be build" ! let hbi = (Just emptyBuildInfo{buildable=False},[]) ! writeHookedBuildInfo "SQLite.buildinfo" hbi ! return testCompileRes ! \end{code} ! ! \begin{code} ! testForSqlite :: LocalBuildInfo -> Int -> IO ExitCode ! testForSqlite lbi verbose = do ! -- create program ! when (verbose > 0) $ do ! putStrLn "Test whether compile (test.hs):" ! putStrLn testProgram ! writeFile "test.hs" testProgram ! -- try to compile it ! let ghcPath = compilerPath (compiler lbi) ! let ghcArgs = ["test.hs", "-lsqlite", "--make", "-ffi", "-o", "test.bin"] ! res <- rawSystemVerbose verbose ghcPath ghcArgs ! try (removeFile "test.hs") ! try (removeFile "test.hi") ! try (removeFile "test.o") ! try (removeFile "test.bin") ! return res ! where ! testProgram = ! "import Foreign\n" ++ ! "import Foreign.C\n" ++ ! "foreign import ccall \"sqlite.h sqlite_open\" sqlite_open :: CString -> CInt -> Ptr CString -> IO (Ptr ())\n"++ ! "main = return ()" ! ! message :: String -> IO () ! message s = putStrLn $ "configure: " ++ s ! \end{code} --- 1,91 ---- ! #!/usr/bin/runghc ! ! \begin{code} ! import Distribution.PackageDescription ! import Distribution.Setup ! import Distribution.Simple ! import Distribution.Simple.LocalBuildInfo ! import Distribution.Simple.Utils(rawSystemVerbose) ! import System.Info ! import System.Exit ! import System.Directory ! import System.Process(runInteractiveProcess, waitForProcess) ! import System.IO(hClose, hGetContents, hPutStr, stderr) ! import Control.Monad(when) ! import Control.Exception(try) ! ! main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf} ! where ! preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo ! preConf args flags = do ! try (removeFile "SQLite.buildinfo") ! return emptyHookedBuildInfo ! postConf :: [String] -> ConfigFlags -> LocalBuildInfo -> IO ExitCode ! postConf args flags localbuildinfo = do ! mb_bi <- pkgConfigBuildInfo (configVerbose flags) "sqlite" ! let bi = case mb_bi of ! Just bi -> bi ! Nothing -> emptyBuildInfo{extraLibs=["sqlite"]} ! writeHookedBuildInfo "SQLite.buildinfo" (Just bi,[]) ! return ExitSuccess ! \end{code} ! ! The following code is derived from Distribution.Simple.Configure ! \begin{code} ! findProgram ! :: String -- ^ program name ! -> Maybe FilePath -- ^ optional explicit path ! -> IO (Maybe FilePath) ! findProgram name Nothing = do ! mb_path <- findExecutable name ! case mb_path of ! Nothing -> message ("No " ++ name ++ " found") ! Just path -> message ("Using " ++ name ++ ": " ++ path) ! return mb_path ! findProgram name (Just path) = do ! message ("Using " ++ name ++ ": " ++ path) ! return (Just path) ! ! rawSystemGrabOutput :: Int -> FilePath -> [String] -> IO String ! rawSystemGrabOutput verbose path args = do ! when (verbose > 0) $ ! putStrLn (path ++ concatMap (' ':) args) ! (inp,out,err,pid) <- runInteractiveProcess path args Nothing Nothing ! exitCode <- waitForProcess pid ! if exitCode /= ExitSuccess ! then do errMsg <- hGetContents err ! hPutStr stderr errMsg ! exitWith exitCode ! else return () ! hClose inp ! hClose err ! hGetContents out ! ! message :: String -> IO () ! message s = putStrLn $ "configure: " ++ s ! \end{code} ! ! Populate BuildInfo using pkg-config tool. ! \begin{code} ! pkgConfigBuildInfo :: Int -> String -> IO (Maybe BuildInfo) ! pkgConfigBuildInfo verbose pkgName = do ! mb_pkg_config_path <- findProgram "pkg-config" Nothing ! case mb_pkg_config_path of ! Just pkg_config_path -> do ! message ("configuring "++pkgName++" package using pkg-config") ! res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--libs-only-l"] ! let libs = map (tail.tail) (words res) ! res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--libs-only-L"] ! let lib_dirs = map (tail.tail) (words res) ! res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--libs-only-other"] ! let ld_opts = words res ! res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--cflags-only-I"] ! let inc_dirs = map (tail.tail) (words res) ! res <- rawSystemGrabOutput verbose pkg_config_path [pkgName, "--cflags-only-other"] ! let cc_opts = words res ! let bi = emptyBuildInfo{extraLibs=libs, extraLibDirs=lib_dirs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts} ! return (Just bi) ! Nothing -> do ! message ("The package will be built using default settings for "++pkgName) ! return Nothing ! \end{code} |
|
From: <kr_...@us...> - 2005-06-16 16:34:47
|
Update of /cvsroot/htoolkit/HSQL/ODBC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv13452 Modified Files: Setup.lhs Log Message: 1> The interpreter path is updated 2> CRLF -> CR Index: Setup.lhs =================================================================== RCS file: /cvsroot/htoolkit/HSQL/ODBC/Setup.lhs,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Setup.lhs 1 Feb 2005 13:04:08 -0000 1.1 --- Setup.lhs 16 Jun 2005 16:34:38 -0000 1.2 *************** *** 1,18 **** ! #! runghc ! ! \begin{code} ! import Distribution.Simple ! import Distribution.Setup ! import Distribution.PackageDescription ! import System.Info ! ! main = defaultMainWithHooks defaultUserHooks{preConf=configure} ! where ! configure :: [String] -> ConfigFlags -> IO HookedBuildInfo ! configure args flags = do ! let binfo | os == "mingw32" = emptyBuildInfo{extraLibs=["odbc32"], ccOptions=["-DMSSQL_ODBC", "-Dmingw32_HOST_OS"]} ! | otherwise = emptyBuildInfo{extraLibs=["odbc"]} ! hbi = (Just binfo,[]) ! writeHookedBuildInfo "ODBC.buildinfo" hbi ! return hbi ! \end{code} --- 1,18 ---- ! #!/usr/bin/runghc ! ! \begin{code} ! import Distribution.Simple ! import Distribution.Setup ! import Distribution.PackageDescription ! import System.Info ! ! main = defaultMainWithHooks defaultUserHooks{preConf=configure} ! where ! configure :: [String] -> ConfigFlags -> IO HookedBuildInfo ! configure args flags = do ! let binfo | os == "mingw32" = emptyBuildInfo{extraLibs=["odbc32"], ccOptions=["-DMSSQL_ODBC", "-Dmingw32_HOST_OS"]} ! | otherwise = emptyBuildInfo{extraLibs=["odbc"]} ! hbi = (Just binfo,[]) ! writeHookedBuildInfo "ODBC.buildinfo" hbi ! return hbi ! \end{code} |
|
From: <kr_...@us...> - 2005-06-16 16:33:34
|
Update of /cvsroot/htoolkit/HSQL/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv12541 Modified Files: Setup.lhs Log Message: 1> The interpreted path is updated 2> CRLF -> CR Index: Setup.lhs =================================================================== RCS file: /cvsroot/htoolkit/HSQL/HSQL/Setup.lhs,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Setup.lhs 1 Feb 2005 13:04:06 -0000 1.1 --- Setup.lhs 16 Jun 2005 16:33:25 -0000 1.2 *************** *** 1,7 **** ! #! runghc ! ! \begin{code} ! import Distribution.Simple ! ! main = defaultMain ! \end{code} --- 1,7 ---- ! #!/usr/bin/runghc ! ! \begin{code} ! import Distribution.Simple ! ! main = defaultMain ! \end{code} |
|
From: <kr_...@us...> - 2005-06-14 14:16:40
|
Update of /cvsroot/htoolkit/HSQL/MSI/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23805/MSI/Database/HSQL Added Files: MSI.hsc Log Message: Added MSI driver --- NEW FILE: MSI.hsc --- {-# OPTIONS -fglasgow-exts #-} ----------------------------------------------------------------------------------------- {-| Module : Database.HSQL.MSI Copyright : (c) Krasimir Angelov 2005 License : BSD-style Maintainer : kr....@gm... Stability : provisional Portability : portable The module provides interface to Microsoft Installer Database -} ----------------------------------------------------------------------------------------- module Database.HSQL.MSI(connect, module Database.HSQL) where import Control.Concurrent.MVar import Control.Exception (throwDyn) import Control.Monad import Data.Char (isUpper, toLower) import Data.IORef import Data.Word import Foreign import Foreign.C import Database.HSQL import Database.HSQL.Types #include <windows.h> type MSIHANDLE = CInt connect :: String -> String -> IO Connection connect source dest = withCString source $ \csource -> withCString dest $ \cdest -> alloca $ \phandle -> do msiOpenDatabase csource cdest phandle >>= checkResult 0 hDatabase <- peek phandle refFalse <- newMVar False let connection = (Connection { connDisconnect = disconnect hDatabase , connExecute = execute hDatabase , connQuery = query connection hDatabase , connTables = tables connection hDatabase , connDescribe = describe connection hDatabase , connBeginTransaction = beginTransaction hDatabase , connCommitTransaction = commitTransaction hDatabase , connRollbackTransaction = rollbackTransaction hDatabase , connClosed = refFalse }) return connection where disconnect :: MSIHANDLE -> IO () disconnect hDatabase = do msiDatabaseCommit hDatabase >>= checkResult hDatabase msiCloseHandle hDatabase >>= checkResult hDatabase execute :: MSIHANDLE -> String -> IO () execute hDatabase query = withCString query $ \cquery -> alloca $ \phandle -> do msiDatabaseOpenView hDatabase cquery phandle >>= checkResult hDatabase hView <- peek phandle msiViewExecute hView 0 >>= checkResult hDatabase msiCloseHandle hView >>= checkResult hDatabase query :: Connection -> MSIHANDLE -> String -> IO Statement query connection hDatabase query = withCString query $ \cquery -> alloca $ \phandle -> do msiDatabaseOpenView hDatabase cquery phandle >>= checkResult hDatabase hView <- peek phandle msiViewExecute hView 0 >>= checkResult hDatabase fields <- getFields hView refFalse <- newMVar False refRecord <- newIORef 0 let statement = Statement { stmtConn = connection , stmtClose = closeStatement hView refRecord , stmtFetch = fetch hView refRecord , stmtGetCol = getColValue refRecord , stmtFields = fields , stmtClosed = refFalse } return statement where getFields hView = alloca $ \phNamesRecord -> alloca $ \phTypesRecord -> do msiViewGetColumnInfo hView 0 phNamesRecord >>= checkResult hView msiViewGetColumnInfo hView 1 phTypesRecord >>= checkResult hView hNamesRecord <- peek phNamesRecord hTypesRecord <- peek phTypesRecord count <- msiRecordGetFieldCount hNamesRecord loop 1 count hNamesRecord hTypesRecord loop n count hNamesRecord hTypesRecord | n > count = return [] | otherwise = allocaBytes 1024 $ \buffer -> alloca $ \plen -> do poke plen 1024 msiRecordGetString hNamesRecord n buffer plen >>= checkResult hNamesRecord name <- peekCString buffer poke plen 1024 msiRecordGetString hTypesRecord n buffer plen >>= checkResult hTypesRecord typ <- peekCString buffer fieldDefs <- loop (n+1) count hNamesRecord hTypesRecord return (mkFieldDef name typ : fieldDefs) mkFieldDef name (c:cs) = (name, sqlType, isUpper c) where width = read cs sqlType = case toLower c of 's' -> case width of 0 -> SqlText n -> SqlVarChar n 'l' -> case width of 0 -> SqlText n -> SqlVarChar n 'i' -> case width of 2 -> SqlInteger 4 -> SqlBigInt 'v' -> case width of 0 -> SqlBLOB tables :: Connection -> MSIHANDLE -> IO [String] tables connection hDatabase = undefined describe :: Connection -> MSIHANDLE -> String -> IO [FieldDef] describe connection hDatabase tableName = undefined beginTransaction hDatabase = throwDyn SqlUnsupportedOperation commitTransaction hDatabase = throwDyn SqlUnsupportedOperation rollbackTransaction hDatabase = throwDyn SqlUnsupportedOperation fetch :: MSIHANDLE -> IORef MSIHANDLE -> IO Bool fetch hView refRecord = do hRecord <- readIORef refRecord unless (hRecord == 0) $ (msiCloseHandle hRecord >>= checkResult hRecord) alloca $ \phRecord -> do res <- msiViewFetch hView phRecord if res == 259 then do writeIORef refRecord 0 return False else do checkResult hView res hRecord <- peek phRecord writeIORef refRecord hRecord return True getColValue :: IORef MSIHANDLE -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a) getColValue refRecord colNumber (name,sqlType,nullable) f = allocaBytes 1024 $ \buffer -> alloca $ \plen -> do poke plen 1024 hRecord <- readIORef refRecord msiRecordGetString hRecord (fromIntegral colNumber+1) buffer plen >>= checkResult hRecord len <- peek plen f sqlType buffer (fromIntegral len) closeStatement :: MSIHANDLE -> IORef MSIHANDLE -> IO () closeStatement hView refRecord = do msiCloseHandle hView >>= checkResult 0 hRecord <- readIORef refRecord unless (hRecord == 0) $ (msiCloseHandle hRecord >>= checkResult 0) foreign import stdcall "MsiOpenDatabaseA" msiOpenDatabase :: CString -> CString -> Ptr MSIHANDLE -> IO Word32 foreign import stdcall "MsiDatabaseCommit" msiDatabaseCommit :: MSIHANDLE -> IO Word32 foreign import stdcall "MsiCloseHandle" msiCloseHandle :: MSIHANDLE -> IO Word32 foreign import stdcall "MsiDatabaseOpenViewA" msiDatabaseOpenView :: MSIHANDLE -> CString -> Ptr MSIHANDLE -> IO Word32 foreign import stdcall "MsiViewExecute" msiViewExecute :: MSIHANDLE -> MSIHANDLE -> IO Word32 foreign import stdcall "MsiGetLastErrorRecord" msiGetLastErrorRecord :: IO MSIHANDLE foreign import stdcall "MsiFormatRecordA" msiFormatRecord :: MSIHANDLE -> MSIHANDLE -> CString -> Ptr CInt -> IO Word32 foreign import stdcall "MsiViewGetColumnInfo" msiViewGetColumnInfo :: MSIHANDLE -> CInt -> Ptr MSIHANDLE -> IO Word32 foreign import stdcall "MsiRecordGetFieldCount" msiRecordGetFieldCount :: MSIHANDLE -> IO Word32 foreign import stdcall "MsiRecordGetStringA" msiRecordGetString :: MSIHANDLE -> Word32 -> CString -> Ptr Word32 -> IO Word32 foreign import stdcall "MsiViewFetch" msiViewFetch :: MSIHANDLE -> Ptr MSIHANDLE -> IO Word32 foreign import stdcall "FormatMessageA" formatMessage :: Word32 -> Ptr () -> Word32 -> Word32 -> CString -> Word32 -> Ptr () -> IO Word32 checkResult :: MSIHANDLE -> Word32 -> IO () checkResult hDatabase err | err == 0 = return () | otherwise = do hRecord <- msiGetLastErrorRecord msg <- allocaBytes 1024 $ \cmsg -> do formatMessage (#const FORMAT_MESSAGE_FROM_SYSTEM) nullPtr err 0 cmsg 1024 nullPtr peekCString cmsg msiCloseHandle hRecord throwDyn (SqlError "" (fromIntegral err) msg) |
|
From: <kr_...@us...> - 2005-06-14 14:16:40
|
Update of /cvsroot/htoolkit/HSQL/MSI In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23805/MSI Added Files: MSI.cabal Setup.lhs Log Message: Added MSI driver --- NEW FILE: MSI.cabal --- name: hsql-msi version: 1.5 license: BSD3 author: Krasimir Angelov <kr....@gm...> category: Database description: MSI driver for HSQL. exposed-modules:Database.HSQL.MSI build-depends: base, hsql extensions: ForeignFunctionInterface, CPP extra-libraries: msi, kernel32 --- NEW FILE: Setup.lhs --- #! runghc \begin{code} import Distribution.Simple main = defaultMain \end{code} |
|
From: <kr_...@us...> - 2005-06-14 14:14:47
|
Update of /cvsroot/htoolkit/HSQL/MSI/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv23081/HSQL Log Message: Directory /cvsroot/htoolkit/HSQL/MSI/Database/HSQL added to the repository |
|
From: <kr_...@us...> - 2005-06-14 14:14:31
|
Update of /cvsroot/htoolkit/HSQL/MSI/Database In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22968/Database Log Message: Directory /cvsroot/htoolkit/HSQL/MSI/Database added to the repository |
|
From: <kr_...@us...> - 2005-06-14 14:14:12
|
Update of /cvsroot/htoolkit/HSQL/MSI In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv22685/MSI Log Message: Directory /cvsroot/htoolkit/HSQL/MSI added to the repository |
|
From: <kr_...@us...> - 2005-06-14 09:40:04
|
Update of /cvsroot/htoolkit/HSQL/HSQL/Database In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7354 Modified Files: HSQL.hsc Log Message: Added instance SqlBind Float Index: HSQL.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL.hsc,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** HSQL.hsc 1 Feb 2005 13:04:06 -0000 1.1 --- HSQL.hsc 14 Jun 2005 09:39:56 -0000 1.2 *************** *** 283,286 **** --- 283,297 ---- toSqlValue d = show d + instance SqlBind Float where + fromSqlValue (SqlDecimal _ _) s = Just (read s) + fromSqlValue (SqlNumeric _ _) s = Just (read s) + fromSqlValue SqlDouble s = Just (read s) + fromSqlValue SqlReal s = Just (read s) + fromSqlValue SqlFloat s = Just (read s) + fromSqlValue SqlText s = Just (read s) + fromSqlValue _ _ = Nothing + + toSqlValue d = show d + mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime mkClockTime year mon mday hour min sec tz = |
|
From: <kr_...@us...> - 2005-06-14 09:38:55
|
Update of /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv7018/Database/HSQL Modified Files: Types.hs Log Message: Comments for MSI Index: Types.hs =================================================================== RCS file: /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL/Types.hs,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Types.hs 1 Feb 2005 13:04:07 -0000 1.1 --- Types.hs 14 Jun 2005 09:38:47 -0000 1.2 *************** *** 10,16 **** data SqlType = SqlChar Int -- ODBC, MySQL, PostgreSQL ! | SqlVarChar Int -- ODBC, MySQL, PostgreSQL | SqlLongVarChar Int -- ODBC ! | SqlText -- , , PostgreSQL | SqlWChar Int -- ODBC | SqlWVarChar Int -- ODBC --- 10,16 ---- data SqlType = SqlChar Int -- ODBC, MySQL, PostgreSQL ! | SqlVarChar Int -- ODBC, MySQL, PostgreSQL, MSI | SqlLongVarChar Int -- ODBC ! | SqlText -- , , PostgreSQL, MSI | SqlWChar Int -- ODBC | SqlWVarChar Int -- ODBC *************** *** 19,24 **** | SqlNumeric Int Int -- ODBC, MySQL, PostgreSQL | SqlSmallInt -- ODBC, MySQL, PostgreSQL ! | SqlMedInt -- , MySQL ! | SqlInteger -- ODBC, MySQL, PostgreSQL | SqlReal -- ODBC, MySQL, PostgreSQL | SqlFloat -- ODBC --- 19,24 ---- | SqlNumeric Int Int -- ODBC, MySQL, PostgreSQL | SqlSmallInt -- ODBC, MySQL, PostgreSQL ! | SqlMedInt -- , MySQL, ! | SqlInteger -- ODBC, MySQL, PostgreSQL, MSI | SqlReal -- ODBC, MySQL, PostgreSQL | SqlFloat -- ODBC *************** *** 26,30 **** | SqlBit -- ODBC, , PostgreSQL | SqlTinyInt -- ODBC, MySQL, PostgreSQL ! | SqlBigInt -- ODBC, MySQL, PostgreSQL | SqlBinary Int -- ODBC, , PostgreSQL | SqlVarBinary Int -- ODBC, , PostgreSQL --- 26,30 ---- | SqlBit -- ODBC, , PostgreSQL | SqlTinyInt -- ODBC, MySQL, PostgreSQL ! | SqlBigInt -- ODBC, MySQL, PostgreSQL, MSI | SqlBinary Int -- ODBC, , PostgreSQL | SqlVarBinary Int -- ODBC, , PostgreSQL *************** *** 43,47 **** | SqlSET -- , MySQL | SqlENUM -- , MySQL ! | SqlBLOB -- , MySQL | SqlMoney -- , , PostgreSQL | SqlINetAddr -- , , PostgreSQL --- 43,47 ---- | SqlSET -- , MySQL | SqlENUM -- , MySQL ! | SqlBLOB -- , MySQL, , MSI | SqlMoney -- , , PostgreSQL | SqlINetAddr -- , , PostgreSQL |
|
From: <kr_...@us...> - 2005-06-10 08:26:33
|
Update of /cvsroot/htoolkit/HSQL/mingw32lib In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv10279 Modified Files: Makefile Added Files: msi.def Log Message: Added libmsi.a --- NEW FILE: msi.def --- LIBRARY MSI.DLL EXPORTS DllCanUnloadNow DllGetClassObject DllGetVersion DllRegisterServer DllUnregisterServer Migrate10CachedPackagesA Migrate10CachedPackagesW MsiAdvertiseProductA MsiAdvertiseProductExA MsiAdvertiseProductExW MsiAdvertiseProductW MsiAdvertiseScriptA MsiAdvertiseScriptW MsiApplyPatchA MsiApplyPatchW MsiCloseAllHandles MsiCloseHandle@4 MsiCollectUserInfoA MsiCollectUserInfoW MsiConfigureFeatureA MsiConfigureFeatureFromDescriptorA MsiConfigureFeatureFromDescriptorW MsiConfigureFeatureW MsiConfigureProductA MsiConfigureProductExA MsiConfigureProductExW MsiConfigureProductW MsiCreateAndVerifyInstallerDirectory MsiCreateRecord MsiCreateTransformSummaryInfoA MsiCreateTransformSummaryInfoW MsiDatabaseApplyTransformA MsiDatabaseApplyTransformW MsiDatabaseCommit@4 MsiDatabaseExportA MsiDatabaseExportW MsiDatabaseGenerateTransformA MsiDatabaseGenerateTransformW MsiDatabaseGetPrimaryKeysA MsiDatabaseGetPrimaryKeysW MsiDatabaseImportA MsiDatabaseImportW MsiDatabaseIsTablePersistentA MsiDatabaseIsTablePersistentW MsiDatabaseMergeA MsiDatabaseMergeW MsiDatabaseOpenViewA@12 MsiDatabaseOpenViewW@12 MsiDecomposeDescriptorA MsiDecomposeDescriptorW MsiDeleteUserDataA MsiDeleteUserDataW MsiDoActionA MsiDoActionW MsiEnableLogA MsiEnableLogW MsiEnableUIPreview MsiEnumClientsA MsiEnumClientsW MsiEnumComponentCostsA MsiEnumComponentCostsW MsiEnumComponentQualifiersA MsiEnumComponentQualifiersW MsiEnumComponentsA MsiEnumComponentsW MsiEnumFeaturesA MsiEnumFeaturesW MsiEnumPatchesA MsiEnumPatchesW MsiEnumProductsA MsiEnumProductsW MsiEnumRelatedProductsA MsiEnumRelatedProductsW MsiEvaluateConditionA MsiEvaluateConditionW MsiFormatRecordA@16 MsiFormatRecordW MsiGetActiveDatabase MsiGetComponentPathA MsiGetComponentPathW MsiGetComponentStateA MsiGetComponentStateW MsiGetDatabaseState MsiGetFeatureCostA MsiGetFeatureCostW MsiGetFeatureInfoA MsiGetFeatureInfoW MsiGetFeatureStateA MsiGetFeatureStateW MsiGetFeatureUsageA MsiGetFeatureUsageW MsiGetFeatureValidStatesA MsiGetFeatureValidStatesW MsiGetFileHashA MsiGetFileHashW MsiGetFileSignatureInformationA MsiGetFileSignatureInformationW MsiGetFileVersionA MsiGetFileVersionW MsiGetLanguage MsiGetLastErrorRecord@0 MsiGetMode MsiGetPatchInfoA MsiGetPatchInfoW MsiGetProductCodeA MsiGetProductCodeFromPackageCodeA MsiGetProductCodeFromPackageCodeW MsiGetProductCodeW MsiGetProductInfoA MsiGetProductInfoFromScriptA MsiGetProductInfoFromScriptW MsiGetProductInfoW MsiGetProductPropertyA MsiGetProductPropertyW MsiGetPropertyA MsiGetPropertyW MsiGetShortcutTargetA MsiGetShortcutTargetW MsiGetSourcePathA MsiGetSourcePathW MsiGetSummaryInformationA MsiGetSummaryInformationW MsiGetTargetPathA MsiGetTargetPathW MsiGetUserInfoA MsiGetUserInfoW MsiInstallMissingComponentA MsiInstallMissingComponentW MsiInstallMissingFileA MsiInstallMissingFileW MsiInstallProductA MsiInstallProductW MsiInvalidateFeatureCache MsiIsProductElevatedA MsiIsProductElevatedW MsiLoadStringA MsiLoadStringW MsiLocateComponentA MsiLocateComponentW MsiMessageBoxA MsiMessageBoxW MsiNotifySidChangeA MsiNotifySidChangeW MsiOpenDatabaseA@12 MsiOpenDatabaseW@12 MsiOpenPackageA MsiOpenPackageExA MsiOpenPackageExW MsiOpenPackageW MsiOpenProductA MsiOpenProductW MsiPreviewBillboardA MsiPreviewBillboardW MsiPreviewDialogA MsiPreviewDialogW MsiProcessAdvertiseScriptA MsiProcessAdvertiseScriptW MsiProcessMessage MsiProvideAssemblyA MsiProvideAssemblyW MsiProvideComponentA MsiProvideComponentFromDescriptorA MsiProvideComponentFromDescriptorW MsiProvideComponentW MsiProvideQualifiedComponentA MsiProvideQualifiedComponentExA MsiProvideQualifiedComponentExW MsiProvideQualifiedComponentW MsiQueryFeatureStateA MsiQueryFeatureStateFromDescriptorA MsiQueryFeatureStateFromDescriptorW MsiQueryFeatureStateW MsiQueryProductStateA MsiQueryProductStateW MsiRecordClearData MsiRecordDataSize MsiRecordGetFieldCount MsiRecordGetInteger MsiRecordGetStringA MsiRecordGetStringW MsiRecordIsNull MsiRecordReadStream MsiRecordSetInteger MsiRecordSetStreamA MsiRecordSetStreamW MsiRecordSetStringA MsiRecordSetStringW MsiReinstallFeatureA MsiReinstallFeatureFromDescriptorA MsiReinstallFeatureFromDescriptorW MsiReinstallFeatureW MsiReinstallProductA MsiReinstallProductW MsiSequenceA MsiSequenceW MsiSetComponentStateA MsiSetComponentStateW MsiSetExternalUIA MsiSetExternalUIW MsiSetFeatureAttributesA MsiSetFeatureAttributesW MsiSetFeatureStateA MsiSetFeatureStateW MsiSetInstallLevel MsiSetInternalUI MsiSetMode MsiSetPropertyA MsiSetPropertyW MsiSetTargetPathA MsiSetTargetPathW MsiSourceListAddSourceA MsiSourceListAddSourceW MsiSourceListClearAllA MsiSourceListClearAllW MsiSourceListForceResolutionA MsiSourceListForceResolutionW MsiSummaryInfoGetPropertyA MsiSummaryInfoGetPropertyCount MsiSummaryInfoGetPropertyW MsiSummaryInfoPersist MsiSummaryInfoSetPropertyA MsiSummaryInfoSetPropertyW MsiUseFeatureA MsiUseFeatureExA MsiUseFeatureExW MsiUseFeatureW MsiVerifyDiskSpace MsiVerifyPackageA MsiVerifyPackageW MsiViewClose MsiViewExecute@8 MsiViewFetch MsiViewGetColumnInfo MsiViewGetErrorA MsiViewGetErrorW MsiViewModify Index: Makefile =================================================================== RCS file: /cvsroot/htoolkit/HSQL/mingw32lib/Makefile,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Makefile 10 Apr 2004 19:43:23 -0000 1.1 --- Makefile 10 Jun 2005 08:26:19 -0000 1.2 *************** *** 1,3 **** ! all: liblibmysql.a liblibpq.a libsqlite.a liblibmysql.a: libmysql.def --- 1,3 ---- ! all: liblibmysql.a liblibpq.a libsqlite.a libmsi.a liblibmysql.a: libmysql.def *************** *** 9,10 **** --- 9,13 ---- libsqlite.a: sqlite.def dlltool --input-def sqlite.def --dllname sqlite.dll --output-lib libsqlite.a -k + + libmsi.a: msi.def + dlltool --input-def msi.def --dllname msi.dll --output-lib libmsi.a -k |
|
From: <kr_...@us...> - 2005-06-09 12:16:47
|
Update of /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30331/ODBC/Database/HSQL Modified Files: ODBC.hsc Log Message: Replace ka2...@ya... with kr....@gm... Index: ODBC.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL/ODBC.hsc,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** ODBC.hsc 1 Feb 2005 13:22:47 -0000 1.2 --- ODBC.hsc 9 Jun 2005 12:16:34 -0000 1.3 *************** *** 6,10 **** License : BSD-style ! Maintainer : ka2...@ya... Stability : provisional Portability : portable --- 6,10 ---- License : BSD-style ! Maintainer : kr....@gm... Stability : provisional Portability : portable |
|
From: <kr_...@us...> - 2005-06-09 12:16:47
|
Update of /cvsroot/htoolkit/HSQL/ODBC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30331/ODBC Modified Files: ODBC.cabal Log Message: Replace ka2...@ya... with kr....@gm... Index: ODBC.cabal =================================================================== RCS file: /cvsroot/htoolkit/HSQL/ODBC/ODBC.cabal,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** ODBC.cabal 1 Feb 2005 13:04:08 -0000 1.1 --- ODBC.cabal 9 Jun 2005 12:16:34 -0000 1.2 *************** *** 2,6 **** version: 1.5 license: BSD3 ! author: Krasimir Angelov <ka2...@ya...> category: Database description: ODBC driver for HSQL. --- 2,6 ---- version: 1.5 license: BSD3 ! author: Krasimir Angelov <kr....@gm...> category: Database description: ODBC driver for HSQL. |
|
From: <kr_...@us...> - 2005-06-09 12:16:47
|
Update of /cvsroot/htoolkit/HSQL/SQLite In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30331/SQLite Modified Files: SQLite.cabal Log Message: Replace ka2...@ya... with kr....@gm... Index: SQLite.cabal =================================================================== RCS file: /cvsroot/htoolkit/HSQL/SQLite/SQLite.cabal,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** SQLite.cabal 9 Jun 2005 12:14:25 -0000 1.2 --- SQLite.cabal 9 Jun 2005 12:16:34 -0000 1.3 *************** *** 2,6 **** version: 1.5 license: BSD3 ! author: Krasimir Angelov <ka2...@ya...> category: Database description: SQLite driver for HSQL. --- 2,6 ---- version: 1.5 license: BSD3 ! author: Krasimir Angelov <kr....@gm...> category: Database description: SQLite driver for HSQL. |
|
From: <kr_...@us...> - 2005-06-09 12:16:46
|
Update of /cvsroot/htoolkit/HSQL/SQLite/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30331/SQLite/Database/HSQL Modified Files: SQLite.hsc Log Message: Replace ka2...@ya... with kr....@gm... Index: SQLite.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/SQLite/Database/HSQL/SQLite.hsc,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** SQLite.hsc 1 Feb 2005 13:04:24 -0000 1.1 --- SQLite.hsc 9 Jun 2005 12:16:34 -0000 1.2 *************** *** 4,8 **** License : BSD-style ! Maintainer : ka2...@ya... Stability : provisional Portability : portable --- 4,8 ---- License : BSD-style ! Maintainer : kr....@gm... Stability : provisional Portability : portable |
|
From: <kr_...@us...> - 2005-06-09 12:14:41
|
Update of /cvsroot/htoolkit/HSQL/SQLite In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv29633/SQLite Modified Files: SQLite.cabal Log Message: Upgrade Index: SQLite.cabal =================================================================== RCS file: /cvsroot/htoolkit/HSQL/SQLite/SQLite.cabal,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** SQLite.cabal 1 Feb 2005 13:04:08 -0000 1.1 --- SQLite.cabal 9 Jun 2005 12:14:25 -0000 1.2 *************** *** 1,10 **** ! name: hsql-sqlite ! version: 1.5 ! license: BSD3 ! author: Krasimir Angelov <ka2...@ya...> ! category: Database ! description: SQLite driver for HSQL. ! exposed-modules:Database.HSQL.SQLite ! build-depends: base, hsql ! extensions: ForeignFunctionInterface, CPP ! extra-libs: sqlite \ No newline at end of file --- 1,10 ---- ! name: hsql-sqlite ! version: 1.5 ! license: BSD3 ! author: Krasimir Angelov <ka2...@ya...> ! category: Database ! description: SQLite driver for HSQL. ! exposed-modules: Database.HSQL.SQLite ! build-depends: base, hsql ! extensions: ForeignFunctionInterface, CPP ! extra-libraries: sqlite \ No newline at end of file |
|
From: <kr_...@us...> - 2005-06-09 12:12:56
|
Update of /cvsroot/htoolkit/HSQL/SQLite In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28520/SQLite Modified Files: Setup.lhs Log Message: Upgrade to GHC-6.4 Index: Setup.lhs =================================================================== RCS file: /cvsroot/htoolkit/HSQL/SQLite/Setup.lhs,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** Setup.lhs 1 Feb 2005 13:04:08 -0000 1.1 --- Setup.lhs 9 Jun 2005 12:12:43 -0000 1.2 *************** *** 19,24 **** try (removeFile "SQLite.buildinfo") return emptyHookedBuildInfo ! postConf :: [String] -> LocalBuildInfo -> IO ExitCode ! postConf args localbuildinfo = do testCompileRes <- testForSqlite localbuildinfo 0 case testCompileRes of --- 19,24 ---- try (removeFile "SQLite.buildinfo") return emptyHookedBuildInfo ! postConf :: [String] -> ConfigFlags -> LocalBuildInfo -> IO ExitCode ! postConf args flags localbuildinfo = do testCompileRes <- testForSqlite localbuildinfo 0 case testCompileRes of |
|
From: <kr_...@us...> - 2005-02-01 13:23:01
|
Update of /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30731/ODBC/Database/HSQL Modified Files: ODBC.hsc Log Message: add -fglasgow-exts option Index: ODBC.hsc =================================================================== RCS file: /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL/ODBC.hsc,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** ODBC.hsc 1 Feb 2005 13:04:08 -0000 1.1 --- ODBC.hsc 1 Feb 2005 13:22:47 -0000 1.2 *************** *** 1,2 **** --- 1,4 ---- + {-# OPTIONS -fglasgow-exts #-} + ----------------------------------------------------------------------------------------- {-| Module : Database.HSQL.ODBC |
|
From: <kr_...@us...> - 2005-02-01 13:04:41
|
Update of /cvsroot/htoolkit/HSQL/SQLite/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26145/SQLite/Database/HSQL Added Files: SQLite.hsc Log Message: Add cabalized version of HSQL --- NEW FILE: SQLite.hsc --- ----------------------------------------------------------------------------------------- {-| Module : Database.HSQL.SQLite Copyright : (c) Krasimir Angelov 2003 License : BSD-style Maintainer : ka2...@ya... Stability : provisional Portability : portable The module provides interface to SQLite -} ----------------------------------------------------------------------------------------- module Database.HSQL.SQLite(connect, module Database.HSQL) where import Database.HSQL import Database.HSQL.Types import Foreign import Foreign.C import System.IO import Control.Monad(when) import Control.Exception(throwDyn) import Control.Concurrent.MVar #include <fcntl.h> #include <sqlite.h> type SQLite = Ptr () foreign import ccall sqlite_open :: CString -> CInt -> Ptr CString -> IO SQLite foreign import ccall sqlite_close :: SQLite -> IO () foreign import ccall sqlite_exec :: SQLite -> CString -> FunPtr () -> Ptr () -> Ptr CString -> IO CInt foreign import ccall sqlite_get_table :: SQLite -> CString -> Ptr (Ptr CString) -> Ptr CInt -> Ptr CInt -> Ptr CString -> IO CInt foreign import ccall sqlite_free_table :: Ptr CString -> IO () foreign import ccall sqlite_freemem :: CString -> IO () foreign import ccall "strlen" strlen :: CString -> IO CInt ----------------------------------------------------------------------------------------- -- routines for handling exceptions ----------------------------------------------------------------------------------------- handleSqlResult :: CInt -> Ptr CString -> IO () handleSqlResult res ppMsg | res == (#const SQLITE_OK) = return () | otherwise = do pMsg <- peek ppMsg msg <- peekCString pMsg sqlite_freemem pMsg throwDyn (SqlError "E" (fromIntegral res) msg) ----------------------------------------------------------------------------------------- -- Connect ----------------------------------------------------------------------------------------- connect :: FilePath -> IOMode -> IO Connection connect fpath mode = alloca $ \ppMsg -> withCString fpath $ \pFPath -> do sqlite <- sqlite_open pFPath 0 ppMsg when (sqlite == nullPtr) $ do pMsg <- peek ppMsg msg <- peekCString pMsg free pMsg throwDyn (SqlError { seState = "C" , seNativeError = 0 , seErrorMsg = msg }) refFalse <- newMVar False let connection = Connection { connDisconnect = sqlite_close sqlite , connClosed = refFalse , connExecute = execute sqlite , connQuery = query connection sqlite , connTables = tables connection sqlite , connDescribe = describe connection sqlite , connBeginTransaction = execute sqlite "BEGIN TRANSACTION" , connCommitTransaction = execute sqlite "COMMIT TRANSACTION" , connRollbackTransaction = execute sqlite "ROLLBACK TRANSACTION" } return connection where oflags1 = case mode of ReadMode -> (#const O_RDONLY) WriteMode -> (#const O_WRONLY) ReadWriteMode -> (#const O_RDWR) AppendMode -> (#const O_APPEND) execute :: SQLite -> String -> IO () execute sqlite query = withCString query $ \pQuery -> do alloca $ \ppMsg -> do res <- sqlite_exec sqlite pQuery nullFunPtr nullPtr ppMsg handleSqlResult res ppMsg query :: Connection -> SQLite -> String -> IO Statement query connection sqlite query = do withCString query $ \pQuery -> do alloca $ \ppResult -> do alloca $ \pnRow -> do alloca $ \pnColumn -> do alloca $ \ppMsg -> do res <- sqlite_get_table sqlite pQuery ppResult pnRow pnColumn ppMsg handleSqlResult res ppMsg pResult <- peek ppResult rows <- fmap fromIntegral (peek pnRow) columns <- fmap fromIntegral (peek pnColumn) defs <- getFieldDefs pResult 0 columns refFalse <- newMVar False refIndex <- newMVar 0 return (Statement { stmtConn = connection , stmtClose = sqlite_free_table pResult , stmtFetch = fetch refIndex rows , stmtGetCol = getColValue pResult refIndex columns rows , stmtFields = defs , stmtClosed = refFalse }) where getFieldDefs :: Ptr CString -> Int -> Int -> IO [FieldDef] getFieldDefs pResult index count | index >= count = return [] | otherwise = do name <- peekElemOff pResult index >>= peekCString defs <- getFieldDefs pResult (index+1) count return ((name,SqlText,True):defs) tables :: Connection -> SQLite -> IO [String] tables connection sqlite = do stmt <- query connection sqlite "select tbl_name from sqlite_master" collectRows (\stmt -> getFieldValue stmt "tbl_name") stmt describe :: Connection -> SQLite -> String -> IO [FieldDef] describe connection sqlite table = do stmt <- query connection sqlite ("pragma table_info("++table++")") collectRows getRow stmt where getRow stmt = do name <- getFieldValue stmt "name" notnull <- getFieldValue stmt "notnull" return (name, SqlText, notnull=="0") fetch tupleIndex countTuples = modifyMVar tupleIndex (\index -> return (index+1,index < countTuples)) getColValue pResult refIndex columns rows colNumber (name,sqlType,nullable) f = do index <- readMVar refIndex when (index > rows) (throwDyn SqlNoData) pStr <- peekElemOff pResult (columns*index+colNumber) if pStr == nullPtr then return Nothing else do strLen <- strlen pStr mb_value <- f sqlType pStr (fromIntegral strLen) case mb_value of Just v -> return (Just v) Nothing -> throwDyn (SqlBadTypeCast name sqlType) |
|
From: <kr_...@us...> - 2005-02-01 13:04:20
|
Update of /cvsroot/htoolkit/HSQL/HSQL/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26145/HSQL/Database/HSQL Added Files: Types.hs Log Message: Add cabalized version of HSQL --- NEW FILE: Types.hs --- -- #hide module Database.HSQL.Types where import Control.Concurrent.MVar import Data.Dynamic import Foreign.C type FieldDef = (String, SqlType, Bool) data SqlType = SqlChar Int -- ODBC, MySQL, PostgreSQL | SqlVarChar Int -- ODBC, MySQL, PostgreSQL | SqlLongVarChar Int -- ODBC | SqlText -- , , PostgreSQL | SqlWChar Int -- ODBC | SqlWVarChar Int -- ODBC | SqlWLongVarChar Int -- ODBC | SqlDecimal Int Int -- ODBC | SqlNumeric Int Int -- ODBC, MySQL, PostgreSQL | SqlSmallInt -- ODBC, MySQL, PostgreSQL | SqlMedInt -- , MySQL | SqlInteger -- ODBC, MySQL, PostgreSQL | SqlReal -- ODBC, MySQL, PostgreSQL | SqlFloat -- ODBC | SqlDouble -- ODBC, MySQL, PostgreSQL | SqlBit -- ODBC, , PostgreSQL | SqlTinyInt -- ODBC, MySQL, PostgreSQL | SqlBigInt -- ODBC, MySQL, PostgreSQL | SqlBinary Int -- ODBC, , PostgreSQL | SqlVarBinary Int -- ODBC, , PostgreSQL | SqlLongVarBinary Int -- ODBC | SqlDate -- ODBC, MySQL, PostgreSQL | SqlTime -- ODBC, MySQL, PostgreSQL | SqlTimeTZ -- , , PostgreSQL | SqlAbsTime -- , , PostgreSQL | SqlRelTime -- , , PostgreSQL | SqlTimeInterval -- , , PostgreSQL | SqlAbsTimeInterval -- , , PostgreSQL | SqlTimeStamp -- ODBC, MySQL | SqlDateTime -- , MySQL | SqlDateTimeTZ -- , MySQL, PostgreSQL | SqlYear -- , MySQL | SqlSET -- , MySQL | SqlENUM -- , MySQL | SqlBLOB -- , MySQL | SqlMoney -- , , PostgreSQL | SqlINetAddr -- , , PostgreSQL | SqlCIDRAddr -- , , PostgreSQL | SqlMacAddr -- , , PostgreSQL | SqlPoint -- , , PostgreSQL | SqlLSeg -- , , PostgreSQL | SqlPath -- , , PostgreSQL | SqlBox -- , , PostgreSQL | SqlPolygon -- , , PostgreSQL | SqlLine -- , , PostgreSQL | SqlCircle -- , , PostgreSQL | SqlUnknown Int -- ^ HSQL returns @SqlUnknown tp@ for all -- columns for which it cannot determine -- the right type. The @tp@ here is the -- internal type code returned from the -- backend library deriving (Eq, Show) data SqlError = SqlError { seState :: String , seNativeError :: Int , seErrorMsg :: String } | SqlNoData | SqlInvalidHandle | SqlStillExecuting | SqlNeedData | SqlBadTypeCast { seFieldName :: String , seFieldType :: SqlType } | SqlFetchNull { seFieldName :: String } | SqlUnknownField { seFieldName :: String } | SqlUnsupportedOperation | SqlClosedHandle #ifdef __GLASGOW_HASKELL__ deriving Typeable #endif sqlErrorTc :: TyCon sqlErrorTc = mkTyCon "Database.HSQL.SqlError" #ifndef __GLASGOW_HASKELL__ instance Typeable SqlError where typeOf _ = mkAppTy sqlErrorTc [] #endif instance Show SqlError where showsPrec _ (SqlError{seErrorMsg=msg}) = showString msg showsPrec _ SqlNoData = showString "No data" showsPrec _ SqlInvalidHandle = showString "Invalid handle" showsPrec _ SqlStillExecuting = showString "Stlll executing" showsPrec _ SqlNeedData = showString "Need data" showsPrec _ (SqlBadTypeCast name tp) = showString ("The type of " ++ name ++ " field can't be converted to " ++ show tp ++ " type") showsPrec _ (SqlFetchNull name) = showString ("The value of " ++ name ++ " field is null") showsPrec _ (SqlUnknownField name) = showString ("Unknown field name: " ++ name) showsPrec _ SqlUnsupportedOperation = showString "Unsupported operation" showsPrec _ SqlClosedHandle = showString "The referenced handle is already closed" -- | A 'Connection' type represents a connection to a database, through which you can operate on the it. -- In order to create the connection you need to use the @connect@ function from the module for -- your prefered backend. data Connection = Connection { connDisconnect :: IO () , connExecute :: String -> IO () , connQuery :: String -> IO Statement , connTables :: IO [String] , connDescribe :: String -> IO [FieldDef] , connBeginTransaction :: IO () , connCommitTransaction :: IO () , connRollbackTransaction :: IO () , connClosed :: MVar Bool } -- | The 'Statement' type represents a result from the execution of given SQL query. data Statement = Statement { stmtConn :: Connection , stmtClose :: IO () , stmtFetch :: IO Bool , stmtGetCol :: forall a . Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a) , stmtFields :: [FieldDef] , stmtClosed :: MVar Bool } class SqlBind a where -- This allows for faster conversion for eq. integral numeric types, etc. -- Default version uses fromSqlValue. fromNonNullSqlCStringLen :: SqlType -> CString -> Int -> IO (Maybe a) fromNonNullSqlCStringLen sqlType cstr cstrLen = do str <- peekCStringLen (cstr, cstrLen) return (fromSqlValue sqlType str) fromSqlValue :: SqlType -> String -> Maybe a toSqlValue :: a -> String |
|
From: <kr_...@us...> - 2005-02-01 13:04:20
|
Update of /cvsroot/htoolkit/HSQL/HSQL/Database In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26145/HSQL/Database Added Files: HSQL.hsc Log Message: Add cabalized version of HSQL --- NEW FILE: HSQL.hsc --- ----------------------------------------------------------------------------------------- {-| Module : Database.HSQL.ODBC Copyright : (c) Krasimir Angelov 2003 License : BSD-style Maintainer : ka2...@ya... Stability : provisional Portability : portable The module provides an abstract database interface -} ----------------------------------------------------------------------------------------- module Database.HSQL ( -- * Connect\/Disconnect Connection , disconnect -- :: Connection -> IO () -- * Command Execution Functions -- | Once a connection to a database has been successfully established, -- the functions described here are used to perform SQL queries and commands. , execute -- :: Connection -> String -> IO () , Statement , query -- :: Connection -> String -> IO Statement , closeStatement -- :: Statement -> IO () , fetch -- :: Statement -> IO Bool -- * Retrieving Statement values and types , FieldDef, SqlType(..), SqlBind, toSqlValue , getFieldValueMB -- :: SqlBind a => Statement -> String -> IO (Maybe a) , getFieldValue -- :: SqlBind a => Statement -> String -> IO a , getFieldValue' -- :: SqlBind a => Statement -> String -> a -> IO a , getFieldValueType -- :: Statement -> String -> (SqlType, Bool) , getFieldsTypes -- :: Statement -> [(String, SqlType, Bool)] -- * Transactions , inTransaction -- :: Connection -> (Connection -> IO a) -> IO a -- * SQL Exceptions handling , SqlError(..) , catchSql -- :: IO a -> (SqlError -> IO a) -> IO a , handleSql -- :: (SqlError -> IO a) -> IO a -> IO a , sqlExceptions -- :: Exception -> Maybe SqlError -- * Utilities , forEachRow -- :: (Statement -> s -> IO s) -- ^ an action , forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO () , collectRows -- :: (Statement -> IO a) -> Statement -> IO [a] -- * Metadata , tables -- :: Connection -> IO [String] , describe -- :: Connection -> String -> IO [FieldDef] -- * Extra types , Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..) ) where import Prelude hiding (catch) import Foreign import Foreign.C import Data.Int import Data.Char import Data.Dynamic import System.Time import System.IO.Unsafe(unsafePerformIO) import Control.Monad(when,unless,mplus) import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..), finally, catch, throwIO) import Control.Concurrent.MVar import Text.ParserCombinators.ReadP import Text.Read import Text.Read.Lex import Numeric import Database.HSQL.Types #include <time.h> ----------------------------------------------------------------------------------------- -- routines for exception handling ----------------------------------------------------------------------------------------- catchSql :: IO a -> (SqlError -> IO a) -> IO a catchSql = catchDyn handleSql :: (SqlError -> IO a) -> IO a -> IO a handleSql h f = catchDyn f h sqlExceptions :: Exception -> Maybe SqlError sqlExceptions e = dynExceptions e >>= fromDynamic checkHandle :: MVar Bool -> IO a -> IO a checkHandle ref action = withMVar ref (\closed -> when closed (throwDyn SqlClosedHandle) >> action) closeHandle :: MVar Bool -> IO () -> IO () closeHandle ref action = modifyMVar_ ref (\closed -> unless closed action >> return True) ----------------------------------------------------------------------------------------- -- Operations on the connection ----------------------------------------------------------------------------------------- -- | Closes the connection. Performing 'disconnect' on a connection that has already been -- closed has no effect. All other operations on a closed connection will fail. disconnect :: Connection -> IO () disconnect conn = closeHandle (connClosed conn) (connDisconnect conn) -- | Submits a command to the database. execute :: Connection -- ^ the database connection -> String -- ^ the text of SQL command -> IO () execute conn query = checkHandle (connClosed conn) (connExecute conn query) -- | Executes a query and returns a result set query :: Connection -- ^ the database connection -> String -- ^ the text of SQL query -> IO Statement -- ^ the associated statement. Must be closed with -- the 'closeStatement' function query conn query = checkHandle (connClosed conn) (connQuery conn query) -- | List all tables in the database. tables :: Connection -- ^ Database connection -> IO [String] -- ^ The names of all tables in the database. tables conn = checkHandle (connClosed conn) (connTables conn) -- | List all columns in a table along with their types and @nullable@ flags describe :: Connection -- ^ Database connection -> String -- ^ Name of a database table -> IO [FieldDef] -- ^ The list of fields in the table describe conn table = checkHandle (connClosed conn) (connDescribe conn table) ----------------------------------------------------------------------------------------- -- transactions ----------------------------------------------------------------------------------------- -- | The 'inTransaction' function executes the specified action in transaction mode. -- If the action completes successfully then the transaction will be commited. -- If the action completes with an exception then the transaction will be rolled back -- and the exception will be throw again. inTransaction :: Connection -> (Connection -> IO a) -- ^ an action -> IO a -- ^ the returned value is the result returned from action inTransaction conn action = do checkHandle (connClosed conn) (connBeginTransaction conn) r <- catch (action conn) (\err -> do checkHandle (connClosed conn) (connRollbackTransaction conn) throwIO err) checkHandle (connClosed conn) (connCommitTransaction conn) return r ----------------------------------------------------------------------------------------- -- Operations on the statements ----------------------------------------------------------------------------------------- -- | 'fetch' fetches the next rowset of data from the result set. -- The values from columns can be retrieved with 'getFieldValue' function. fetch :: Statement -> IO Bool fetch stmt = checkHandle (stmtClosed stmt) (stmtFetch stmt) -- | 'closeStatement' stops processing associated with a specific statement, closes any open cursors -- associated with the statement, discards pending results, and frees all resources associated with -- the statement. Performing 'closeStatement' on a statement that has already been -- closed has no effect. All other operations on a closed statement will fail. closeStatement :: Statement -> IO () closeStatement stmt = closeHandle (stmtClosed stmt) (stmtClose stmt) -- | Returns the type and the @nullable@ flag for field with specified name getFieldValueType :: Statement -> String -> (SqlType, Bool) getFieldValueType stmt name = (sqlType, nullable) where (sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0 -- | Returns the list of fields with their types and @nullable@ flags getFieldsTypes :: Statement -> [(String, SqlType, Bool)] getFieldsTypes stmt = stmtFields stmt findFieldInfo :: String -> [FieldDef] -> Int -> (SqlType,Bool,Int) findFieldInfo name [] colNumber = throwDyn (SqlUnknownField name) findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber | name == name' = (sqlType,nullable,colNumber) | otherwise = findFieldInfo name fields $! (colNumber+1) ----------------------------------------------------------------------------------------- -- binding ----------------------------------------------------------------------------------------- foreign import ccall "stdlib.h atoi" c_atoi :: CString -> IO Int #ifdef mingw32_TARGET_OS foreign import ccall "stdlib.h _atoi64" c_atoi64 :: CString -> IO Int64 #else foreign import ccall "stdlib.h strtoll" c_strtoll :: CString -> Ptr CString -> Int -> IO Int64 #endif instance SqlBind Int where fromNonNullSqlCStringLen sqlType cstr cstrLen = do if sqlType==SqlInteger || sqlType==SqlMedInt || sqlType==SqlTinyInt || sqlType==SqlSmallInt || sqlType==SqlBigInt then do val <- c_atoi cstr return (Just val) else return Nothing fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlMedInt s = Just (read s) fromSqlValue SqlTinyInt s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) fromSqlValue SqlBigInt s = Just (read s) fromSqlValue SqlDouble s = Just (truncate (read s :: Double)) fromSqlValue SqlText s = Just (read s) fromSqlValue _ _ = Nothing toSqlValue s = show s instance SqlBind Int64 where fromNonNullSqlCStringLen sqlType cstr cstrLen = do if sqlType==SqlInteger || sqlType==SqlMedInt || sqlType==SqlTinyInt || sqlType==SqlSmallInt || sqlType==SqlBigInt then do #ifdef mingw32_TARGET_OS val <- c_atoi64 cstr #else val <- c_strtoll cstr nullPtr 10 #endif return (Just val) else return Nothing fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlMedInt s = Just (read s) fromSqlValue SqlTinyInt s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) fromSqlValue SqlBigInt s = Just (read s) fromSqlValue SqlDouble s = Just (truncate (read s :: Double)) fromSqlValue SqlText s = Just (read s) fromSqlValue _ s = Nothing toSqlValue val = show val instance SqlBind Integer where fromSqlValue SqlInteger s = Just (read s) fromSqlValue SqlMedInt s = Just (read s) fromSqlValue SqlTinyInt s = Just (read s) fromSqlValue SqlSmallInt s = Just (read s) fromSqlValue SqlBigInt s = Just (read s) fromSqlValue SqlDouble s = Just (truncate (read s :: Double)) fromSqlValue SqlText s = Just (read s) fromSqlValue _ _ = Nothing toSqlValue s = show s instance SqlBind String where fromSqlValue _ = Just toSqlValue s = '\'' : foldr mapChar "'" s where mapChar '\\' s = '\\':'\\':s mapChar '\'' s = '\\':'\'':s mapChar '\n' s = '\\':'n' :s mapChar '\r' s = '\\':'r' :s mapChar '\t' s = '\\':'t' :s mapChar '\NUL' s = '\\':'0' :s mapChar c s = c :s instance SqlBind Bool where fromSqlValue SqlBit s = Just (s == "t") fromSqlValue _ _ = Nothing toSqlValue True = "'t'" toSqlValue False = "'f'" instance SqlBind Double where fromSqlValue (SqlDecimal _ _) s = Just (read s) fromSqlValue (SqlNumeric _ _) s = Just (read s) fromSqlValue SqlDouble s = Just (read s) fromSqlValue SqlReal s = Just (read s) fromSqlValue SqlFloat s = Just (read s) fromSqlValue SqlText s = Just (read s) fromSqlValue _ _ = Nothing toSqlValue d = show d mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime mkClockTime year mon mday hour min sec tz = unsafePerformIO $ do allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt) (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt) (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt) (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt) (#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt) (#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt) (#poke struct tm,tm_isdst) p_tm (-1 :: CInt) t <- mktime p_tm #if __GLASGOW_HASKELL__ >= 603 return (TOD (fromIntegral (fromEnum t) + fromIntegral (tz-currTZ)) 0) #else return (TOD (fromIntegral t + fromIntegral (tz-currTZ)) 0) #endif foreign import ccall unsafe mktime :: Ptr () -> IO CTime {-# NOINLINE currTZ #-} currTZ :: Int currTZ = ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime)) -- Hack parseTZ :: ReadP Int parseTZ = (char '+' >> readDecP) `mplus` (char '-' >> fmap negate readDecP) f_read :: ReadP a -> String -> Maybe a f_read f s = case readP_to_S f s of {[(x,_)] -> Just x} readHMS :: ReadP (Int, Int, Int) readHMS = do hour <- readDecP char ':' minutes <- readDecP char ':' seconds <- readDecP return (hour, minutes, seconds) readYMD :: ReadP (Int, Int, Int) readYMD = do year <- readDecP char '-' month <- readDecP char '-' day <- readDecP return (year, month, day) readDateTime :: ReadP (Int, Int, Int, Int, Int, Int) readDateTime = do (year, month, day) <- readYMD skipSpaces (hour, minutes, seconds) <- readHMS return (year, month, day, hour, minutes, seconds) instance SqlBind ClockTime where fromSqlValue SqlTimeTZ s = f_read getTimeTZ s where getTimeTZ :: ReadP ClockTime getTimeTZ = do (hour, minutes, seconds) <- readHMS (char '.' >> readDecP) `mplus` (return 0) tz <- parseTZ return (mkClockTime 1970 1 1 hour minutes seconds (tz*3600)) fromSqlValue SqlTime s = f_read getTime s where getTime :: ReadP ClockTime getTime = do (hour, minutes, seconds) <- readHMS return (mkClockTime 1970 1 1 hour minutes seconds currTZ) fromSqlValue SqlDate s = f_read getDate s where getDate :: ReadP ClockTime getDate = do (year, month, day) <- readYMD return (mkClockTime year month day 0 0 0 currTZ) fromSqlValue SqlDateTimeTZ s = f_read getDateTimeTZ s where getDateTimeTZ :: ReadP ClockTime getDateTimeTZ = do (year, month, day, hour, minutes, seconds) <- readDateTime char '.' >> readDecP -- ) `mplus` (return 0) tz <- parseTZ return (mkClockTime year month day hour minutes seconds (tz*3600)) -- The only driver which seems to report the type as SqlTimeStamp seems -- to be the MySQL driver. MySQL (at least 4.1) uses the same format for datetime and -- timestamp columns. -- Allow SqlText to support SQLite, which reports everything as SqlText fromSqlValue t s | t == SqlDateTime || t == SqlTimeStamp || t == SqlText = f_read getDateTime s where getDateTime :: ReadP ClockTime getDateTime = do (year, month, day, hour, minutes, seconds) <- readDateTime return (mkClockTime year month day hour minutes seconds currTZ) fromSqlValue _ _ = Nothing toSqlValue ct = '\'' : (shows (ctYear t) . score . shows (ctMonth t) . score . shows (ctDay t) . space . shows (ctHour t) . colon . shows (ctMin t) . colon . shows (ctSec t)) "'" where t = toUTCTime ct score = showChar '-' space = showChar ' ' colon = showChar ':' data Point = Point Double Double deriving (Eq, Show) data Line = Line Point Point deriving (Eq, Show) data Path = OpenPath [Point] | ClosedPath [Point] deriving (Eq, Show) data Box = Box Double Double Double Double deriving (Eq, Show) data Circle = Circle Point Double deriving (Eq, Show) data Polygon = Polygon [Point] deriving (Eq, Show) instance SqlBind Point where fromSqlValue SqlPoint s = case read s of (x,y) -> Just (Point x y) fromSqlValue _ _ = Nothing toSqlValue (Point x y) = '\'' : shows (x,y) "'" instance SqlBind Line where fromSqlValue SqlLSeg s = case read s of [(x1,y1),(x2,y2)] -> Just (Line (Point x1 y1) (Point x2 y2)) fromSqlValue _ _ = Nothing toSqlValue (Line (Point x1 y1) (Point x2 y2)) = '\'' : shows [(x1,y1),(x2,y2)] "'" instance SqlBind Path where fromSqlValue SqlPath ('(':s) = case read ("["++init s++"]") of -- closed path ps -> Just (ClosedPath (map (\(x,y) -> Point x y) ps)) fromSqlValue SqlPath s = case read s of -- closed path -- open path ps -> Just (OpenPath (map (\(x,y) -> Point x y) ps)) fromSqlValue SqlLSeg s = case read s of [(x1,y1),(x2,y2)] -> Just (OpenPath [(Point x1 y1), (Point x2 y2)]) fromSqlValue SqlPoint s = case read s of (x,y) -> Just (ClosedPath [Point x y]) fromSqlValue _ _ = Nothing toSqlValue (OpenPath ps) = '\'' : shows ps "'" toSqlValue (ClosedPath ps) = "'(" ++ init (tail (show ps)) ++ "')" instance SqlBind Box where fromSqlValue SqlBox s = case read ("("++s++")") of ((x1,y1),(x2,y2)) -> Just (Box x1 y1 x2 y2) fromSqlValue _ _ = Nothing toSqlValue (Box x1 y1 x2 y2) = '\'' : shows ((x1,y1),(x2,y2)) "'" instance SqlBind Polygon where fromSqlValue SqlPolygon s = case read ("["++init (tail s)++"]") of ps -> Just (Polygon (map (\(x,y) -> Point x y) ps)) fromSqlValue _ _ = Nothing toSqlValue (Polygon ps) = "'(" ++ init (tail (show ps)) ++ "')" instance SqlBind Circle where fromSqlValue SqlCircle s = case read ("("++init (tail s)++")") of ((x,y),r) -> Just (Circle (Point x y) r) fromSqlValue _ _ = Nothing toSqlValue (Circle (Point x y) r) = "'<" ++ show (x,y) ++ "," ++ show r ++ "'>" data INetAddr = INetAddr Int Int Int Int Int deriving (Eq,Show) instance SqlBind INetAddr where fromSqlValue t s | t == SqlINetAddr || t == SqlCIDRAddr = case readNum s of (x1,s) -> case readNum s of (x2,s) -> case readNum s of (x3,s) -> case readNum s of (x4,s) -> case readNum s of (mask,_) -> Just (INetAddr x1 x2 x3 x4 mask) | otherwise = Nothing where readNum s = case readDec s of [(x,'.':s)] -> (x,s) [(x,'/':s)] -> (x,s) [(x,"")] -> (x,"") _ -> (0,"") toSqlValue (INetAddr x1 x2 x3 x4 mask) = '\'' : (shows x1 . dot . shows x2. dot . shows x3 . dot . shows x4 . slash . shows mask) "'" where dot = showChar '.' slash = showChar '/' data MacAddr = MacAddr Int Int Int Int Int Int deriving (Eq,Show) instance SqlBind MacAddr where fromSqlValue SqlMacAddr s = case readHex s of [(x1,':':s)] -> case readHex s of [(x2,':':s)] -> case readHex s of [(x3,':':s)] -> case readHex s of [(x4,':':s)] -> case readHex s of [(x5,':':s)] -> case readHex s of [(x6,_)] -> Just (MacAddr x1 x2 x3 x4 x5 x6) fromSqlValue _ _ = Nothing toSqlValue (MacAddr x1 x2 x3 x4 x5 x6) = '\'' : (showHex x1 . colon . showHex x2 . colon . showHex x3 . colon . showHex x4 . colon . showHex x5 . colon . showHex x6) "'" where colon = showChar ':' showHex = showIntAtBase 16 intToDigit -- | Retrieves the value of field with the specified name. -- The returned value is Nothing if the field value is @null@. getFieldValueMB :: SqlBind a => Statement -> String -- ^ Field name -> IO (Maybe a) -- ^ Field value or Nothing getFieldValueMB stmt name = checkHandle (stmtClosed stmt) $ stmtGetCol stmt colNumber (name,sqlType,nullable) fromCStr where (sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0 fromCStr t c l = do m <- fromNonNullSqlCStringLen t c l case m of Just _ -> return m Nothing -> do str <- peekCStringLen (c, l) return (fromSqlValue t str) -- | Retrieves the value of field with the specified name. -- If the field value is @null@ then the function will throw 'SqlFetchNull' exception. getFieldValue :: SqlBind a => Statement -> String -- ^ Field name -> IO a -- ^ Field value getFieldValue stmt name = do mb_v <- getFieldValueMB stmt name case mb_v of Nothing -> throwDyn (SqlFetchNull name) Just a -> return a -- | Retrieves the value of field with the specified name. -- If the field value is @null@ then the function will return the default value. getFieldValue' :: SqlBind a => Statement -> String -- ^ Field name -> a -- ^ Default field value -> IO a -- ^ Field value getFieldValue' stmt name def = do mb_v <- getFieldValueMB stmt name return (case mb_v of { Nothing -> def; Just a -> a }) ----------------------------------------------------------------------------------------- -- helpers ----------------------------------------------------------------------------------------- -- | The 'forEachRow' function iterates through the result set in 'Statement' and -- executes the given action for each row in the set. The function closes the 'Statement' -- after the last row processing or if the given action raises an exception. forEachRow :: (Statement -> s -> IO s) -- ^ an action -> Statement -- ^ the statement -> s -- ^ initial state -> IO s -- ^ final state forEachRow f stmt s = loop s `finally` closeStatement stmt where loop s = do success <- fetch stmt if success then f stmt s >>= loop else return s -- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't provide state. -- The function closes the 'Statement' after the last row processing or if the given -- action raises an exception. forEachRow' :: (Statement -> IO ()) -> Statement -> IO () forEachRow' f stmt = loop `finally` closeStatement stmt where loop = do success <- fetch stmt when success (f stmt >> loop) -- | The 'collectRows' function iterates through the result set in 'Statement' and -- executes the given action for each row in the set. The values returned from action -- are collected and returned as list. The function closes the 'Statement' after the -- last row processing or if the given action raises an exception. collectRows :: (Statement -> IO a) -> Statement -> IO [a] collectRows f stmt = loop `finally` closeStatement stmt where loop = do success <- fetch stmt if success then do x <- f stmt xs <- loop return (x:xs) else return [] |
|
From: <kr_...@us...> - 2005-02-01 13:04:20
|
Update of /cvsroot/htoolkit/HSQL/ODBC In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26145/ODBC Added Files: ODBC.cabal Setup.lhs Log Message: Add cabalized version of HSQL --- NEW FILE: ODBC.cabal --- name: hsql-odbc version: 1.5 license: BSD3 author: Krasimir Angelov <ka2...@ya...> category: Database description: ODBC driver for HSQL. exposed-modules:Database.HSQL.ODBC build-depends: base, hsql extensions: ForeignFunctionInterface, CPP cc-options: -IDatabase/HSQL c-sources: Database/HSQL/HsODBC.c --- NEW FILE: Setup.lhs --- #! runghc \begin{code} import Distribution.Simple import Distribution.Setup import Distribution.PackageDescription import System.Info main = defaultMainWithHooks defaultUserHooks{preConf=configure} where configure :: [String] -> ConfigFlags -> IO HookedBuildInfo configure args flags = do let binfo | os == "mingw32" = emptyBuildInfo{extraLibs=["odbc32"], ccOptions=["-DMSSQL_ODBC", "-Dmingw32_HOST_OS"]} | otherwise = emptyBuildInfo{extraLibs=["odbc"]} hbi = (Just binfo,[]) writeHookedBuildInfo "ODBC.buildinfo" hbi return hbi \end{code} |
|
From: <kr_...@us...> - 2005-02-01 13:04:19
|
Update of /cvsroot/htoolkit/HSQL/SQLite In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26145/SQLite Added Files: SQLite.cabal Setup.lhs Log Message: Add cabalized version of HSQL --- NEW FILE: SQLite.cabal --- name: hsql-sqlite version: 1.5 license: BSD3 author: Krasimir Angelov <ka2...@ya...> category: Database description: SQLite driver for HSQL. exposed-modules:Database.HSQL.SQLite build-depends: base, hsql extensions: ForeignFunctionInterface, CPP extra-libs: sqlite --- NEW FILE: Setup.lhs --- #! runghc \begin{code} import Distribution.PackageDescription import Distribution.Setup import Distribution.Simple import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Utils(rawSystemVerbose) import System.Info import System.Exit import System.Directory import Control.Monad(when) import Control.Exception(try) main = defaultMainWithHooks defaultUserHooks{preConf=preConf, postConf=postConf} where preConf :: [String] -> ConfigFlags -> IO HookedBuildInfo preConf args flags = do try (removeFile "SQLite.buildinfo") return emptyHookedBuildInfo postConf :: [String] -> LocalBuildInfo -> IO ExitCode postConf args localbuildinfo = do testCompileRes <- testForSqlite localbuildinfo 0 case testCompileRes of ExitSuccess -> do message "sqlite library and headers are found" return testCompileRes ExitFailure n -> do message "sqlite library or headers aren't found" message "The package will not be build" let hbi = (Just emptyBuildInfo{buildable=False},[]) writeHookedBuildInfo "SQLite.buildinfo" hbi return testCompileRes \end{code} \begin{code} testForSqlite :: LocalBuildInfo -> Int -> IO ExitCode testForSqlite lbi verbose = do -- create program when (verbose > 0) $ do putStrLn "Test whether compile (test.hs):" putStrLn testProgram writeFile "test.hs" testProgram -- try to compile it let ghcPath = compilerPath (compiler lbi) let ghcArgs = ["test.hs", "-lsqlite", "--make", "-ffi", "-o", "test.bin"] res <- rawSystemVerbose verbose ghcPath ghcArgs try (removeFile "test.hs") try (removeFile "test.hi") try (removeFile "test.o") try (removeFile "test.bin") return res where testProgram = "import Foreign\n" ++ "import Foreign.C\n" ++ "foreign import ccall \"sqlite.h sqlite_open\" sqlite_open :: CString -> CInt -> Ptr CString -> IO (Ptr ())\n"++ "main = return ()" message :: String -> IO () message s = putStrLn $ "configure: " ++ s \end{code} |
|
From: <kr_...@us...> - 2005-02-01 13:04:19
|
Update of /cvsroot/htoolkit/HSQL/ODBC/Database/HSQL In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv26145/ODBC/Database/HSQL Added Files: HsODBC.c HsODBC.h ODBC.hsc Log Message: Add cabalized version of HSQL --- NEW FILE: HsODBC.c --- #include "HsODBC.h" #if defined(mingw32_HOST_OS) // Under Windows SQLFreeEnv function has stdcall calling convention // while in Haskell functions represented with FunPtr must be always // with ccall convention. For that reason we need to redirect calling // to this function. void my_sqlFreeEnv(HENV hEnv) { SQLFreeEnv(hEnv); } #endif --- NEW FILE: HsODBC.h --- #ifndef HsODBC #define HsODBC #ifdef mingw32_HOST_OS #include <windows.h> #endif #include <sqlext.h> #include <sqlucode.h> #define FIELD_NAME_LENGTH 255 typedef struct { HSTMT hSTMT; SQLUSMALLINT fieldsCount; SQLCHAR fieldName[FIELD_NAME_LENGTH]; SQLSMALLINT NameLength; SQLSMALLINT DataType; SQLULEN ColumnSize; SQLSMALLINT DecimalDigits; SQLSMALLINT Nullable; } FIELD; #ifdef mingw32_HOST_OS void my_sqlFreeEnv(HENV hEnv); #endif #endif --- NEW FILE: ODBC.hsc --- ----------------------------------------------------------------------------------------- {-| Module : Database.HSQL.ODBC Copyright : (c) Krasimir Angelov 2003 License : BSD-style Maintainer : ka2...@ya... Stability : provisional Portability : portable The module provides interface to ODBC -} ----------------------------------------------------------------------------------------- module Database.HSQL.ODBC(connect, driverConnect, module Database.HSQL) where import Database.HSQL import Database.HSQL.Types import Data.Word(Word32, Word16) import Data.Int(Int32, Int16) import Data.Maybe import Foreign import Foreign.C import Control.Monad(unless) import Control.Exception(throwDyn) import Control.Concurrent.MVar import System.IO.Unsafe import System.Time #ifdef ODBC_DEBUG import Debug.Trace #endif #include <time.h> #include <HsODBC.h> type SQLHANDLE = Ptr () type HENV = SQLHANDLE type HDBC = SQLHANDLE type HSTMT = SQLHANDLE type HENVRef = ForeignPtr () type SQLSMALLINT = #type SQLSMALLINT type SQLUSMALLINT = #type SQLUSMALLINT type SQLINTEGER = #type SQLINTEGER type SQLUINTEGER = #type SQLUINTEGER type SQLRETURN = SQLSMALLINT type SQLLEN = SQLINTEGER type SQLULEN = SQLINTEGER #ifdef mingw32_HOST_OS #let CALLCONV = "stdcall" #else #let CALLCONV = "ccall" #endif foreign import #{CALLCONV} "HsODBC.h SQLAllocEnv" sqlAllocEnv :: Ptr HENV -> IO SQLRETURN #ifdef mingw32_HOST_OS foreign import ccall "HsODBC.h &my_sqlFreeEnv" sqlFreeEnv_p :: FunPtr (HENV -> IO ()) #else foreign import ccall "HsODBC.h &SQLFreeEnv" sqlFreeEnv_p :: FunPtr (HENV -> IO ()) #endif foreign import #{CALLCONV} "HsODBC.h SQLAllocConnect" sqlAllocConnect :: HENV -> Ptr HDBC -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLFreeConnect" sqlFreeConnect:: HDBC -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLConnect" sqlConnect :: HDBC -> CString -> Int -> CString -> Int -> CString -> Int -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLDriverConnect" sqlDriverConnect :: HDBC -> Ptr () -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> SQLUSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLDisconnect" sqlDisconnect :: HDBC -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLAllocStmt" sqlAllocStmt :: HDBC -> Ptr HSTMT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLFreeStmt" sqlFreeStmt :: HSTMT -> SQLUSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLNumResultCols" sqlNumResultCols :: HSTMT -> Ptr SQLUSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLDescribeCol" sqlDescribeCol :: HSTMT -> SQLUSMALLINT -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> Ptr SQLULEN -> Ptr SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLBindCol" sqlBindCol :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr a -> SQLLEN -> Ptr SQLINTEGER -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLFetch" sqlFetch :: HSTMT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLGetDiagRec" sqlGetDiagRec :: SQLSMALLINT -> SQLHANDLE -> SQLSMALLINT -> CString -> Ptr SQLINTEGER -> CString -> SQLSMALLINT -> Ptr SQLSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLExecDirect" sqlExecDirect :: HSTMT -> CString -> Int -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLSetConnectOption" sqlSetConnectOption :: HDBC -> SQLUSMALLINT -> SQLULEN -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLTransact" sqlTransact :: HENV -> HDBC -> SQLUSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLGetData" sqlGetData :: HSTMT -> SQLUSMALLINT -> SQLSMALLINT -> Ptr () -> SQLINTEGER -> Ptr SQLINTEGER -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLTables" sqlTables :: HSTMT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLColumns" sqlColumns :: HSTMT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> CString -> SQLSMALLINT -> IO SQLRETURN foreign import #{CALLCONV} "HsODBC.h SQLMoreResults" sqlMoreResults :: HSTMT -> IO SQLRETURN #if defined(MSSQL_ODBC) foreign import #{CALLCONV} "HsODBC.h SQLSetStmtAttr" sqlSetStmtAttr :: HSTMT -> SQLINTEGER -> SQLINTEGER -> SQLINTEGER -> IO SQLRETURN #endif ----------------------------------------------------------------------------------------- -- routines for handling exceptions ----------------------------------------------------------------------------------------- handleSqlResult :: SQLSMALLINT -> SQLHANDLE -> SQLRETURN -> IO () handleSqlResult handleType handle res | res == (#const SQL_SUCCESS) || res == (#const SQL_NO_DATA) = return () | res == (#const SQL_SUCCESS_WITH_INFO) = do #ifdef ODBC_DEBUG e <- getDiagRec trace (show e) $ return () #else return () #endif | res == (#const SQL_INVALID_HANDLE) = throwDyn SqlInvalidHandle | res == (#const SQL_STILL_EXECUTING) = throwDyn SqlStillExecuting | res == (#const SQL_NEED_DATA) = throwDyn SqlNeedData | res == (#const SQL_ERROR) = do e <- getDiagRec throwDyn e | otherwise = error (show res) where getDiagRec = allocaBytes 256 $ \pState -> alloca $ \pNative -> allocaBytes 256 $ \pMsg -> alloca $ \pTextLen -> do res <- sqlGetDiagRec handleType handle 1 pState pNative pMsg 256 pTextLen if res == (#const SQL_NO_DATA) then return SqlNoData else do state <- peekCString pState native <- peek pNative msg <- peekCString pMsg return (SqlError {seState=state, seNativeError=fromIntegral native, seErrorMsg=msg}) ----------------------------------------------------------------------------------------- -- keeper of HENV ----------------------------------------------------------------------------------------- {-# NOINLINE myEnvironment #-} myEnvironment :: HENVRef myEnvironment = unsafePerformIO $ alloca $ \ (phEnv :: Ptr HENV) -> do res <- sqlAllocEnv phEnv hEnv <- peek phEnv handleSqlResult 0 nullPtr res newForeignPtr sqlFreeEnv_p hEnv ----------------------------------------------------------------------------------------- -- Connect/Disconnect ----------------------------------------------------------------------------------------- -- | Makes a new connection to the ODBC data source connect :: String -- ^ Data source name -> String -- ^ User identifier -> String -- ^ Authentication string (password) -> IO Connection -- ^ the returned value represents the new connection connect server user authentication = connectHelper $ \hDBC -> withCString server $ \pServer -> withCString user $ \pUser -> withCString authentication $ \pAuthentication -> sqlConnect hDBC pServer (#const SQL_NTS) pUser (#const SQL_NTS) pAuthentication (#const SQL_NTS) -- | 'driverConnect' is an alternative to 'connect'. It supports data sources that -- require more connection information than the three arguments in 'connect' -- and data sources that are not defined in the system information. driverConnect :: String -- ^ Connection string -> IO Connection -- ^ the returned value represents the new connection driverConnect connString = connectHelper $ \hDBC -> withCString connString $ \pConnString -> allocaBytes 1024 $ \pOutConnString -> alloca $ \pLen -> sqlDriverConnect hDBC nullPtr pConnString (#const SQL_NTS) pOutConnString 1024 pLen (#const SQL_DRIVER_NOPROMPT) connectHelper :: (HDBC -> IO SQLRETURN) -> IO Connection connectHelper connectFunction = withForeignPtr myEnvironment $ \hEnv -> do hDBC <- alloca $ \ (phDBC :: Ptr HDBC) -> do res <- sqlAllocConnect hEnv phDBC handleSqlResult (#const SQL_HANDLE_ENV) hEnv res peek phDBC res <- connectFunction hDBC handleSqlResult (#const SQL_HANDLE_DBC) hDBC res refFalse <- newMVar False let connection = (Connection { connDisconnect = disconnect hDBC , connExecute = execute hDBC , connQuery = query connection hDBC , connTables = tables connection hDBC , connDescribe = describe connection hDBC , connBeginTransaction = beginTransaction myEnvironment hDBC , connCommitTransaction = commitTransaction myEnvironment hDBC , connRollbackTransaction = rollbackTransaction myEnvironment hDBC , connClosed = refFalse }) return connection where disconnect :: HDBC -> IO () disconnect hDBC = do sqlDisconnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC sqlFreeConnect hDBC >>= handleSqlResult (#const SQL_HANDLE_DBC) hDBC execute :: HDBC -> String -> IO () execute hDBC query = allocaBytes (#const sizeof(HSTMT)) $ \pStmt -> do res <- sqlAllocStmt hDBC pStmt handleSqlResult (#const SQL_HANDLE_DBC) hDBC res hSTMT <- peek pStmt withCStringLen query $ \(pQuery,len) -> do res <- sqlExecDirect hSTMT pQuery len handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res res <- sqlFreeStmt hSTMT (#const SQL_DROP) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res stmtBufferSize = 256 withStatement :: Connection -> HDBC -> (HSTMT -> IO SQLRETURN) -> IO Statement withStatement connection hDBC f = allocaBytes (#const sizeof(FIELD)) $ \pFIELD -> do res <- sqlAllocStmt hDBC ((#ptr FIELD, hSTMT) pFIELD) handleSqlResult (#const SQL_HANDLE_DBC) hDBC res hSTMT <- (#peek FIELD, hSTMT) pFIELD let handleResult res = handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res #if defined(MSSQL_ODBC) sqlSetStmtAttr hSTMT (#const SQL_ATTR_ROW_ARRAY_SIZE) 2 (#const SQL_IS_INTEGER) sqlSetStmtAttr hSTMT (#const SQL_ATTR_CURSOR_TYPE) (#const SQL_CURSOR_STATIC) (#const SQL_IS_INTEGER) #endif f hSTMT >>= handleResult fields <- moveToFirstResult hSTMT pFIELD buffer <- mallocBytes (fromIntegral stmtBufferSize) refFalse <- newMVar False let statement = Statement { stmtConn = connection , stmtClose = closeStatement hSTMT buffer , stmtFetch = fetch hSTMT , stmtGetCol = getColValue hSTMT buffer , stmtFields = fields , stmtClosed = refFalse } return statement where moveToFirstResult :: HSTMT -> Ptr a -> IO [FieldDef] moveToFirstResult hSTMT pFIELD = do res <- sqlNumResultCols hSTMT ((#ptr FIELD, fieldsCount) pFIELD) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res count <- (#peek FIELD, fieldsCount) pFIELD if count == 0 then do #if defined(MSSQL_ODBC) sqlSetStmtAttr hSTMT (#const SQL_ATTR_ROW_ARRAY_SIZE) 2 (#const SQL_IS_INTEGER) sqlSetStmtAttr hSTMT (#const SQL_ATTR_CURSOR_TYPE) (#const SQL_CURSOR_STATIC) (#const SQL_IS_INTEGER) #endif res <- sqlMoreResults hSTMT handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res if res == (#const SQL_NO_DATA) then return [] else moveToFirstResult hSTMT pFIELD else getFieldDefs hSTMT pFIELD 1 count getFieldDefs :: HSTMT -> Ptr a -> SQLUSMALLINT -> SQLUSMALLINT -> IO [FieldDef] getFieldDefs hSTMT pFIELD n count | n > count = return [] | otherwise = do res <- sqlDescribeCol hSTMT n ((#ptr FIELD, fieldName) pFIELD) (#const FIELD_NAME_LENGTH) ((#ptr FIELD, NameLength) pFIELD) ((#ptr FIELD, DataType) pFIELD) ((#ptr FIELD, ColumnSize) pFIELD) ((#ptr FIELD, DecimalDigits) pFIELD) ((#ptr FIELD, Nullable) pFIELD) handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res name <- peekCString ((#ptr FIELD, fieldName) pFIELD) dataType <- (#peek FIELD, DataType) pFIELD columnSize <- (#peek FIELD, ColumnSize) pFIELD decimalDigits <- (#peek FIELD, DecimalDigits) pFIELD (nullable :: SQLSMALLINT) <- (#peek FIELD, Nullable) pFIELD let sqlType = mkSqlType dataType columnSize decimalDigits fields <- getFieldDefs hSTMT pFIELD (n+1) count return ((name,sqlType,toBool nullable):fields) mkSqlType :: SQLSMALLINT -> SQLULEN -> SQLSMALLINT -> SqlType mkSqlType (#const SQL_CHAR) size _ = SqlChar (fromIntegral size) mkSqlType (#const SQL_VARCHAR) size _ = SqlVarChar (fromIntegral size) mkSqlType (#const SQL_LONGVARCHAR) size _ = SqlLongVarChar (fromIntegral size) mkSqlType (#const SQL_DECIMAL) size prec = SqlDecimal (fromIntegral size) (fromIntegral prec) mkSqlType (#const SQL_NUMERIC) size prec = SqlNumeric (fromIntegral size) (fromIntegral prec) mkSqlType (#const SQL_SMALLINT) _ _ = SqlSmallInt mkSqlType (#const SQL_INTEGER) _ _ = SqlInteger mkSqlType (#const SQL_REAL) _ _ = SqlReal -- From: http://msdn.microsoft.com/library/en-us/odbc/htm/odappdpr_2.asp -- "Depending on the implementation, the precision of SQL_FLOAT can be either 24 or 53: -- if it is 24, the SQL_FLOAT data type is the same as SQL_REAL; -- if it is 53, the SQL_FLOAT data type is the same as SQL_DOUBLE." mkSqlType (#const SQL_FLOAT) _ _ = SqlFloat mkSqlType (#const SQL_DOUBLE) _ _ = SqlDouble mkSqlType (#const SQL_BIT) _ _ = SqlBit mkSqlType (#const SQL_TINYINT) _ _ = SqlTinyInt mkSqlType (#const SQL_BIGINT) _ _ = SqlBigInt mkSqlType (#const SQL_BINARY) size _ = SqlBinary (fromIntegral size) mkSqlType (#const SQL_VARBINARY) size _ = SqlVarBinary (fromIntegral size) mkSqlType (#const SQL_LONGVARBINARY)size _ = SqlLongVarBinary (fromIntegral size) mkSqlType (#const SQL_DATE) _ _ = SqlDate mkSqlType (#const SQL_TIME) _ _ = SqlTime mkSqlType (#const SQL_TIMESTAMP) _ _ = SqlDateTime mkSqlType (#const SQL_WCHAR) size _ = SqlWChar (fromIntegral size) mkSqlType (#const SQL_WVARCHAR) size _ = SqlWVarChar (fromIntegral size) mkSqlType (#const SQL_WLONGVARCHAR) size _ = SqlWLongVarChar (fromIntegral size) mkSqlType tp _ _ = SqlUnknown (fromIntegral tp) query :: Connection -> HDBC -> String -> IO Statement query connection hDBC q = withStatement connection hDBC doQuery where doQuery hSTMT = withCStringLen q (uncurry (sqlExecDirect hSTMT)) beginTransaction myEnvironment hDBC = do sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_OFF) return () commitTransaction myEnvironment hDBC = withForeignPtr myEnvironment $ \hEnv -> do sqlTransact hEnv hDBC (#const SQL_COMMIT) sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON) return () rollbackTransaction myEnvironment hDBC = withForeignPtr myEnvironment $ \hEnv -> do sqlTransact hEnv hDBC (#const SQL_ROLLBACK) sqlSetConnectOption hDBC (#const SQL_AUTOCOMMIT) (#const SQL_AUTOCOMMIT_ON) return () tables :: Connection -> HDBC -> IO [String] tables connection hDBC = do stmt <- withStatement connection hDBC sqlTables' -- SQLTables returns (column names may vary): -- Column name # Type -- TABLE_NAME 3 VARCHAR collectRows (\s -> getFieldValue s 3 ("TABLE_NAME", SqlVarChar 0, False) "") stmt where sqlTables' hSTMT = sqlTables hSTMT nullPtr 0 nullPtr 0 nullPtr 0 nullPtr 0 describe :: Connection -> HDBC -> String -> IO [FieldDef] describe connection hDBC table = do stmt <- withStatement connection hDBC (sqlColumns' table) collectRows getColumnInfo stmt where sqlColumns' table hSTMT = withCStringLen table (\(pTable,len) -> sqlColumns hSTMT nullPtr 0 nullPtr 0 pTable (fromIntegral len) nullPtr 0) -- SQLColumns returns (column names may vary): -- Column name # Type -- COLUMN_NAME 4 Varchar not NULL -- DATA_TYPE 5 Smallint not NULL -- COLUMN_SIZE 7 Integer -- DECIMAL_DIGITS 9 Smallint -- NULLABLE 11 Smallint not NULL getColumnInfo stmt = do column_name <- getFieldValue stmt 4 ("COLUMN_NAME", SqlVarChar 0, False) "" (data_type::Int) <- getFieldValue stmt 5 ("DATA_TYPE", SqlSmallInt, False) 0 (column_size::Int) <- getFieldValue stmt 7 ("COLUMN_SIZE", SqlInteger, True) 0 (decimal_digits::Int) <- getFieldValue stmt 9 ("DECIMAL_DIGITS", SqlSmallInt, True) 0 (nullable::Int) <- getFieldValue stmt 11 ("NULLABLE", SqlSmallInt, False) 0 let sqlType = mkSqlType (fromIntegral data_type) (fromIntegral column_size) (fromIntegral decimal_digits) return (column_name, sqlType, toBool nullable) getFieldValue stmt colNumber fieldDef v = do mb_v <- stmtGetCol stmt (colNumber-1) fieldDef fromNonNullSqlCStringLen return (case mb_v of { Nothing -> v; Just a -> a }) fetch :: HSTMT -> IO Bool fetch hSTMT = do res <- sqlFetch hSTMT handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res return (res /= (#const SQL_NO_DATA)) getColValue :: HSTMT -> CString -> Int -> FieldDef -> (SqlType -> CString -> Int -> IO (Maybe a)) -> IO (Maybe a) getColValue hSTMT buffer colNumber (name,sqlType,nullable) f = do (res,len_or_ind) <- getData buffer (fromIntegral stmtBufferSize) if len_or_ind == (#const SQL_NULL_DATA) then return Nothing else do mb_value <- (if res == (#const SQL_SUCCESS_WITH_INFO) then getLongData len_or_ind else f sqlType buffer (fromIntegral len_or_ind)) case mb_value of Just value -> return (Just value) Nothing -> throwDyn (SqlBadTypeCast name sqlType) where getData :: CString -> SQLINTEGER -> IO (SQLRETURN, SQLINTEGER) getData buffer size = alloca $ \lenP -> do res <- sqlGetData hSTMT (fromIntegral colNumber+1) (#const SQL_C_CHAR) (castPtr buffer) size lenP handleSqlResult (#const SQL_HANDLE_STMT) hSTMT res len_or_ind <- peek lenP return (res, len_or_ind) -- gets called only when there is more data than would -- fit in the normal buffer. This call to -- SQLGetData() will fetch the rest of the data. -- We create a new buffer big enough to hold the -- old and the new data, copy the old data into -- it and put the new data in buffer after the old. getLongData len = allocaBytes (fromIntegral newBufSize) $ \newBuf -> do copyBytes newBuf buffer stmtBufferSize -- The last byte of the old data with always be null, -- so it is overwritten with the first byte of the new data. let newDataStart = newBuf `plusPtr` (stmtBufferSize - 1) newDataLen = newBufSize - (fromIntegral stmtBufferSize - 1) (res,_) <- getData newDataStart newDataLen f sqlType newBuf (fromIntegral newBufSize-1) where newBufSize = len+1 -- to allow for terminating null character closeStatement :: HSTMT -> CString -> IO () closeStatement hSTMT buffer = do free buffer sqlFreeStmt hSTMT (#const SQL_DROP) >>= handleSqlResult (#const SQL_HANDLE_STMT) hSTMT |
221 messages has been excluded from this view by a project administrator.
