[Pkg-haskell-commits] r1052 - in /packages/haskell-hsql-mysql: ./ branches/ branches/upstream/ branches/upstream/current/ branches/upstream/current/Database/ branches/upstream/current/Database/HSQL/
arjan at users.alioth.debian.org
arjan at users.alioth.debian.org
Sun Feb 3 21:33:27 UTC 2008
Author: arjan
Date: Sun Feb 3 21:33:27 2008
New Revision: 1052
URL: http://svn.debian.org/wsvn/pkg-haskell/?sc=1&rev=1052
Log:
[svn-inject] Installing original source of haskell-hsql-mysql
Added:
packages/haskell-hsql-mysql/
packages/haskell-hsql-mysql/branches/
packages/haskell-hsql-mysql/branches/upstream/
packages/haskell-hsql-mysql/branches/upstream/current/
packages/haskell-hsql-mysql/branches/upstream/current/Database/
packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/
packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/HsMySQL.h (with props)
packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/MySQL.hsc (with props)
packages/haskell-hsql-mysql/branches/upstream/current/Setup.lhs (with props)
packages/haskell-hsql-mysql/branches/upstream/current/hsql-mysql.cabal (with props)
Added: packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/HsMySQL.h
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/HsMySQL.h?rev=1052&op=file
==============================================================================
--- packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/HsMySQL.h (added)
+++ packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/HsMySQL.h Sun Feb 3 21:33:27 2008
@@ -1,0 +1,16 @@
+#ifndef HsMySQL
+#define HsMySQL
+
+#ifdef mingw32_HOST_OS
+#include <windows.h>
+#endif
+
+#include <mysql.h>
+
+#ifdef CLIENT_MULTI_STATEMENTS
+#define MYSQL_DEFAULT_CONNECT_FLAGS CLIENT_MULTI_STATEMENTS
+#else
+#define MYSQL_DEFAULT_CONNECT_FLAGS 0
+#endif
+
+#endif
Propchange: packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/HsMySQL.h
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/MySQL.hsc
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/MySQL.hsc?rev=1052&op=file
==============================================================================
--- packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/MySQL.hsc (added)
+++ packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/MySQL.hsc Sun Feb 3 21:33:27 2008
@@ -1,0 +1,223 @@
+-----------------------------------------------------------------------------------------
+{-| Module : Database.HSQL.MySQL
+ Copyright : (c) Krasimir Angelov 2003
+ License : BSD-style
+
+ Maintainer : ka2_mail at yahoo.com
+ Stability : provisional
+ Portability : portable
+
+ The module provides interface to MySQL database
+-}
+-----------------------------------------------------------------------------------------
+
+module Database.HSQL.MySQL(connect, module Database.HSQL) where
+
+import Database.HSQL
+import Database.HSQL.Types
+import Data.Dynamic
+import Data.Bits
+import Data.Char
+import Foreign
+import Foreign.C
+import Control.Monad(when,unless)
+import Control.Exception (throwDyn, finally)
+import Control.Concurrent.MVar
+import System.Time
+import System.IO.Unsafe
+import Text.ParserCombinators.ReadP
+import Text.Read
+
+#include <HsMySQL.h>
+
+type MYSQL = Ptr ()
+type MYSQL_RES = Ptr ()
+type MYSQL_FIELD = Ptr ()
+type MYSQL_ROW = Ptr CString
+type MYSQL_LENGTHS = Ptr CULong
+
+#ifdef mingw32_HOST_OS
+#let CALLCONV = "stdcall"
+#else
+#let CALLCONV = "ccall"
+#endif
+
+foreign import #{CALLCONV} "HsMySQL.h mysql_init" mysql_init :: MYSQL -> IO MYSQL
+foreign import #{CALLCONV} "HsMySQL.h mysql_real_connect" mysql_real_connect :: MYSQL -> CString -> CString -> CString -> CString -> CInt -> CString -> CInt -> IO MYSQL
+foreign import #{CALLCONV} "HsMySQL.h mysql_close" mysql_close :: MYSQL -> IO ()
+foreign import #{CALLCONV} "HsMySQL.h mysql_errno" mysql_errno :: MYSQL -> IO CInt
+foreign import #{CALLCONV} "HsMySQL.h mysql_error" mysql_error :: MYSQL -> IO CString
+foreign import #{CALLCONV} "HsMySQL.h mysql_query" mysql_query :: MYSQL -> CString -> IO CInt
+foreign import #{CALLCONV} "HsMySQL.h mysql_use_result" mysql_use_result :: MYSQL -> IO MYSQL_RES
+foreign import #{CALLCONV} "HsMySQL.h mysql_fetch_field" mysql_fetch_field :: MYSQL_RES -> IO MYSQL_FIELD
+foreign import #{CALLCONV} "HsMySQL.h mysql_free_result" mysql_free_result :: MYSQL_RES -> IO ()
+foreign import #{CALLCONV} "HsMySQL.h mysql_fetch_row" mysql_fetch_row :: MYSQL_RES -> IO MYSQL_ROW
+foreign import #{CALLCONV} "HsMySQL.h mysql_fetch_lengths" mysql_fetch_lengths :: MYSQL_RES -> IO MYSQL_LENGTHS
+foreign import #{CALLCONV} "HsMySQL.h mysql_list_tables" mysql_list_tables :: MYSQL -> CString -> IO MYSQL_RES
+foreign import #{CALLCONV} "HsMySQL.h mysql_list_fields" mysql_list_fields :: MYSQL -> CString -> CString -> IO MYSQL_RES
+foreign import #{CALLCONV} "HsMySQL.h mysql_next_result" mysql_next_result :: MYSQL -> IO CInt
+
+
+
+-----------------------------------------------------------------------------------------
+-- routines for handling exceptions
+-----------------------------------------------------------------------------------------
+
+handleSqlError :: MYSQL -> IO a
+handleSqlError pMYSQL = do
+ errno <- mysql_errno pMYSQL
+ errMsg <- mysql_error pMYSQL >>= peekCString
+ throwDyn (SqlError "" (fromIntegral errno) errMsg)
+
+-----------------------------------------------------------------------------------------
+-- Connect/Disconnect
+-----------------------------------------------------------------------------------------
+
+-- | Makes a new connection to the database server.
+connect :: String -- ^ Server name
+ -> String -- ^ Database name
+ -> String -- ^ User identifier
+ -> String -- ^ Authentication string (password)
+ -> IO Connection
+connect server database user authentication = do
+ pMYSQL <- mysql_init nullPtr
+ pServer <- newCString server
+ pDatabase <- newCString database
+ pUser <- newCString user
+ pAuthentication <- newCString authentication
+ res <- mysql_real_connect pMYSQL pServer pUser pAuthentication pDatabase 0 nullPtr (#const MYSQL_DEFAULT_CONNECT_FLAGS)
+ free pServer
+ free pDatabase
+ free pUser
+ free pAuthentication
+ when (res == nullPtr) (handleSqlError pMYSQL)
+ refFalse <- newMVar False
+ let connection = Connection
+ { connDisconnect = mysql_close pMYSQL
+ , connExecute = execute pMYSQL
+ , connQuery = query connection pMYSQL
+ , connTables = tables connection pMYSQL
+ , connDescribe = describe connection pMYSQL
+ , connBeginTransaction = execute pMYSQL "begin"
+ , connCommitTransaction = execute pMYSQL "commit"
+ , connRollbackTransaction = execute pMYSQL "rollback"
+ , connClosed = refFalse
+ }
+ return connection
+ where
+ execute :: MYSQL -> String -> IO ()
+ execute pMYSQL query = do
+ res <- withCString query (mysql_query pMYSQL)
+ when (res /= 0) (handleSqlError pMYSQL)
+
+ withStatement :: Connection -> MYSQL -> MYSQL_RES -> IO Statement
+ withStatement conn pMYSQL pRes = do
+ currRow <- newMVar (nullPtr, nullPtr)
+ refFalse <- newMVar False
+ if (pRes == nullPtr)
+ then do
+ errno <- mysql_errno pMYSQL
+ when (errno /= 0) (handleSqlError pMYSQL)
+ return (Statement
+ { stmtConn = conn
+ , stmtClose = return ()
+ , stmtFetch = fetch pRes currRow
+ , stmtGetCol = getColValue currRow
+ , stmtFields = []
+ , stmtClosed = refFalse
+ })
+ else do
+ fieldDefs <- getFieldDefs pRes
+ return (Statement
+ { stmtConn = conn
+ , stmtClose = mysql_free_result pRes
+ , stmtFetch = fetch pRes currRow
+ , stmtGetCol = getColValue currRow
+ , stmtFields = fieldDefs
+ , stmtClosed = refFalse
+ })
+ where
+ getFieldDefs pRes = do
+ pField <- mysql_fetch_field pRes
+ if pField == nullPtr
+ then return []
+ else do
+ name <- (#peek MYSQL_FIELD, name) pField >>= peekCString
+ dataType <- (#peek MYSQL_FIELD, type) pField
+ columnSize <- (#peek MYSQL_FIELD, length) pField
+ flags <- (#peek MYSQL_FIELD, flags) pField
+ decimalDigits <- (#peek MYSQL_FIELD, decimals) pField
+ let sqlType = mkSqlType dataType columnSize decimalDigits
+ defs <- getFieldDefs pRes
+ return ((name,sqlType,((flags :: Int) .&. (#const NOT_NULL_FLAG)) == 0):defs)
+
+ mkSqlType :: Int -> Int -> Int -> SqlType
+ mkSqlType (#const FIELD_TYPE_STRING) size _ = SqlChar size
+ mkSqlType (#const FIELD_TYPE_VAR_STRING) size _ = SqlVarChar size
+ mkSqlType (#const FIELD_TYPE_DECIMAL) size prec = SqlNumeric size prec
+ mkSqlType (#const FIELD_TYPE_SHORT) _ _ = SqlSmallInt
+ mkSqlType (#const FIELD_TYPE_INT24) _ _ = SqlMedInt
+ mkSqlType (#const FIELD_TYPE_LONG) _ _ = SqlInteger
+ mkSqlType (#const FIELD_TYPE_FLOAT) _ _ = SqlReal
+ mkSqlType (#const FIELD_TYPE_DOUBLE) _ _ = SqlDouble
+ mkSqlType (#const FIELD_TYPE_TINY) _ _ = SqlTinyInt
+ mkSqlType (#const FIELD_TYPE_LONGLONG) _ _ = SqlBigInt
+ mkSqlType (#const FIELD_TYPE_DATE) _ _ = SqlDate
+ mkSqlType (#const FIELD_TYPE_TIME) _ _ = SqlTime
+ mkSqlType (#const FIELD_TYPE_TIMESTAMP) _ _ = SqlTimeStamp
+ mkSqlType (#const FIELD_TYPE_DATETIME) _ _ = SqlDateTime
+ mkSqlType (#const FIELD_TYPE_YEAR) _ _ = SqlYear
+ mkSqlType (#const FIELD_TYPE_BLOB) _ _ = SqlBLOB
+ mkSqlType (#const FIELD_TYPE_SET) _ _ = SqlSET
+ mkSqlType (#const FIELD_TYPE_ENUM) _ _ = SqlENUM
+ mkSqlType tp _ _ = SqlUnknown tp
+
+ query :: Connection -> MYSQL -> String -> IO Statement
+ query conn pMYSQL query = do
+ res <- withCString query (mysql_query pMYSQL)
+ when (res /= 0) (handleSqlError pMYSQL)
+ pRes <- getFirstResult pMYSQL
+ withStatement conn pMYSQL pRes
+ where
+ getFirstResult :: MYSQL -> IO MYSQL_RES
+ getFirstResult pMYSQL = do
+ pRes <- mysql_use_result pMYSQL
+ if pRes == nullPtr
+ then do
+ res <- mysql_next_result pMYSQL
+ if res == 0
+ then getFirstResult pMYSQL
+ else return nullPtr
+ else return pRes
+
+ fetch :: MYSQL_RES -> MVar (MYSQL_ROW, MYSQL_LENGTHS) -> IO Bool
+ fetch pRes currRow
+ | pRes == nullPtr = return False
+ | otherwise = modifyMVar currRow $ \(pRow, pLengths) -> do
+ pRow <- mysql_fetch_row pRes
+ pLengths <- mysql_fetch_lengths pRes
+ return ((pRow, pLengths), pRow /= nullPtr)
+
+ getColValue :: MVar (MYSQL_ROW, MYSQL_LENGTHS) -> Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a
+ getColValue currRow colNumber fieldDef f = do
+ (row, lengths) <- readMVar currRow
+ pValue <- peekElemOff row colNumber
+ len <- fmap fromIntegral (peekElemOff lengths colNumber)
+ f fieldDef pValue len
+
+ tables :: Connection -> MYSQL -> IO [String]
+ tables conn pMYSQL = do
+ pRes <- mysql_list_tables pMYSQL nullPtr
+ stmt <- withStatement conn pMYSQL pRes
+ -- SQLTables returns:
+ -- Column name # Type
+ -- Tables_in_xx 0 VARCHAR
+ collectRows (\stmt -> do
+ mb_v <- stmtGetCol stmt 0 ("Tables", SqlVarChar 0, False) fromSqlCStringLen
+ return (case mb_v of { Nothing -> ""; Just a -> a })) stmt
+
+ describe :: Connection -> MYSQL -> String -> IO [FieldDef]
+ describe conn pMYSQL table = do
+ pRes <- withCString table (\table -> mysql_list_fields pMYSQL table nullPtr)
+ stmt <- withStatement conn pMYSQL pRes
+ return (getFieldsTypes stmt)
Propchange: packages/haskell-hsql-mysql/branches/upstream/current/Database/HSQL/MySQL.hsc
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-mysql/branches/upstream/current/Setup.lhs
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-mysql/branches/upstream/current/Setup.lhs?rev=1052&op=file
==============================================================================
--- packages/haskell-hsql-mysql/branches/upstream/current/Setup.lhs (added)
+++ packages/haskell-hsql-mysql/branches/upstream/current/Setup.lhs Sun Feb 3 21:33:27 2008
@@ -1,0 +1,104 @@
+#!/usr/bin/runghc
+
+\begin{code}
+import Data.Maybe(fromMaybe)
+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 "MySQL.buildinfo")
+ return emptyHookedBuildInfo
+ postConf :: [String] -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ExitCode
+ postConf args flags _ localbuildinfo = do
+ mb_bi <- mysqlConfigBuildInfo (configVerbose flags)
+ let default_binfo | os == "mingw32" = emptyBuildInfo{extraLibs=["libmySQL"], ccOptions=["-Dmingw32_HOST_OS"]}
+ | otherwise = emptyBuildInfo{extraLibs=["mysqlclient"]}
+ writeHookedBuildInfo "MySQL.buildinfo" (Just (fromMaybe default_binfo mb_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}
+mysqlConfigBuildInfo :: Int -> IO (Maybe BuildInfo)
+mysqlConfigBuildInfo verbose = do
+ mb_mysql_config_path <- findProgram "mysql_config" Nothing
+ case mb_mysql_config_path of
+ Just mysql_config_path -> do
+ message ("configuring mysqlclient library")
+ res <- rawSystemGrabOutput verbose mysql_config_path ["--libs"]
+ let (lib_dirs,libs,ld_opts) = splitLibsFlags (words res)
+ res <- rawSystemGrabOutput verbose mysql_config_path ["--include"]
+ let (inc_dirs,cc_opts) = splitCFlags (words res)
+ let bi = emptyBuildInfo{extraLibDirs=lib_dirs, extraLibs=libs, ldOptions=ld_opts, includeDirs=inc_dirs, ccOptions=cc_opts}
+ return (Just bi)
+ Nothing -> do
+ message ("The package will be built using default settings for mysqlclient library")
+ return Nothing
+ where
+ splitLibsFlags [] = ([],[],[])
+ splitLibsFlags (arg:args) =
+ case arg of
+ ('-':'L':lib_dir) -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args
+ in (lib_dir:lib_dirs,libs,ld_opts)
+ ('-':'l':lib) -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args
+ in (lib_dirs,lib:libs,ld_opts)
+ ld_opt -> let (lib_dirs,libs,ld_opts) = splitLibsFlags args
+ in (lib_dirs,libs,ld_opt:ld_opts)
+
+ splitCFlags [] = ([],[])
+ splitCFlags (arg:args) =
+ case arg of
+ ('-':'I':inc_dir) -> let (inc_dirs,c_opts) = splitCFlags args
+ in (inc_dir:inc_dirs,c_opts)
+ c_opt -> let (inc_dirs,c_opts) = splitCFlags args
+ in (inc_dirs,c_opt:c_opts)
+
+\end{code}
Propchange: packages/haskell-hsql-mysql/branches/upstream/current/Setup.lhs
------------------------------------------------------------------------------
svn:executable =
Added: packages/haskell-hsql-mysql/branches/upstream/current/hsql-mysql.cabal
URL: http://svn.debian.org/wsvn/pkg-haskell/packages/haskell-hsql-mysql/branches/upstream/current/hsql-mysql.cabal?rev=1052&op=file
==============================================================================
--- packages/haskell-hsql-mysql/branches/upstream/current/hsql-mysql.cabal (added)
+++ packages/haskell-hsql-mysql/branches/upstream/current/hsql-mysql.cabal Sun Feb 3 21:33:27 2008
@@ -1,0 +1,11 @@
+name: hsql-mysql
+version: 1.7
+license: BSD3
+author: Krasimir Angelov <kr.angelov at gmail.com>
+category: Database
+description: MySQL driver for HSQL.
+exposed-modules: Database.HSQL.MySQL
+build-depends: base, hsql
+extensions: ForeignFunctionInterface, CPP
+cc-options: -IDatabase/HSQL
+extra-source-files: Database/HSQL/HsMySQL.h
Propchange: packages/haskell-hsql-mysql/branches/upstream/current/hsql-mysql.cabal
------------------------------------------------------------------------------
svn:executable =
More information about the Pkg-haskell-commits
mailing list