HDBC-postgresql 2.1.0.0 → 2.2.0.0
raw patch · 15 files changed
+1574/−54 lines, 15 filesdep ~HDBCdep ~base
Dependency ranges changed: HDBC, base
Files
- Database/HDBC/PostgreSQL.hs +8/−1
- Database/HDBC/PostgreSQL/Connection.hsc +8/−0
- Database/HDBC/PostgreSQL/ConnectionImpl.hs +2/−0
- Database/HDBC/PostgreSQL/ErrorCodes.hs +820/−0
- Database/HDBC/PostgreSQL/Statement.hsc +74/−44
- Database/HDBC/PostgreSQL/Types.hs +1/−0
- HDBC-postgresql.cabal +7/−9
- testsrc/SpecificDB.hs +25/−0
- testsrc/SpecificDBTests.hs +24/−0
- testsrc/TestMisc.hs +180/−0
- testsrc/TestSbasics.hs +171/−0
- testsrc/TestUtils.hs +25/−0
- testsrc/Testbasics.hs +168/−0
- testsrc/Tests.hs +34/−0
- testsrc/runtests.hs +27/−0
Database/HDBC/PostgreSQL.hs view
@@ -62,9 +62,16 @@ module Database.HDBC.PostgreSQL (- connectPostgreSQL, Connection+ -- * Connecting to Databases+ connectPostgreSQL, Connection,+ -- * PostgreSQL Error Codes+ --+ -- |When an @SqlError@ is thrown, the field @seState@ is set to one of the following+ -- error codes.+ module Database.HDBC.PostgreSQL.ErrorCodes, ) where import Database.HDBC.PostgreSQL.Connection(connectPostgreSQL, Connection())+import Database.HDBC.PostgreSQL.ErrorCodes
Database/HDBC/PostgreSQL/Connection.hsc view
@@ -72,6 +72,7 @@ Impl.disconnect = fdisconnect conn children, Impl.commit = fcommit conn children, Impl.rollback = frollback conn children,+ Impl.runRaw = frunRaw conn children, Impl.run = frun conn children, Impl.prepare = newSth conn children, Impl.clone = connectPostgreSQL args,@@ -92,6 +93,13 @@ begin_transaction :: Conn -> ChildList -> IO () begin_transaction o children = frun o children "BEGIN" [] >> return ()++frunRaw :: Conn -> ChildList -> String -> IO ()+frunRaw o children query =+ do sth <- newSth o children query+ executeRaw sth+ finish sth+ return () frun :: Conn -> ChildList -> String -> [SqlValue] -> IO Integer frun o children query args =
Database/HDBC/PostgreSQL/ConnectionImpl.hs view
@@ -26,6 +26,7 @@ disconnect :: IO (), commit :: IO (), rollback :: IO (),+ runRaw :: String -> IO (), run :: String -> [Types.SqlValue] -> IO Integer, prepare :: String -> IO Types.Statement, clone :: IO Connection,@@ -43,6 +44,7 @@ disconnect = disconnect commit = commit rollback = rollback+ runRaw = runRaw run = run prepare = prepare clone = clone
+ Database/HDBC/PostgreSQL/ErrorCodes.hs view
@@ -0,0 +1,820 @@+-- Generated from "/usr/include/postgresql/utils/errcodes.h" (PostgreSQL 8.3).+--+-- The following vim regexp substitutions map "errorcodes.h" to this file:+--+-- " remove all comments+-- :%s/\v\/\*\_.{-}\*\/+--+-- " remove empty lines+-- :%s/^\s*\n/+--+-- " #defines -> functions+-- :%s/\v#define ERRCODE_(\S*)\t*/\L\1 = /+--+-- " expand MAKE_SQLSTATE macro+-- :%s/\vMAKE_SQLSTATE\('(.)',\s*'(.)',\s*'(.)',\s*'(.)',\s*'(.)'\)/"\1\2\3\4\5"/+--+-- " aliases+-- :%s/\vERRCODE_(\S*)/\L\1/+--+-- " type signatures+-- :%s/\v^(\S*)/\r\1 :: String\r\1/+--+-- " to mixedCase+-- :%s/\v_(\l)/\u\1/g+--+-- " got ride of additional whitespace+-- :%s/\s+=\s+/ = /+--+-- " Documentation+-- :%s/\v(\a+) :: String\n\1 \= "(.*)"/-- |Is set to @\\"\2\\"@.\r\0+--+-- " Documentation for aliases+-- :%s/\v(\a+) :: String\n\1 \= (\a+)/-- |Same as '\2'.\r\0+--++module Database.HDBC.PostgreSQL.ErrorCodes where++-- |Is set to @\"00000\"@.+successfulCompletion :: String+successfulCompletion = "00000"++-- |Is set to @\"01000\"@.+warning :: String+warning = "01000"++-- |Is set to @\"0100C\"@.+warningDynamicResultSetsReturned :: String+warningDynamicResultSetsReturned = "0100C"++-- |Is set to @\"01008\"@.+warningImplicitZeroBitPadding :: String+warningImplicitZeroBitPadding = "01008"++-- |Is set to @\"01003\"@.+warningNullValueEliminatedInSetFunction :: String+warningNullValueEliminatedInSetFunction = "01003"++-- |Is set to @\"01007\"@.+warningPrivilegeNotGranted :: String+warningPrivilegeNotGranted = "01007"++-- |Is set to @\"01006\"@.+warningPrivilegeNotRevoked :: String+warningPrivilegeNotRevoked = "01006"++-- |Is set to @\"01004\"@.+warningStringDataRightTruncation :: String+warningStringDataRightTruncation = "01004"++-- |Is set to @\"01P01\"@.+warningDeprecatedFeature :: String+warningDeprecatedFeature = "01P01"++-- |Is set to @\"02000\"@.+noData :: String+noData = "02000"++-- |Is set to @\"02001\"@.+noAdditionalDynamicResultSetsReturned :: String+noAdditionalDynamicResultSetsReturned = "02001"++-- |Is set to @\"03000\"@.+sqlStatementNotYetComplete :: String+sqlStatementNotYetComplete = "03000"++-- |Is set to @\"08000\"@.+connectionException :: String+connectionException = "08000"++-- |Is set to @\"08003\"@.+connectionDoesNotExist :: String+connectionDoesNotExist = "08003"++-- |Is set to @\"08006\"@.+connectionFailure :: String+connectionFailure = "08006"++-- |Is set to @\"08001\"@.+sqlclientUnableToEstablishSqlconnection :: String+sqlclientUnableToEstablishSqlconnection = "08001"++-- |Is set to @\"08004\"@.+sqlserverRejectedEstablishmentOfSqlconnection :: String+sqlserverRejectedEstablishmentOfSqlconnection = "08004"++-- |Is set to @\"08007\"@.+transactionResolutionUnknown :: String+transactionResolutionUnknown = "08007"++-- |Is set to @\"08P01\"@.+protocolViolation :: String+protocolViolation = "08P01"++-- |Is set to @\"09000\"@.+triggeredActionException :: String+triggeredActionException = "09000"++-- |Is set to @\"0A000\"@.+featureNotSupported :: String+featureNotSupported = "0A000"++-- |Is set to @\"0B000\"@.+invalidTransactionInitiation :: String+invalidTransactionInitiation = "0B000"++-- |Is set to @\"0F000\"@.+locatorException :: String+locatorException = "0F000"++-- |Is set to @\"0F001\"@.+lEInvalidSpecification :: String+lEInvalidSpecification = "0F001"++-- |Is set to @\"0L000\"@.+invalidGrantor :: String+invalidGrantor = "0L000"++-- |Is set to @\"0LP01\"@.+invalidGrantOperation :: String+invalidGrantOperation = "0LP01"++-- |Is set to @\"0P000\"@.+invalidRoleSpecification :: String+invalidRoleSpecification = "0P000"++-- |Is set to @\"21000\"@.+cardinalityViolation :: String+cardinalityViolation = "21000"++-- |Is set to @\"22000\"@.+dataException :: String+dataException = "22000"++-- |Is set to @\"2202E\"@.+arrayElementError :: String+arrayElementError = "2202E"++-- |Same as 'arrayElementError'.+arraySubscriptError :: String+arraySubscriptError = arrayElementError++-- |Is set to @\"22021\"@.+characterNotInRepertoire :: String+characterNotInRepertoire = "22021"++-- |Is set to @\"22008\"@.+datetimeFieldOverflow :: String+datetimeFieldOverflow = "22008"++-- |Same as 'datetimeFieldOverflow'.+datetimeValueOutOfRange :: String+datetimeValueOutOfRange = datetimeFieldOverflow++-- |Is set to @\"22012\"@.+divisionByZero :: String+divisionByZero = "22012"++-- |Is set to @\"22005\"@.+errorInAssignment :: String+errorInAssignment = "22005"++-- |Is set to @\"2200B\"@.+escapeCharacterConflict :: String+escapeCharacterConflict = "2200B"++-- |Is set to @\"22022\"@.+indicatorOverflow :: String+indicatorOverflow = "22022"++-- |Is set to @\"22015\"@.+intervalFieldOverflow :: String+intervalFieldOverflow = "22015"++-- |Is set to @\"2201E\"@.+invalidArgumentForLog :: String+invalidArgumentForLog = "2201E"++-- |Is set to @\"2201F\"@.+invalidArgumentForPowerFunction :: String+invalidArgumentForPowerFunction = "2201F"++-- |Is set to @\"2201G\"@.+invalidArgumentForWidthBucketFunction :: String+invalidArgumentForWidthBucketFunction = "2201G"++-- |Is set to @\"22018\"@.+invalidCharacterValueForCast :: String+invalidCharacterValueForCast = "22018"++-- |Is set to @\"22007\"@.+invalidDatetimeFormat :: String+invalidDatetimeFormat = "22007"++-- |Is set to @\"22019\"@.+invalidEscapeCharacter :: String+invalidEscapeCharacter = "22019"++-- |Is set to @\"2200D\"@.+invalidEscapeOctet :: String+invalidEscapeOctet = "2200D"++-- |Is set to @\"22025\"@.+invalidEscapeSequence :: String+invalidEscapeSequence = "22025"++-- |Is set to @\"22P06\"@.+nonstandardUseOfEscapeCharacter :: String+nonstandardUseOfEscapeCharacter = "22P06"++-- |Is set to @\"22010\"@.+invalidIndicatorParameterValue :: String+invalidIndicatorParameterValue = "22010"++-- |Is set to @\"22020\"@.+invalidLimitValue :: String+invalidLimitValue = "22020"++-- |Is set to @\"22023\"@.+invalidParameterValue :: String+invalidParameterValue = "22023"++-- |Is set to @\"2201B\"@.+invalidRegularExpression :: String+invalidRegularExpression = "2201B"++-- |Is set to @\"22009\"@.+invalidTimeZoneDisplacementValue :: String+invalidTimeZoneDisplacementValue = "22009"++-- |Is set to @\"2200C\"@.+invalidUseOfEscapeCharacter :: String+invalidUseOfEscapeCharacter = "2200C"++-- |Is set to @\"2200G\"@.+mostSpecificTypeMismatch :: String+mostSpecificTypeMismatch = "2200G"++-- |Is set to @\"22004\"@.+nullValueNotAllowed :: String+nullValueNotAllowed = "22004"++-- |Is set to @\"22002\"@.+nullValueNoIndicatorParameter :: String+nullValueNoIndicatorParameter = "22002"++-- |Is set to @\"22003\"@.+numericValueOutOfRange :: String+numericValueOutOfRange = "22003"++-- |Is set to @\"22026\"@.+stringDataLengthMismatch :: String+stringDataLengthMismatch = "22026"++-- |Is set to @\"22001\"@.+stringDataRightTruncation :: String+stringDataRightTruncation = "22001"++-- |Is set to @\"22011\"@.+substringError :: String+substringError = "22011"++-- |Is set to @\"22027\"@.+trimError :: String+trimError = "22027"++-- |Is set to @\"22024\"@.+unterminatedCString :: String+unterminatedCString = "22024"++-- |Is set to @\"2200F\"@.+zeroLengthCharacterString :: String+zeroLengthCharacterString = "2200F"++-- |Is set to @\"22P01\"@.+floatingPointException :: String+floatingPointException = "22P01"++-- |Is set to @\"22P02\"@.+invalidTextRepresentation :: String+invalidTextRepresentation = "22P02"++-- |Is set to @\"22P03\"@.+invalidBinaryRepresentation :: String+invalidBinaryRepresentation = "22P03"++-- |Is set to @\"22P04\"@.+badCopyFileFormat :: String+badCopyFileFormat = "22P04"++-- |Is set to @\"22P05\"@.+untranslatableCharacter :: String+untranslatableCharacter = "22P05"++-- |Is set to @\"2200L\"@.+notAnXmlDocument :: String+notAnXmlDocument = "2200L"++-- |Is set to @\"2200M\"@.+invalidXmlDocument :: String+invalidXmlDocument = "2200M"++-- |Is set to @\"2200N\"@.+invalidXmlContent :: String+invalidXmlContent = "2200N"++-- |Is set to @\"2200S\"@.+invalidXmlComment :: String+invalidXmlComment = "2200S"++-- |Is set to @\"2200T\"@.+invalidXmlProcessingInstruction :: String+invalidXmlProcessingInstruction = "2200T"++-- |Is set to @\"23000\"@.+integrityConstraintViolation :: String+integrityConstraintViolation = "23000"++-- |Is set to @\"23001\"@.+restrictViolation :: String+restrictViolation = "23001"++-- |Is set to @\"23502\"@.+notNullViolation :: String+notNullViolation = "23502"++-- |Is set to @\"23503\"@.+foreignKeyViolation :: String+foreignKeyViolation = "23503"++-- |Is set to @\"23505\"@.+uniqueViolation :: String+uniqueViolation = "23505"++-- |Is set to @\"23514\"@.+checkViolation :: String+checkViolation = "23514"++-- |Is set to @\"24000\"@.+invalidCursorState :: String+invalidCursorState = "24000"++-- |Is set to @\"25000\"@.+invalidTransactionState :: String+invalidTransactionState = "25000"++-- |Is set to @\"25001\"@.+activeSqlTransaction :: String+activeSqlTransaction = "25001"++-- |Is set to @\"25002\"@.+branchTransactionAlreadyActive :: String+branchTransactionAlreadyActive = "25002"++-- |Is set to @\"25008\"@.+heldCursorRequiresSameIsolationLevel :: String+heldCursorRequiresSameIsolationLevel = "25008"++-- |Is set to @\"25003\"@.+inappropriateAccessModeForBranchTransaction :: String+inappropriateAccessModeForBranchTransaction = "25003"++-- |Is set to @\"25004\"@.+inappropriateIsolationLevelForBranchTransaction :: String+inappropriateIsolationLevelForBranchTransaction = "25004"++-- |Is set to @\"25005\"@.+noActiveSqlTransactionForBranchTransaction :: String+noActiveSqlTransactionForBranchTransaction = "25005"++-- |Is set to @\"25006\"@.+readOnlySqlTransaction :: String+readOnlySqlTransaction = "25006"++-- |Is set to @\"25007\"@.+schemaAndDataStatementMixingNotSupported :: String+schemaAndDataStatementMixingNotSupported = "25007"++-- |Is set to @\"25P01\"@.+noActiveSqlTransaction :: String+noActiveSqlTransaction = "25P01"++-- |Is set to @\"25P02\"@.+inFailedSqlTransaction :: String+inFailedSqlTransaction = "25P02"++-- |Is set to @\"26000\"@.+invalidSqlStatementName :: String+invalidSqlStatementName = "26000"++-- |Is set to @\"27000\"@.+triggeredDataChangeViolation :: String+triggeredDataChangeViolation = "27000"++-- |Is set to @\"28000\"@.+invalidAuthorizationSpecification :: String+invalidAuthorizationSpecification = "28000"++-- |Is set to @\"2B000\"@.+dependentPrivilegeDescriptorsStillExist :: String+dependentPrivilegeDescriptorsStillExist = "2B000"++-- |Is set to @\"2BP01\"@.+dependentObjectsStillExist :: String+dependentObjectsStillExist = "2BP01"++-- |Is set to @\"2D000\"@.+invalidTransactionTermination :: String+invalidTransactionTermination = "2D000"++-- |Is set to @\"2F000\"@.+sqlRoutineException :: String+sqlRoutineException = "2F000"++-- |Is set to @\"2F005\"@.+sREFunctionExecutedNoReturnStatement :: String+sREFunctionExecutedNoReturnStatement = "2F005"++-- |Is set to @\"2F002\"@.+sREModifyingSqlDataNotPermitted :: String+sREModifyingSqlDataNotPermitted = "2F002"++-- |Is set to @\"2F003\"@.+sREProhibitedSqlStatementAttempted :: String+sREProhibitedSqlStatementAttempted = "2F003"++-- |Is set to @\"2F004\"@.+sREReadingSqlDataNotPermitted :: String+sREReadingSqlDataNotPermitted = "2F004"++-- |Is set to @\"34000\"@.+invalidCursorName :: String+invalidCursorName = "34000"++-- |Is set to @\"38000\"@.+externalRoutineException :: String+externalRoutineException = "38000"++-- |Is set to @\"38001\"@.+eREContainingSqlNotPermitted :: String+eREContainingSqlNotPermitted = "38001"++-- |Is set to @\"38002\"@.+eREModifyingSqlDataNotPermitted :: String+eREModifyingSqlDataNotPermitted = "38002"++-- |Is set to @\"38003\"@.+eREProhibitedSqlStatementAttempted :: String+eREProhibitedSqlStatementAttempted = "38003"++-- |Is set to @\"38004\"@.+eREReadingSqlDataNotPermitted :: String+eREReadingSqlDataNotPermitted = "38004"++-- |Is set to @\"39000\"@.+externalRoutineInvocationException :: String+externalRoutineInvocationException = "39000"++-- |Is set to @\"39001\"@.+eRIEInvalidSqlstateReturned :: String+eRIEInvalidSqlstateReturned = "39001"++-- |Is set to @\"39004\"@.+eRIENullValueNotAllowed :: String+eRIENullValueNotAllowed = "39004"++-- |Is set to @\"39P01\"@.+eRIETriggerProtocolViolated :: String+eRIETriggerProtocolViolated = "39P01"++-- |Is set to @\"39P02\"@.+eRIESrfProtocolViolated :: String+eRIESrfProtocolViolated = "39P02"++-- |Is set to @\"3B000\"@.+savepointException :: String+savepointException = "3B000"++-- |Is set to @\"3B001\"@.+sEInvalidSpecification :: String+sEInvalidSpecification = "3B001"++-- |Is set to @\"3D000\"@.+invalidCatalogName :: String+invalidCatalogName = "3D000"++-- |Is set to @\"3F000\"@.+invalidSchemaName :: String+invalidSchemaName = "3F000"++-- |Is set to @\"40000\"@.+transactionRollback :: String+transactionRollback = "40000"++-- |Is set to @\"40002\"@.+tRIntegrityConstraintViolation :: String+tRIntegrityConstraintViolation = "40002"++-- |Is set to @\"40001\"@.+tRSerializationFailure :: String+tRSerializationFailure = "40001"++-- |Is set to @\"40003\"@.+tRStatementCompletionUnknown :: String+tRStatementCompletionUnknown = "40003"++-- |Is set to @\"40P01\"@.+tRDeadlockDetected :: String+tRDeadlockDetected = "40P01"++-- |Is set to @\"42000\"@.+syntaxErrorOrAccessRuleViolation :: String+syntaxErrorOrAccessRuleViolation = "42000"++-- |Is set to @\"42601\"@.+syntaxError :: String+syntaxError = "42601"++-- |Is set to @\"42501\"@.+insufficientPrivilege :: String+insufficientPrivilege = "42501"++-- |Is set to @\"42846\"@.+cannotCoerce :: String+cannotCoerce = "42846"++-- |Is set to @\"42803\"@.+groupingError :: String+groupingError = "42803"++-- |Is set to @\"42830\"@.+invalidForeignKey :: String+invalidForeignKey = "42830"++-- |Is set to @\"42602\"@.+invalidName :: String+invalidName = "42602"++-- |Is set to @\"42622\"@.+nameTooLong :: String+nameTooLong = "42622"++-- |Is set to @\"42939\"@.+reservedName :: String+reservedName = "42939"++-- |Is set to @\"42804\"@.+datatypeMismatch :: String+datatypeMismatch = "42804"++-- |Is set to @\"42P18\"@.+indeterminateDatatype :: String+indeterminateDatatype = "42P18"++-- |Is set to @\"42809\"@.+wrongObjectType :: String+wrongObjectType = "42809"++-- |Is set to @\"42703\"@.+undefinedColumn :: String+undefinedColumn = "42703"++-- |Same as 'invalidCursorName'.+undefinedCursor :: String+undefinedCursor = invalidCursorName++-- |Same as 'invalidCatalogName'.+undefinedDatabase :: String+undefinedDatabase = invalidCatalogName++-- |Is set to @\"42883\"@.+undefinedFunction :: String+undefinedFunction = "42883"++-- |Same as 'invalidSqlStatementName'.+undefinedPstatement :: String+undefinedPstatement = invalidSqlStatementName++-- |Same as 'invalidSchemaName'.+undefinedSchema :: String+undefinedSchema = invalidSchemaName++-- |Is set to @\"42P01\"@.+undefinedTable :: String+undefinedTable = "42P01"++-- |Is set to @\"42P02\"@.+undefinedParameter :: String+undefinedParameter = "42P02"++-- |Is set to @\"42704\"@.+undefinedObject :: String+undefinedObject = "42704"++-- |Is set to @\"42701\"@.+duplicateColumn :: String+duplicateColumn = "42701"++-- |Is set to @\"42P03\"@.+duplicateCursor :: String+duplicateCursor = "42P03"++-- |Is set to @\"42P04\"@.+duplicateDatabase :: String+duplicateDatabase = "42P04"++-- |Is set to @\"42723\"@.+duplicateFunction :: String+duplicateFunction = "42723"++-- |Is set to @\"42P05\"@.+duplicatePstatement :: String+duplicatePstatement = "42P05"++-- |Is set to @\"42P06\"@.+duplicateSchema :: String+duplicateSchema = "42P06"++-- |Is set to @\"42P07\"@.+duplicateTable :: String+duplicateTable = "42P07"++-- |Is set to @\"42712\"@.+duplicateAlias :: String+duplicateAlias = "42712"++-- |Is set to @\"42710\"@.+duplicateObject :: String+duplicateObject = "42710"++-- |Is set to @\"42702\"@.+ambiguousColumn :: String+ambiguousColumn = "42702"++-- |Is set to @\"42725\"@.+ambiguousFunction :: String+ambiguousFunction = "42725"++-- |Is set to @\"42P08\"@.+ambiguousParameter :: String+ambiguousParameter = "42P08"++-- |Is set to @\"42P09\"@.+ambiguousAlias :: String+ambiguousAlias = "42P09"++-- |Is set to @\"42P10\"@.+invalidColumnReference :: String+invalidColumnReference = "42P10"++-- |Is set to @\"42611\"@.+invalidColumnDefinition :: String+invalidColumnDefinition = "42611"++-- |Is set to @\"42P11\"@.+invalidCursorDefinition :: String+invalidCursorDefinition = "42P11"++-- |Is set to @\"42P12\"@.+invalidDatabaseDefinition :: String+invalidDatabaseDefinition = "42P12"++-- |Is set to @\"42P13\"@.+invalidFunctionDefinition :: String+invalidFunctionDefinition = "42P13"++-- |Is set to @\"42P14\"@.+invalidPstatementDefinition :: String+invalidPstatementDefinition = "42P14"++-- |Is set to @\"42P15\"@.+invalidSchemaDefinition :: String+invalidSchemaDefinition = "42P15"++-- |Is set to @\"42P16\"@.+invalidTableDefinition :: String+invalidTableDefinition = "42P16"++-- |Is set to @\"42P17\"@.+invalidObjectDefinition :: String+invalidObjectDefinition = "42P17"++-- |Is set to @\"44000\"@.+withCheckOptionViolation :: String+withCheckOptionViolation = "44000"++-- |Is set to @\"53000\"@.+insufficientResources :: String+insufficientResources = "53000"++-- |Is set to @\"53100\"@.+diskFull :: String+diskFull = "53100"++-- |Is set to @\"53200\"@.+outOfMemory :: String+outOfMemory = "53200"++-- |Is set to @\"53300\"@.+tooManyConnections :: String+tooManyConnections = "53300"++-- |Is set to @\"54000\"@.+programLimitExceeded :: String+programLimitExceeded = "54000"++-- |Is set to @\"54001\"@.+statementTooComplex :: String+statementTooComplex = "54001"++-- |Is set to @\"54011\"@.+tooManyColumns :: String+tooManyColumns = "54011"++-- |Is set to @\"54023\"@.+tooManyArguments :: String+tooManyArguments = "54023"++-- |Is set to @\"55000\"@.+objectNotInPrerequisiteState :: String+objectNotInPrerequisiteState = "55000"++-- |Is set to @\"55006\"@.+objectInUse :: String+objectInUse = "55006"++-- |Is set to @\"55P02\"@.+cantChangeRuntimeParam :: String+cantChangeRuntimeParam = "55P02"++-- |Is set to @\"55P03\"@.+lockNotAvailable :: String+lockNotAvailable = "55P03"++-- |Is set to @\"57000\"@.+operatorIntervention :: String+operatorIntervention = "57000"++-- |Is set to @\"57014\"@.+queryCanceled :: String+queryCanceled = "57014"++-- |Is set to @\"57P01\"@.+adminShutdown :: String+adminShutdown = "57P01"++-- |Is set to @\"57P02\"@.+crashShutdown :: String+crashShutdown = "57P02"++-- |Is set to @\"57P03\"@.+cannotConnectNow :: String+cannotConnectNow = "57P03"++-- |Is set to @\"58030\"@.+ioError :: String+ioError = "58030"++-- |Is set to @\"58P01\"@.+undefinedFile :: String+undefinedFile = "58P01"++-- |Is set to @\"58P02\"@.+duplicateFile :: String+duplicateFile = "58P02"++-- |Is set to @\"F0000\"@.+configFileError :: String+configFileError = "F0000"++-- |Is set to @\"F0001\"@.+lockFileExists :: String+lockFileExists = "F0001"++-- |Is set to @\"P0000\"@.+plpgsqlError :: String+plpgsqlError = "P0000"++-- |Is set to @\"P0001\"@.+raiseException :: String+raiseException = "P0001"++-- |Is set to @\"P0002\"@.+noDataFound :: String+noDataFound = "P0002"++-- |Is set to @\"P0003\"@.+tooManyRows :: String+tooManyRows = "P0003"++-- |Is set to @\"XX000\"@.+internalError :: String+internalError = "XX000"++-- |Is set to @\"XX001\"@.+dataCorrupted :: String+dataCorrupted = "XX001"++-- |Is set to @\"XX002\"@.+indexCorrupted :: String+indexCorrupted = "XX002"
Database/HDBC/PostgreSQL/Statement.hsc view
@@ -76,6 +76,7 @@ let retval = Statement {execute = fexecute sstate, executeMany = fexecutemany sstate,+ executeRaw = fexecuteRaw sstate, finish = public_ffinish sstate, fetchRow = ffetchrow sstate, originalQuery = query,@@ -103,51 +104,74 @@ public_ffinish sstate -- Sets nextrowmv to -1 resptr <- pqexecParams cconn cquery (genericLength args) nullPtr cargs nullPtr nullPtr 0- status <- pqresultStatus resptr- case status of- #{const PGRES_EMPTY_QUERY} ->- do l $ "PGRES_EMPTY_QUERY: " ++ squery sstate- pqclear_raw resptr- swapMVar (coldefmv sstate) []- return 0- #{const PGRES_COMMAND_OK} ->- do l $ "PGRES_COMMAND_OK: " ++ squery sstate- rowscs <- pqcmdTuples resptr- rows <- peekCString rowscs- pqclear_raw resptr- swapMVar (coldefmv sstate) []- return $ case rows of- "" -> 0- x -> read x- #{const PGRES_TUPLES_OK} -> - do l $ "PGRES_TUPLES_OK: " ++ squery sstate- fgetcoldef resptr >>= swapMVar (coldefmv sstate) - numrows <- pqntuples resptr- if numrows < 1- then do pqclear_raw resptr- return 0- else do - wrappedptr <- withRawConn (dbo sstate) - (\rawconn -> wrapstmt resptr rawconn)- fresptr <- newForeignPtr pqclearptr wrappedptr- swapMVar (nextrowmv sstate) 0- swapMVar (stomv sstate) (Just fresptr)- return 0- _ -> do l $ "PGRES ERROR: " ++ squery sstate- csstatusmsg <- pqresStatus status- cserrormsg <- pqresultErrorMessage resptr- - statusmsgbs <- B.packCString csstatusmsg- errormsgbs <- B.packCString cserrormsg- let statusmsg = BUTF8.toString statusmsgbs- let errormsg = BUTF8.toString errormsgbs+ handleResultStatus resptr sstate =<< pqresultStatus resptr - pqclear_raw resptr- throwSqlError $ - SqlError {seState = "",- seNativeError = fromIntegral status,- seErrorMsg = "execute: " ++ statusmsg ++- ": " ++ errormsg}+{- | Differs from fexecute in that it does not prepare its input+ query, and the input query may contain multiple statements. This+ is useful for issuing DDL or DML commands. -}+fexecuteRaw :: SState -> IO ()+fexecuteRaw sstate =+ withConn (dbo sstate) $ \cconn ->+ B.useAsCString (BUTF8.fromString (squery sstate)) $ \cquery ->+ do l "in fexecute"+ public_ffinish sstate -- Sets nextrowmv to -1+ resptr <- pqexec cconn cquery+ handleResultStatus resptr sstate =<< pqresultStatus resptr+ return ()++handleResultStatus :: (Num a, Read a) => WrappedCStmt -> SState -> ResultStatus -> IO a+handleResultStatus resptr sstate status =+ case status of+ #{const PGRES_EMPTY_QUERY} ->+ do l $ "PGRES_EMPTY_QUERY: " ++ squery sstate+ pqclear_raw resptr+ swapMVar (coldefmv sstate) []+ return 0+ #{const PGRES_COMMAND_OK} ->+ do l $ "PGRES_COMMAND_OK: " ++ squery sstate+ rowscs <- pqcmdTuples resptr+ rows <- peekCString rowscs+ pqclear_raw resptr+ swapMVar (coldefmv sstate) []+ return $ case rows of+ "" -> 0+ x -> read x+ #{const PGRES_TUPLES_OK} ->+ do l $ "PGRES_TUPLES_OK: " ++ squery sstate+ fgetcoldef resptr >>= swapMVar (coldefmv sstate)+ 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+ swapMVar (nextrowmv sstate) 0+ swapMVar (stomv sstate) (Just fresptr)+ return 0+ _ -> do l $ "PGRES ERROR: " ++ squery sstate+ csstatusmsg <- pqresStatus status+ cserrormsg <- pqresultErrorMessage resptr++ statusmsgbs <- B.packCString csstatusmsg+ errormsgbs <- B.packCString cserrormsg+ let statusmsg = BUTF8.toString statusmsgbs+ let errormsg = BUTF8.toString errormsgbs++ state <- pqresultErrorField resptr #{const PG_DIAG_SQLSTATE} >>= peekCStringUTF8++ pqclear_raw resptr+ throwSqlError $ SqlError { seState = state+ , seNativeError = fromIntegral status+ , seErrorMsg = "execute: " ++ statusmsg +++ ": " ++ errormsg}++peekCStringUTF8 :: CString -> IO String+-- Marshal a NUL terminated C string into a Haskell string, decoding it+-- with UTF8.+peekCStringUTF8 str = fmap BUTF8.toString (B.packCString str)+++ {- General algorithm: find out how many columns we have, check the type of each to see if it's NULL. If it's not, fetch it as text and return that. -}@@ -224,6 +248,9 @@ CInt -> IO (Ptr CStmt) +foreign import ccall unsafe "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 () @@ -243,6 +270,9 @@ foreign import ccall unsafe "libpq-fe.h PQresultErrorMessage" pqresultErrorMessage :: (Ptr CStmt) -> IO CString++foreign import ccall unsafe "libpq-fe.h PQresultErrorField"+ pqresultErrorField :: (Ptr CStmt) -> CInt -> IO CString foreign import ccall unsafe "libpq-fe.h PQntuples" pqntuples :: Ptr CStmt -> IO CInt
Database/HDBC/PostgreSQL/Types.hs view
@@ -10,4 +10,5 @@ data CStmt = CStmt type WrappedCStmt = Ptr CStmt type Stmt = ForeignPtr WrappedCStmt+type ResultStatus = Word32
HDBC-postgresql.cabal view
@@ -1,12 +1,12 @@ Name: HDBC-postgresql-Version: 2.1.0.0+Version: 2.2.0.0 License: LGPL Maintainer: John Goerzen <jgoerzen@complete.org> Author: John Goerzen Copyright: Copyright (c) 2005-2009 John Goerzen license-file: COPYRIGHT extra-source-files: COPYING, hdbc-postgresql-helper.h, pgtypes.h-homepage: http://software.complete.org/hdbc-postgres+homepage: http://software.complete.org/hdbc-postgresql Category: Database synopsis: PostgreSQL driver for HDBC Description: This package provides a PostgreSQL driver for HDBC@@ -29,14 +29,11 @@ Database.HDBC.PostgreSQL.Types, Database.HDBC.PostgreSQL.Utils, Database.HDBC.PostgreSQL.Parser,- Database.HDBC.PostgreSQL.PTypeConv+ Database.HDBC.PostgreSQL.PTypeConv,+ Database.HDBC.PostgreSQL.ErrorCodes Extensions: ExistentialQuantification, ForeignFunctionInterface- Build-Depends: base, mtl, HDBC>=2.1.0, parsec, utf8-string,- bytestring, old-time, old-locale- if flag(splitBase)- Build-Depends: base >= 3, old-time- else- Build-Depends: base < 3+ Build-Depends: base >= 3 && < 5, mtl, HDBC>=2.2.0, parsec, utf8-string,+ bytestring, old-time, old-locale, time if impl(ghc >= 6.9) Build-Depends: base >= 4 Extra-Libraries: pq@@ -59,6 +56,7 @@ Database.HDBC.PostgreSQL.Utils, Database.HDBC.PostgreSQL.Parser, Database.HDBC.PostgreSQL.PTypeConv,+ Database.HDBC.PostgreSQL.ErrorCodes, SpecificDB, SpecificDBTests, TestMisc,
+ testsrc/SpecificDB.hs view
@@ -0,0 +1,25 @@+module SpecificDB where+import Database.HDBC+import Database.HDBC.PostgreSQL+import Database.HDBC.PostgreSQL.Parser(convertSQL)+import Test.HUnit++connectDB = + handleSqlError (do dbh <- connectPostgreSQL ""+ run dbh "SET client_min_messages=WARNING" []+ return dbh)++dateTimeTypeOfSqlValue :: SqlValue -> String+dateTimeTypeOfSqlValue (SqlLocalDate _) = "date"+dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone"+dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone"+dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone"+dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone"+dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone"+dateTimeTypeOfSqlValue (SqlDiffTime _) = "interval"+dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric"+dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer"+dateTimeTypeOfSqlValue (SqlTimeDiff _) = "interval"+dateTimeTypeOfSqlValue _ = "text"++supportsFracTime = True
+ testsrc/SpecificDBTests.hs view
@@ -0,0 +1,24 @@+module SpecificDBTests where+import Database.HDBC+import Database.HDBC.PostgreSQL+import Database.HDBC.PostgreSQL.Parser(convertSQL)+import Test.HUnit++testp inp exp = TestCase $+ case convertSQL inp of+ Right x -> assertEqual "" exp x+ Left y -> assertFailure $ show y++tests = TestList + [TestLabel "empty" (testp "" ""),+ TestLabel "simple" (testp "SELECT a from b WHERE c = ?"+ "SELECT a from b WHERE c = $1"),+ TestLabel "multi" (testp "INSERT INTO foo VALUES (?,?)"+ "INSERT INTO foo VALUES ($1,$2)"),+ TestLabel "literal" (testp "INSERT INTO foo VALUES ('?', '''?')"+ "INSERT INTO foo VALUES ('?', '''?')"),+ TestLabel "torture" + (testp "-- really?\n-- yes'?\nINSERT INTO ? VALUES ('', ?, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ?)"+ "-- really?\n-- yes'?\nINSERT INTO $1 VALUES ('', $2, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ $3)")+ ] +
+ testsrc/TestMisc.hs view
@@ -0,0 +1,180 @@+module TestMisc(tests, setup) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception+import Data.Char+import Control.Monad+import qualified Data.Map as Map++rowdata = + [[SqlInt32 0, toSql "Testing", SqlNull],+ [SqlInt32 1, toSql "Foo", SqlInt32 5],+ [SqlInt32 2, toSql "Bar", SqlInt32 9]]++colnames = ["testid", "teststring", "testint"]+alrows :: [[(String, SqlValue)]]+alrows = map (zip colnames) rowdata++setup f = dbTestCase $ \dbh ->+ do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" []+ sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rowdata+ commit dbh+ finally (f dbh)+ (do run dbh "DROP TABLE hdbctest2" []+ commit dbh+ )++cloneTest dbh a =+ do dbh2 <- clone dbh+ finally (handleSqlError (a dbh2))+ (handleSqlError (disconnect dbh2))++testgetColumnNames = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2"+ execute sth []+ cols <- getColumnNames sth+ finish sth+ ["testid", "teststring", "testint"] @=? map (map toLower) cols++testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`+ ["sqlite3"])) $+ do sth <- prepare dbh "SELECT * from hdbctest2"+ execute sth []+ cols <- describeResult sth+ ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols+ let coldata = map snd cols+ assertBool "r0 type" (colType (coldata !! 0) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertBool "r1 type" (colType (coldata !! 1) `elem`+ [SqlVarCharT, SqlLongVarCharT])+ assertBool "r2 type" (colType (coldata !! 2) `elem`+ [SqlBigIntT, SqlIntegerT])+ finish sth++testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`+ ["sqlite3"])) $+ do cols <- describeTable dbh "hdbctest2"+ ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols+ let coldata = map snd cols+ assertBool "r0 type" (colType (coldata !! 0) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0))+ assertBool "r1 type" (colType (coldata !! 1) `elem`+ [SqlVarCharT, SqlLongVarCharT])+ assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1))+ assertBool "r2 type" (colType (coldata !! 2) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2))++testquickQuery = setup $ \dbh ->+ do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ rowdata @=? results++testfetchRowAL = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth []+ fetchRowAL sth >>= (Just (head alrows) @=?)+ fetchRowAL sth >>= (Just (alrows !! 1) @=?)+ fetchRowAL sth >>= (Just (alrows !! 2) @=?)+ fetchRowAL sth >>= (Nothing @=?)+ finish sth++testfetchRowMap = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth []+ fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?)+ fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?)+ fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?)+ fetchRowMap sth >>= (Nothing @=?)+ finish sth++testfetchAllRowsAL = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"+ execute sth []+ fetchAllRowsAL sth >>= (alrows @=?)++testfetchAllRowsMap = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"+ execute sth []+ fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?)++testexception = setup $ \dbh ->+ catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2"+ execute sth []+ assertFailure "No exception was raised"+ )+ (\e -> commit dbh)++testrowcount = setup $ \dbh ->+ do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" []+ assertEqual "UPDATE with no change" 0 r+ r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" []+ assertEqual "UPDATE with 1 change" 1 r+ r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" []+ assertEqual "UPDATE with 2 changes" 2 r+ commit dbh+ res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ assertEqual "final results"+ [[SqlInt32 0, toSql "Testing", SqlInt32 26],+ [SqlInt32 1, toSql "Foo", SqlInt32 27],+ [SqlInt32 2, toSql "Bar", SqlInt32 27]] res+ +{- Since we might be running against a live DB, we can't look at a specific+list here (though a SpecificDB test case may be able to). We can ensure+that our test table is, or is not, present, as appropriate. -}+ +testgetTables1 = setup $ \dbh ->+ do r <- getTables dbh+ True @=? "hdbctest2" `elem` r++testgetTables2 = dbTestCase $ \dbh ->+ do r <- getTables dbh+ False @=? "hdbctest2" `elem` r++testclone = setup $ \dbho -> cloneTest dbho $ \dbh ->+ do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ rowdata @=? results++testnulls = setup $ \dbh ->+ do let dn = hdbcDriverName dbh+ when (not (dn `elem` ["postgresql", "odbc"])) (+ do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rows+ finish sth+ res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []+ seq (length res) rows @=? res+ )+ where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull],+ [SqlInt32 101, SqlString "bar\NUL", SqlNull],+ [SqlInt32 102, SqlString "\NUL", SqlNull],+ [SqlInt32 103, SqlString "\xFF", SqlNull],+ [SqlInt32 104, SqlString "regular", SqlNull]]+ +testunicode = setup $ \dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rows+ finish sth+ res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []+ seq (length res) rows @=? res+ where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull],+ [SqlInt32 101, SqlString "bar\x00A3", SqlNull],+ [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]]++tests = TestList [TestLabel "getColumnNames" testgetColumnNames,+ TestLabel "describeResult" testdescribeResult,+ TestLabel "describeTable" testdescribeTable,+ TestLabel "quickQuery" testquickQuery,+ TestLabel "fetchRowAL" testfetchRowAL,+ TestLabel "fetchRowMap" testfetchRowMap,+ TestLabel "fetchAllRowsAL" testfetchAllRowsAL,+ TestLabel "fetchAllRowsMap" testfetchAllRowsMap,+ TestLabel "sql exception" testexception,+ TestLabel "clone" testclone,+ TestLabel "update rowcount" testrowcount,+ TestLabel "get tables1" testgetTables1,+ TestLabel "get tables2" testgetTables2,+ TestLabel "nulls" testnulls,+ TestLabel "unicode" testunicode]
+ testsrc/TestSbasics.hs view
@@ -0,0 +1,171 @@+module TestSbasics(tests) where+import Test.HUnit+import Data.List+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception hiding (catch)++openClosedb = sqlTestCase $ + do dbh <- connectDB+ disconnect dbh++multiFinish = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ finish sth+ finish sth+ finish sth+ )++runRawTest = dbTestCase (\dbh ->+ do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)"+ tables <- getTables dbh+ assertBool "valid1 table not created!" ("valid1" `elem` tables)+ assertBool "valid2 table not created!" ("valid2" `elem` tables)+ )++runRawErrorTest = dbTestCase (\dbh ->+ let expected = "ERROR: syntax error at or near \"INVALID\""+ in do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql`+ (return . seErrorMsg)+ assertBool "Error message inappropriate" (expected `isInfixOf` err)+ rollback dbh+ tables <- getTables dbh+ assertBool "valid1 table created!" (not $ "valid1" `elem` tables)+ )+++basicQueries = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"]))+ sFetchRow sth >>= (assertEqual "last row" Nothing)+ )+ +createTable = dbTestCase (\dbh ->+ do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []+ commit dbh+ )++dropTable = dbTestCase (\dbh ->+ do sRun dbh "DROP TABLE hdbctest1" []+ commit dbh+ )++runReplace = dbTestCase (\dbh ->+ do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1+ sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"+ sExecute sth []+ sFetchRow sth >>= (assertEqual "r1" (Just r1))+ sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2",+ Just "2", Nothing]))+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )+ where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"]+ r2 = [Just "runReplace", Just "2", Nothing]++executeReplace = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"+ sExecute sth [Just "1", Just "1234", Just "Foo"]+ sExecute sth [Just "2", Nothing, Just "Bar"]+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"+ sExecute sth [Just "executeReplace"]+ sFetchRow sth >>= (assertEqual "r1" + (Just $ map Just ["executeReplace", "1", "1234", + "Foo"]))+ sFetchRow sth >>= (assertEqual "r2"+ (Just [Just "executeReplace", Just "2", Nothing,+ Just "Bar"]))+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )++testExecuteMany = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"+ sExecuteMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"+ sExecute sth []+ mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )+ where rows = [map Just ["1", "1234", "foo"],+ map Just ["2", "1341", "bar"],+ [Just "3", Nothing, Nothing]]++testsFetchAllRows = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"+ sExecuteMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"+ sExecute sth []+ results <- sFetchAllRows sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++basicTransactions = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"+ sExecute sth [Just "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])++ -- Now try a rollback+ sExecuteMany sth rows+ rollback dbh+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])++ -- Now try another commit+ sExecuteMany sth rows+ commit dbh+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++testWithTransaction = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"+ sExecute sth [Just "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])+ + -- Let's try a rollback.+ catch (withTransaction dbh (\_ -> do sExecuteMany sth rows+ fail "Foo"))+ (\_ -> return ())+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])++ -- And now a commit.+ withTransaction dbh (\_ -> sExecuteMany sth rows)+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]+ +tests = TestList+ [+ TestLabel "openClosedb" openClosedb,+ TestLabel "multiFinish" multiFinish,+ TestLabel "runRawTest" runRawTest,+ TestLabel "runRawErrorTest" runRawErrorTest,+ TestLabel "basicQueries" basicQueries,+ TestLabel "createTable" createTable,+ TestLabel "runReplace" runReplace,+ TestLabel "executeReplace" executeReplace,+ TestLabel "executeMany" testExecuteMany,+ TestLabel "sFetchAllRows" testsFetchAllRows,+ TestLabel "basicTransactions" basicTransactions,+ TestLabel "withTransaction" testWithTransaction,+ TestLabel "dropTable" dropTable+ ]
+ testsrc/TestUtils.hs view
@@ -0,0 +1,25 @@+module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where+import Database.HDBC+import Test.HUnit+import Control.Exception+import SpecificDB(connectDB)++sqlTestCase a = + TestCase (handleSqlError a)++dbTestCase a =+ TestCase (do dbh <- connectDB+ finally (handleSqlError (a dbh))+ (handleSqlError (disconnect dbh))+ )++printDBInfo = handleSqlError $+ do dbh <- connectDB+ putStrLn "+-------------------------------------------------------------------------"+ putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh +++ ", bound to client: " ++ hdbcClientVer dbh+ putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh +++ ", bound to version: " ++ proxiedClientVer dbh+ putStrLn $ "| Connected to server version: " ++ dbServerVer dbh+ putStrLn "+-------------------------------------------------------------------------\n"+ disconnect dbh
+ testsrc/Testbasics.hs view
@@ -0,0 +1,168 @@+module Testbasics(tests) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception hiding (catch)++openClosedb = sqlTestCase $ + do dbh <- connectDB+ disconnect dbh++multiFinish = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ r <- execute sth []+ assertEqual "basic count" 0 r+ finish sth+ finish sth+ finish sth+ )++basicQueries = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ execute sth [] >>= (0 @=?)+ r <- fetchAllRows sth+ assertEqual "converted from" [["2"]] (map (map fromSql) r)+ assertEqual "int32 compare" [[SqlInt32 2]] r+ assertEqual "iToSql compare" [[iToSql 2]] r+ assertEqual "num compare" [[toSql (2::Int)]] r+ assertEqual "nToSql compare" [[nToSql (2::Int)]] r+ assertEqual "string compare" [[SqlString "2"]] r+ )+ +createTable = dbTestCase (\dbh ->+ do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []+ commit dbh+ )++dropTable = dbTestCase (\dbh ->+ do run dbh "DROP TABLE hdbctest1" []+ commit dbh+ )++runReplace = dbTestCase (\dbh ->+ do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1+ assertEqual "insert retval" 1 r+ run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"+ rv2 <- execute sth []+ assertEqual "select retval" 0 rv2+ r <- fetchAllRows sth+ assertEqual "" [r1, r2] r+ )+ where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull]++executeReplace = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"+ execute sth [iToSql 1, iToSql 1234, toSql "Foo"]+ execute sth [SqlInt32 2, SqlNull, toSql "Bar"]+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"+ execute sth [SqlString "executeReplace"]+ r <- fetchAllRows sth+ assertEqual "result"+ [[toSql "executeReplace", iToSql 1, toSql "1234",+ toSql "Foo"],+ [toSql "executeReplace", iToSql 2, SqlNull,+ toSql "Bar"]]+ r+ )++testExecuteMany = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"+ execute sth []+ r <- fetchAllRows sth+ assertEqual "" rows r+ )+ where rows = [map toSql ["1", "1234", "foo"],+ map toSql ["2", "1341", "bar"],+ [toSql "3", SqlNull, SqlNull]]++testFetchAllRows = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"+ execute sth []+ results <- fetchAllRows sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [iToSql x]) [1..9]++testFetchAllRows' = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid"+ execute sth []+ results <- fetchAllRows' sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [iToSql x]) [1..9]++basicTransactions = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"+ execute sth [iToSql 0]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])++ -- Now try a rollback+ executeMany sth rows+ rollback dbh+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]])++ -- Now try another commit+ executeMany sth rows+ commit dbh+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows))+ )+ where rows = map (\x -> [iToSql $ x]) [1..9]++testWithTransaction = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"+ execute sth [toSql "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])+ + -- Let's try a rollback.+ catch (withTransaction dbh (\_ -> do executeMany sth rows+ fail "Foo"))+ (\_ -> return ())+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]])++ -- And now a commit.+ withTransaction dbh (\_ -> executeMany sth rows)+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows))+ )+ where rows = map (\x -> [iToSql x]) [1..9]+ +tests = TestList+ [+ TestLabel "openClosedb" openClosedb,+ TestLabel "multiFinish" multiFinish,+ TestLabel "basicQueries" basicQueries,+ TestLabel "createTable" createTable,+ TestLabel "runReplace" runReplace,+ TestLabel "executeReplace" executeReplace,+ TestLabel "executeMany" testExecuteMany,+ TestLabel "fetchAllRows" testFetchAllRows,+ TestLabel "fetchAllRows'" testFetchAllRows',+ TestLabel "basicTransactions" basicTransactions,+ TestLabel "withTransaction" testWithTransaction,+ TestLabel "dropTable" dropTable+ ]
+ testsrc/Tests.hs view
@@ -0,0 +1,34 @@+{- arch-tag: Tests main file+Copyright (C) 2004-2005 John Goerzen <jgoerzen@complete.org>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Tests(tests) where+import Test.HUnit+import qualified Testbasics+import qualified TestSbasics+import qualified SpecificDBTests+import qualified TestMisc+import qualified TestTime++test1 = TestCase ("x" @=? "x")++tests = TestList [TestLabel "test1" test1,+ TestLabel "String basics" TestSbasics.tests,+ TestLabel "SqlValue basics" Testbasics.tests,+ TestLabel "SpecificDB" SpecificDBTests.tests,+ TestLabel "Misc tests" TestMisc.tests,+ TestLabel "Time tests" TestTime.tests]
+ testsrc/runtests.hs view
@@ -0,0 +1,27 @@+{- arch-tag: Test runner+Copyright (C) 2004 John Goerzen <jgoerzen@complete.org>++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2 of the License, or+(at your option) any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; if not, write to the Free Software+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module Main where ++import Test.HUnit+import Tests+import TestUtils++main = do printDBInfo+ runTestTT tests+