HDBC-postgresql 2.3.2.4 → 2.5.0.2
raw patch · 13 files changed
Files
- CHANGELOG.md +29/−0
- Database/HDBC/PostgreSQL/Connection.hsc +16/−24
- Database/HDBC/PostgreSQL/PTypeConv.hsc +1/−1
- Database/HDBC/PostgreSQL/Statement.hsc +6/−17
- Database/HDBC/PostgreSQL/Types.hs +2/−4
- Database/HDBC/PostgreSQL/Utils.hsc +8/−19
- HDBC-postgresql.cabal +16/−15
- Setup.hs +17/−8
- hdbc-postgresql-helper.c +0/−65
- hdbc-postgresql-helper.h +0/−16
- pgtypes.h +0/−77
- pgtypes_internal.h +77/−0
- testsrc/TestSbasics.hs +14/−1
CHANGELOG.md view
@@ -1,5 +1,34 @@ # Changelog +## 2.5.0.1++* Bump time upper bound to 1.14, add round-trip test for 0-padded date.++## 2.5.0.0++* Add explicit call to `finalizeForeignPtr` on connection disconnects. Ensures disconnects happen at the moment close is call, as opposed to when the GC frees the ForeignPtr.++## 2.4.0.0++* Remove custom reference counting logic. Thanks to David Johnson.++### 2.3.2.8++* Compatiblity with Cabal 3.2++### 2.3.2.7++* Compatibility with time 1.9 & GHC 8.8+* Custom setup for cabal v2 & v3++### 2.3.2.6++* Fix postgresql header name collision++#### 2.3.2.5++* Compatibility with time 1.8, GHC 8.2.+ #### 2.3.2.4 * Compatibility with time 1.6, base 4.9, and Cabal 1.24 (GHC 8).
Database/HDBC/PostgreSQL/Connection.hsc view
@@ -1,5 +1,4 @@ -- -*- mode: haskell; -*--{-# CFILES hdbc-postgresql-helper.c #-} -- Above line for hugs {-# LANGUAGE FlexibleContexts #-} @@ -28,7 +27,7 @@ import Control.Concurrent.MVar import System.IO (stderr, hPutStrLn) import System.IO.Unsafe (unsafePerformIO)-import Control.Exception(bracket) +import Control.Exception(bracket) import Data.Convertible (Convertible) #include <libpq-fe.h>@@ -64,8 +63,7 @@ return globalConnLock else newMVar () status <- pqstatus ptr- wrappedptr <- wrapconn ptr nullPtr- fptr <- newForeignPtr pqfinishptr wrappedptr+ fptr <- newForeignPtr pqfinish ptr case status of #{const CONNECTION_OK} -> mkConn auto_transaction args (connLock,fptr) _ -> raiseError "connectPostgreSQL" status ptr@@ -74,7 +72,7 @@ -- for clone. mkConn :: Bool -> String -> Conn -> IO Impl.Connection mkConn auto_transaction args conn = withConn conn $- \cconn -> + \cconn -> do children <- newMVar [] when auto_transaction $ begin_transaction conn children protover <- pqprotocolVersion cconn@@ -141,7 +139,7 @@ fgetTables :: (Convertible SqlValue a) => Conn -> ChildList -> IO [a] fgetTables conn children =- do sth <- newSth conn children + do sth <- newSth conn children "select table_name from information_schema.tables where \ \table_schema != 'pg_catalog' AND table_schema != \ \'information_schema'"@@ -155,7 +153,7 @@ fdescribeSchemaTable :: Conn -> ChildList -> Maybe String -> String -> IO [(String, SqlColDesc)] fdescribeSchemaTable o cl maybeSchema table =- do sth <- newSth o cl + do sth <- newSth o cl ("SELECT attname, atttypid, attlen, format_type(atttypid, atttypmod), attnotnull " ++ "FROM pg_attribute, pg_class, pg_namespace ns " ++ "WHERE relname = ? and attnum > 0 and attisdropped IS FALSE " ++@@ -167,37 +165,31 @@ return $ map desccol res where desccol [attname, atttypid, attlen, formattedtype, attnotnull] =- (fromSql attname, + (fromSql attname, colDescForPGAttr (fromSql atttypid) (fromSql attlen) (fromSql formattedtype) (fromSql attnotnull == False)) desccol x = error $ "Got unexpected result from pg_attribute: " ++ show x- fdisconnect :: Conn -> ChildList -> IO ()-fdisconnect conn mchildren = - do closeAllChildren mchildren- withRawConn conn $ pqfinish+fdisconnect (lock, fptr) childList = do+ closeAllChildren childList+ modifyMVar_ lock $ \_ ->+ finalizeForeignPtr fptr foreign import ccall safe "libpq-fe.h PQconnectdb" pqconnectdb :: CString -> IO (Ptr CConn) -foreign import ccall unsafe "hdbc-postgresql-helper.h wrapobjpg"- wrapconn :: Ptr CConn -> Ptr WrappedCConn -> IO (Ptr WrappedCConn)--foreign import ccall unsafe "libpq-fe.h PQstatus"+foreign import ccall safe "libpq-fe.h PQstatus" pqstatus :: Ptr CConn -> IO #{type ConnStatusType} -foreign import ccall unsafe "hdbc-postgresql-helper.h PQfinish_app"- pqfinish :: Ptr WrappedCConn -> IO ()--foreign import ccall unsafe "hdbc-postgresql-helper.h &PQfinish_finalizer"- pqfinishptr :: FunPtr (Ptr WrappedCConn -> IO ())+foreign import ccall safe "libpq-fe.h &PQfinish"+ pqfinish :: FunPtr (Ptr CConn -> IO ()) -foreign import ccall unsafe "libpq-fe.h PQprotocolVersion"+foreign import ccall safe "libpq-fe.h PQprotocolVersion" pqprotocolVersion :: Ptr CConn -> IO CInt -foreign import ccall unsafe "libpq-fe.h PQserverVersion"+foreign import ccall safe "libpq-fe.h PQserverVersion" pqserverVersion :: Ptr CConn -> IO CInt -foreign import ccall unsafe "libpq.fe.h PQisthreadsafe"+foreign import ccall safe "libpq.fe.h PQisthreadsafe" pqisThreadSafe :: Ptr CConn -> IO Int
Database/HDBC/PostgreSQL/PTypeConv.hsc view
@@ -3,7 +3,7 @@ import Database.HDBC.ColTypes import Data.Word -#include "pgtypes.h"+#include "pgtypes_internal.h" #include <libpq-fe.h>
Database/HDBC/PostgreSQL/Statement.hsc view
@@ -1,8 +1,5 @@--- -*- mode: haskell; -*--{-# CFILES hdbc-postgresql-helper.c #-}--- Above line for hugs- module Database.HDBC.PostgreSQL.Statement where+ import Database.HDBC.Types import Database.HDBC import Database.HDBC.PostgreSQL.Types@@ -103,7 +100,7 @@ _ <- handleResultStatus cconn resptr sstate =<< pqresultStatus resptr :: IO Int return () -handleResultStatus :: (Num a, Read a) => Ptr CConn -> WrappedCStmt -> SState -> ResultStatus -> IO a+handleResultStatus :: (Num a, Read a) => Ptr CConn -> Ptr CStmt -> SState -> ResultStatus -> IO a handleResultStatus cconn resptr sstate status = case status of #{const PGRES_EMPTY_QUERY} ->@@ -126,9 +123,7 @@ numrows <- pqntuples resptr if numrows < 1 then (pqclear_raw resptr >> return 0) else do- wrappedptr <- withRawConn (dbo sstate)- (\rawconn -> wrapstmt resptr rawconn)- fresptr <- newForeignPtr pqclearptr wrappedptr+ fresptr <- newForeignPtr pqclearptr resptr _ <- swapMVar (nextrowmv sstate) 0 _ <- swapMVar (stomv sstate) (Just fresptr) return 0@@ -224,7 +219,7 @@ worker (Just sth) = ffinish sth >> return Nothing ffinish :: Stmt -> IO ()-ffinish p = withRawStmt p $ pqclear+ffinish _ = pure () foreign import ccall unsafe "libpq-fe.h PQresultStatus" pqresultStatus :: (Ptr CStmt) -> IO #{type ExecStatusType}@@ -241,17 +236,11 @@ foreign import ccall safe "libpq-fe.h PQexec" pqexec :: (Ptr CConn) -> CString -> IO (Ptr CStmt) -foreign import ccall unsafe "hdbc-postgresql-helper.h PQclear_app"- pqclear :: Ptr WrappedCStmt -> IO ()--foreign import ccall unsafe "hdbc-postgresql-helper.h &PQclear_finalizer"- pqclearptr :: FunPtr (Ptr WrappedCStmt -> IO ())+foreign import ccall unsafe "libpq-fe.h &PQclear"+ pqclearptr :: FunPtr (Ptr CStmt -> IO ()) foreign import ccall unsafe "libpq-fe.h PQclear" pqclear_raw :: Ptr CStmt -> IO ()--foreign import ccall unsafe "hdbc-postgresql-helper.h wrapobjpg"- wrapstmt :: Ptr CStmt -> Ptr WrappedCConn -> IO (Ptr WrappedCStmt) foreign import ccall unsafe "libpq-fe.h PQcmdTuples" pqcmdTuples :: Ptr CStmt -> IO CString
Database/HDBC/PostgreSQL/Types.hs view
@@ -7,11 +7,9 @@ type ConnLock = MVar () data CConn = CConn-type WrappedCConn = Ptr CConn-type Conn = (ConnLock, ForeignPtr WrappedCConn)+type Conn = (ConnLock, ForeignPtr CConn) data CStmt = CStmt-type WrappedCStmt = Ptr CStmt-type Stmt = ForeignPtr WrappedCStmt+type Stmt = ForeignPtr CStmt type ResultStatus = Word32
Database/HDBC/PostgreSQL/Utils.hsc view
@@ -1,7 +1,5 @@-{- -*- mode: haskell; -*- --}- module Database.HDBC.PostgreSQL.Utils where+ import Foreign.C.String import Foreign.ForeignPtr import Foreign.Ptr@@ -24,8 +22,6 @@ import qualified Data.ByteString.Unsafe as B #endif -#include "hdbc-postgresql-helper.h"- raiseError :: String -> Word32 -> (Ptr CConn) -> IO a raiseError msg code cconn = do rc <- pqerrorMessage cconn@@ -47,30 +43,30 @@ Ditto for statements. -} withConn :: Conn -> (Ptr CConn -> IO b) -> IO b-withConn (_lock,conn) = genericUnwrap conn+withConn (_lock,conn) = withForeignPtr conn -- Perform the associated action with the connection lock held. -- Care must be taken with the use of this as it is *not* re-entrant. Calling it--- a second time in the same thread will cause dead-lock. +-- a second time in the same thread will cause dead-lock. -- (A better approach would be to use RLock from concurrent-extra) withConnLocked :: Conn -> (Ptr CConn -> IO b) -> IO b withConnLocked c@(lock,_) a = withConn c (\cconn -> withMVar lock (\_ -> a cconn)) -withRawConn :: Conn -> (Ptr WrappedCConn -> IO b) -> IO b+withRawConn :: Conn -> (Ptr CConn -> IO b) -> IO b withRawConn (_lock,conn) = withForeignPtr conn withStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b-withStmt = genericUnwrap+withStmt = withForeignPtr -withRawStmt :: Stmt -> (Ptr WrappedCStmt -> IO b) -> IO b+withRawStmt :: Stmt -> (Ptr CStmt -> IO b) -> IO b withRawStmt = withForeignPtr withCStringArr0 :: [SqlValue] -> (Ptr CString -> IO a) -> IO a withCStringArr0 inp action = withAnyArr0 convfunc freefunc inp action where convfunc SqlNull = return nullPtr {-- convfunc y@(SqlZonedTime _) = convfunc (SqlString $ - "TIMESTAMP WITH TIME ZONE '" ++ + convfunc y@(SqlZonedTime _) = convfunc (SqlString $+ "TIMESTAMP WITH TIME ZONE '" ++ fromSql y ++ "'") -} convfunc y@(SqlUTCTime _) = convfunc (SqlZonedTime (fromSql y))@@ -110,12 +106,5 @@ -- return ptr return res -genericUnwrap :: ForeignPtr (Ptr a) -> (Ptr a -> IO b) -> IO b-genericUnwrap fptr action = withForeignPtr fptr (\structptr ->- do objptr <- #{peek finalizeonce, encapobj} structptr- action objptr- )- foreign import ccall unsafe "libpq-fe.h PQerrorMessage" pqerrorMessage :: Ptr CConn -> IO CString-
HDBC-postgresql.cabal view
@@ -1,13 +1,14 @@ Name: HDBC-postgresql-Version: 2.3.2.4+Version: 2.5.0.2 License: BSD3-Maintainer: Nicolas Wu <nicolas.wu@gmail.com>+Maintainer: Nicolas Wu <nicolas.wu@gmail.com>, David Johnson <code@dmj.io> Author: John Goerzen Copyright: Copyright (c) 2005-2011 John Goerzen license-file: LICENSE-extra-source-files: LICENSE, hdbc-postgresql-helper.h, pgtypes.h,- Makefile,- README.txt,+extra-source-files: LICENSE+ pgtypes_internal.h+ Makefile+ README.txt testsrc/TestTime.hs CHANGELOG.md homepage: http://github.com/hdbc/hdbc-postgresql@@ -17,8 +18,11 @@ Stability: Stable Build-Type: Custom-Cabal-Version: >=1.8+Cabal-Version: >=1.10 +custom-setup+ setup-depends: Cabal >= 1.8 && < 3.17, base < 5+ Flag splitBase description: Choose the new smaller, split-up package. Flag buildtests@@ -38,29 +42,28 @@ Database.HDBC.PostgreSQL.Parser, Database.HDBC.PostgreSQL.PTypeConv, Database.HDBC.PostgreSQL.ErrorCodes- Extensions: ExistentialQuantification, ForeignFunctionInterface Build-Depends: base >= 3 && < 5, mtl, HDBC>=2.2.0, parsec, utf8-string, bytestring, old-time, convertible if flag(minTime15)- Build-Depends: time >= 1.5 && < 1.7+ Build-Depends: time >= 1.5 && < 1.17 CPP-Options: -DMIN_TIME_15 else Build-Depends: time < 1.5, old-locale if impl(ghc >= 6.9) Build-Depends: base >= 4 Extra-Libraries: pq- C-Sources: hdbc-postgresql-helper.c Include-Dirs: . GHC-Options: -O2 -Wall+ Default-Language: Haskell2010 Executable runtests if flag(buildtests) Buildable: True- Build-Depends: HUnit, QuickCheck, testpack, containers,+ Build-Depends: HUnit, QuickCheck, containers, convertible, parsec, utf8-string, bytestring, old-time, base >= 4.6 && < 5.0, HDBC>=2.2.6 if flag(minTime15)- Build-Depends: time >= 1.5 && < 1.7+ Build-Depends: time >= 1.5 && < 1.17 CPP-Options: -DMIN_TIME_15 else Build-Depends: time < 1.5, old-locale@@ -82,13 +85,11 @@ TestUtils, Testbasics, Tests- C-Sources: hdbc-postgresql-helper.c include-dirs: . Extra-Libraries: pq Hs-Source-Dirs: ., testsrc- GHC-Options: -O2- Extensions: ExistentialQuantification,- ForeignFunctionInterface+ GHC-Options: -O2 -threaded+ Default-Language: Haskell2010 source-repository head type: git
Setup.hs view
@@ -1,5 +1,5 @@ #!/usr/bin/env runhaskell-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+{-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleInstances #-} import Distribution.Simple import Distribution.PackageDescription@@ -8,9 +8,13 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Verbosity+#if MIN_VERSION_Cabal(3,14,0)+import Distribution.Utils.Path+#endif import Data.Char (isSpace) import Data.List (dropWhile,reverse)+import Data.String (fromString) import Control.Monad @@ -23,7 +27,7 @@ return lbi { localPkgDescr = updatePackageDescription- (Just bi, [("runtests", bi)]) (localPkgDescr lbi)+ (Just bi, [(fromString "runtests", bi)]) (localPkgDescr lbi) } } @@ -44,9 +48,9 @@ constOrId x = liftM (fmap (\x -> (x, []))) . const x pgconfigProgram = (simpleProgram "pgconfig or pg_config") {- programFindLocation = \verbosity -> constOrId $ do- pgconfig <- findProgramLocation verbosity "pgconfig"- pg_config <- findProgramLocation verbosity "pg_config"+ programFindLocation = \verbosity searchPath -> do+ pgconfig <- findProgramOnSearchPath verbosity searchPath "pgconfig"+ pg_config <- findProgramOnSearchPath verbosity searchPath "pg_config" return (pgconfig `mplus` pg_config) } @@ -54,15 +58,20 @@ psqlBuildInfo lbi = do (pgconfigProg, _) <- requireProgram verbosity pgconfigProgram (withPrograms lbi)- let pgconfig = rawSystemProgramStdout verbosity pgconfigProg+ let pgconfig = getProgramOutput verbosity pgconfigProg incDir <- pgconfig ["--includedir"] libDir <- pgconfig ["--libdir"] return emptyBuildInfo {- extraLibDirs = [strip libDir],- includeDirs = [strip incDir]+ extraLibDirs = [toPath $ strip libDir],+ includeDirs = [toPath $ strip incDir] } where+#if MIN_VERSION_Cabal(3,14,0)+ toPath = makeSymbolicPath+#else+ toPath = id+#endif verbosity = normal -- honestly, this is a hack strip x = dropWhile isSpace $ reverse $ dropWhile isSpace $ reverse x
− hdbc-postgresql-helper.c
@@ -1,65 +0,0 @@-#include <libpq-fe.h>-#include <stdio.h>-#include <stdlib.h>-#include "hdbc-postgresql-helper.h"--/* Things can't finalize more than once. -We'd like to let people call them from the app.-Yet we'd also like to be able to have a ForeignPtr finalize them.--So, here's a little wrapper for things. */--void PQfinish_conditional_finalizer(finalizeonce *conn);--finalizeonce *wrapobjpg(void *obj, finalizeonce *parentobj) {- finalizeonce *newobj;- newobj = malloc(sizeof(finalizeonce));- if (newobj == NULL) {- fprintf(stderr, "HDBC: could not allocate wrapper!\n");- return NULL;- }- newobj->isfinalized = 0;- newobj->refcount = 1;- newobj->encapobj = obj;- newobj->parent = parentobj;- if (parentobj != NULL) - parentobj->refcount++;- return newobj;-}- -void PQfinish_app(finalizeonce *conn) {- if (conn->isfinalized)- return;- PQfinish((PGconn *) (conn->encapobj));- conn->encapobj = NULL;- conn->isfinalized = 1;-}--void PQfinish_finalizer(finalizeonce *conn) {- (conn->refcount)--;- PQfinish_conditional_finalizer(conn);-}--void PQfinish_conditional_finalizer(finalizeonce *conn) {- if (conn->refcount < 1) {- PQfinish_app(conn);- free(conn);- }-}--void PQclear_app(finalizeonce *res) {- if (res->isfinalized)- return;- PQclear((PGresult *) (res->encapobj));- res->isfinalized = 1;-}--void PQclear_finalizer(finalizeonce *res) {- PQclear_app(res);- (res->refcount)--; /* Not really important since this is never a - parent */- (res->parent->refcount)--;- PQfinish_conditional_finalizer(res->parent);- free(res);-}-
− hdbc-postgresql-helper.h
@@ -1,16 +0,0 @@-#include <libpq-fe.h>--typedef struct TAG_finalizeonce {- void *encapobj;- int refcount;- int isfinalized;- struct TAG_finalizeonce *parent;-} finalizeonce;--extern finalizeonce *wrapobjpg(void *obj, finalizeonce *parentobj);--extern void PQfinish_app(finalizeonce *conn);-extern void PQfinish_finalizer(finalizeonce *conn);--extern void PQclear_app(finalizeonce *res);-extern void PQclear_finalizer(finalizeonce *res);
− pgtypes.h
@@ -1,77 +0,0 @@-/* File: pgtypes.h- *- * Description: See "pgtypes.c"- *- * Comments: See "notice.txt" for copyright and license information.- *- */--#ifndef __PGTYPES_H__-#define __PGTYPES_H__--/* the type numbers are defined by the OID's of the types' rows */-/* in table pg_type */---#ifdef NOT_USED-#define PG_TYPE_LO ???? /* waiting for permanent type */-#endif--#define MS_ACCESS_SERIAL "int identity"-#define PG_TYPE_BOOL 16-#define PG_TYPE_BYTEA 17-#define PG_TYPE_CHAR 18-#define PG_TYPE_NAME 19-#define PG_TYPE_INT8 20-#define PG_TYPE_INT2 21-#define PG_TYPE_INT2VECTOR 22-#define PG_TYPE_INT4 23-#define PG_TYPE_REGPROC 24-#define PG_TYPE_TEXT 25-#define PG_TYPE_OID 26-#define PG_TYPE_TID 27-#define PG_TYPE_XID 28-#define PG_TYPE_CID 29-#define PG_TYPE_OIDVECTOR 30-#define PG_TYPE_SET 32-#define PG_TYPE_XML 142-#define PG_TYPE_XMLARRAY 143-#define PG_TYPE_CHAR2 409-#define PG_TYPE_CHAR4 410-#define PG_TYPE_CHAR8 411-#define PG_TYPE_POINT 600-#define PG_TYPE_LSEG 601-#define PG_TYPE_PATH 602-#define PG_TYPE_BOX 603-#define PG_TYPE_POLYGON 604-#define PG_TYPE_FILENAME 605-#define PG_TYPE_CIDR 650-#define PG_TYPE_FLOAT4 700-#define PG_TYPE_FLOAT8 701-#define PG_TYPE_ABSTIME 702-#define PG_TYPE_RELTIME 703-#define PG_TYPE_TINTERVAL 704-#define PG_TYPE_UNKNOWN 705-#define PG_TYPE_MONEY 790-#define PG_TYPE_OIDINT2 810-#define PG_TYPE_MACADDR 829-#define PG_TYPE_INET 869-#define PG_TYPE_OIDINT4 910-#define PG_TYPE_OIDNAME 911-#define PG_TYPE_TEXTARRAY 1009-#define PG_TYPE_BPCHARARRAY 1014-#define PG_TYPE_VARCHARARRAY 1015-#define PG_TYPE_BPCHAR 1042-#define PG_TYPE_VARCHAR 1043-#define PG_TYPE_DATE 1082-#define PG_TYPE_TIME 1083-#define PG_TYPE_TIMESTAMP_NO_TMZONE 1114 /* since 7.2 */-#define PG_TYPE_DATETIME 1184-#define PG_TYPE_TIME_WITH_TMZONE 1266 /* since 7.1 */-#define PG_TYPE_TIMESTAMP 1296 /* deprecated since 7.0 */-#define PG_TYPE_NUMERIC 1700-#define PG_TYPE_RECORD 2249-#define PG_TYPE_VOID 2278-#define INTERNAL_ASIS_TYPE (-9999)--#endif
+ pgtypes_internal.h view
@@ -0,0 +1,77 @@+/* File: pgtypes.h+ *+ * Description: See "pgtypes.c"+ *+ * Comments: See "notice.txt" for copyright and license information.+ *+ */++#ifndef __PGTYPES_H__+#define __PGTYPES_H__++/* the type numbers are defined by the OID's of the types' rows */+/* in table pg_type */+++#ifdef NOT_USED+#define PG_TYPE_LO ???? /* waiting for permanent type */+#endif++#define MS_ACCESS_SERIAL "int identity"+#define PG_TYPE_BOOL 16+#define PG_TYPE_BYTEA 17+#define PG_TYPE_CHAR 18+#define PG_TYPE_NAME 19+#define PG_TYPE_INT8 20+#define PG_TYPE_INT2 21+#define PG_TYPE_INT2VECTOR 22+#define PG_TYPE_INT4 23+#define PG_TYPE_REGPROC 24+#define PG_TYPE_TEXT 25+#define PG_TYPE_OID 26+#define PG_TYPE_TID 27+#define PG_TYPE_XID 28+#define PG_TYPE_CID 29+#define PG_TYPE_OIDVECTOR 30+#define PG_TYPE_SET 32+#define PG_TYPE_XML 142+#define PG_TYPE_XMLARRAY 143+#define PG_TYPE_CHAR2 409+#define PG_TYPE_CHAR4 410+#define PG_TYPE_CHAR8 411+#define PG_TYPE_POINT 600+#define PG_TYPE_LSEG 601+#define PG_TYPE_PATH 602+#define PG_TYPE_BOX 603+#define PG_TYPE_POLYGON 604+#define PG_TYPE_FILENAME 605+#define PG_TYPE_CIDR 650+#define PG_TYPE_FLOAT4 700+#define PG_TYPE_FLOAT8 701+#define PG_TYPE_ABSTIME 702+#define PG_TYPE_RELTIME 703+#define PG_TYPE_TINTERVAL 704+#define PG_TYPE_UNKNOWN 705+#define PG_TYPE_MONEY 790+#define PG_TYPE_OIDINT2 810+#define PG_TYPE_MACADDR 829+#define PG_TYPE_INET 869+#define PG_TYPE_OIDINT4 910+#define PG_TYPE_OIDNAME 911+#define PG_TYPE_TEXTARRAY 1009+#define PG_TYPE_BPCHARARRAY 1014+#define PG_TYPE_VARCHARARRAY 1015+#define PG_TYPE_BPCHAR 1042+#define PG_TYPE_VARCHAR 1043+#define PG_TYPE_DATE 1082+#define PG_TYPE_TIME 1083+#define PG_TYPE_TIMESTAMP_NO_TMZONE 1114 /* since 7.2 */+#define PG_TYPE_DATETIME 1184+#define PG_TYPE_TIME_WITH_TMZONE 1266 /* since 7.1 */+#define PG_TYPE_TIMESTAMP 1296 /* deprecated since 7.0 */+#define PG_TYPE_NUMERIC 1700+#define PG_TYPE_RECORD 2249+#define PG_TYPE_VOID 2278+#define INTERNAL_ASIS_TYPE (-9999)++#endif
testsrc/TestSbasics.hs view
@@ -1,6 +1,8 @@ module TestSbasics(tests) where import Test.HUnit+import Data.Convertible (convert) import Data.List+import Data.Time (UTCTime(UTCTime), fromGregorian) import Database.HDBC import TestUtils import System.IO@@ -153,6 +155,16 @@ ) where rows = map (\x -> [Just . show $ x]) [1..9] +testFirstCentury = dbTestCase $ \dbh ->+ do -- we use UTC to avoid Local Mean Time which the 'time' library can't handle+ runRaw dbh "SET TIMEZONE TO 'UTC';"+ select <- prepare dbh "SELECT ? :: timestamptz;"+ let time = UTCTime (fromGregorian 99 12 25) 0+ execute select [toSql (convert time :: SqlValue)]+ result <- fetchAllRows select+ assertEqual "first century year can roundtrip"+ time (fromSql $ head $ head result)+ tests = TestList [ TestLabel "openClosedb" openClosedb,@@ -167,5 +179,6 @@ TestLabel "sFetchAllRows" testsFetchAllRows, TestLabel "basicTransactions" basicTransactions, TestLabel "withTransaction" testWithTransaction,- TestLabel "dropTable" dropTable+ TestLabel "dropTable" dropTable,+ TestLabel "firstCentury" testFirstCentury ]