diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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). diff --git a/Database/HDBC/PostgreSQL/Connection.hsc b/Database/HDBC/PostgreSQL/Connection.hsc --- a/Database/HDBC/PostgreSQL/Connection.hsc +++ b/Database/HDBC/PostgreSQL/Connection.hsc @@ -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 @@ -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 diff --git a/Database/HDBC/PostgreSQL/PTypeConv.hsc b/Database/HDBC/PostgreSQL/PTypeConv.hsc --- a/Database/HDBC/PostgreSQL/PTypeConv.hsc +++ b/Database/HDBC/PostgreSQL/PTypeConv.hsc @@ -3,7 +3,7 @@ import Database.HDBC.ColTypes import Data.Word -#include "pgtypes.h" +#include "pgtypes_internal.h" #include diff --git a/Database/HDBC/PostgreSQL/Statement.hsc b/Database/HDBC/PostgreSQL/Statement.hsc --- a/Database/HDBC/PostgreSQL/Statement.hsc +++ b/Database/HDBC/PostgreSQL/Statement.hsc @@ -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 diff --git a/Database/HDBC/PostgreSQL/Types.hs b/Database/HDBC/PostgreSQL/Types.hs --- a/Database/HDBC/PostgreSQL/Types.hs +++ b/Database/HDBC/PostgreSQL/Types.hs @@ -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 diff --git a/Database/HDBC/PostgreSQL/Utils.hsc b/Database/HDBC/PostgreSQL/Utils.hsc --- a/Database/HDBC/PostgreSQL/Utils.hsc +++ b/Database/HDBC/PostgreSQL/Utils.hsc @@ -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 - diff --git a/HDBC-postgresql.cabal b/HDBC-postgresql.cabal --- a/HDBC-postgresql.cabal +++ b/HDBC-postgresql.cabal @@ -1,13 +1,14 @@ Name: HDBC-postgresql -Version: 2.3.2.4 +Version: 2.5.0.2 License: BSD3 -Maintainer: Nicolas Wu +Maintainer: Nicolas Wu , David Johnson 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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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 diff --git a/hdbc-postgresql-helper.c b/hdbc-postgresql-helper.c deleted file mode 100644 --- a/hdbc-postgresql-helper.c +++ /dev/null @@ -1,65 +0,0 @@ -#include -#include -#include -#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); -} - diff --git a/hdbc-postgresql-helper.h b/hdbc-postgresql-helper.h deleted file mode 100644 --- a/hdbc-postgresql-helper.h +++ /dev/null @@ -1,16 +0,0 @@ -#include - -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); diff --git a/pgtypes.h b/pgtypes.h deleted file mode 100644 --- a/pgtypes.h +++ /dev/null @@ -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 diff --git a/pgtypes_internal.h b/pgtypes_internal.h new file mode 100644 --- /dev/null +++ b/pgtypes_internal.h @@ -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 diff --git a/testsrc/TestSbasics.hs b/testsrc/TestSbasics.hs --- a/testsrc/TestSbasics.hs +++ b/testsrc/TestSbasics.hs @@ -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 ]