packages feed

HDBC-postgresql 2.3.2.8 → 2.5.0.2

raw patch · 10 files changed

Files

CHANGELOG.md view
@@ -1,5 +1,17 @@ # 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
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/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,14 +1,14 @@ Name: HDBC-postgresql-Version: 2.3.2.8+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,+extra-source-files: LICENSE                     pgtypes_internal.h-                    Makefile,-                    README.txt,+                    Makefile+                    README.txt                     testsrc/TestTime.hs                     CHANGELOG.md homepage: http://github.com/hdbc/hdbc-postgresql@@ -21,7 +21,7 @@ Cabal-Version: >=1.10  custom-setup-  setup-depends: Cabal >= 1.8 && < 3.3, base < 5+  setup-depends: Cabal >= 1.8 && < 3.17, base < 5  Flag splitBase   description: Choose the new smaller, split-up package.@@ -45,14 +45,13 @@   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.10+    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@@ -60,11 +59,11 @@ 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.9+        Build-Depends: time >= 1.5 && < 1.17         CPP-Options: -DMIN_TIME_15       else         Build-Depends: time < 1.5, old-locale@@ -86,11 +85,10 @@                   TestUtils,                   Testbasics,                   Tests-   C-Sources: hdbc-postgresql-helper.c    include-dirs: .    Extra-Libraries: pq    Hs-Source-Dirs: ., testsrc-   GHC-Options: -O2+   GHC-Options: -O2 -threaded    Default-Language: Haskell2010  source-repository head
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,6 +8,9 @@ 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)@@ -61,9 +64,14 @@   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);
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          ]