You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
758 lines
31 KiB
758 lines
31 KiB
VERSION 1.0 CLASS
|
|
BEGIN
|
|
MultiUse = -1 'True
|
|
Persistable = 0 'NotPersistable
|
|
DataBindingBehavior = 0 'vbNone
|
|
DataSourceBehavior = 0 'vbNone
|
|
MTSTransactionMode = 0 'NotAnMTSObject
|
|
END
|
|
Attribute VB_Name = "Service"
|
|
Attribute VB_GlobalNameSpace = False
|
|
Attribute VB_Creatable = True
|
|
Attribute VB_PredeclaredId = False
|
|
Attribute VB_Exposed = True
|
|
Attribute VB_Description = "APE Service"
|
|
Option Explicit
|
|
|
|
Implements APEInterfaces.IService
|
|
|
|
Private Const msJetDBName = "APETest.mdb" ' Name of Jet database used for database tests
|
|
|
|
' Text of "DRIVER" specifications of connect string for supported database types
|
|
Private Const msAccessDriver = "Microsoft Access Driver (*.mdb)"
|
|
Private Const msSQLServerDriver = "SQL Server"
|
|
|
|
Private Const miMinQueryRetryDelay As Integer = 20 ' Min delay (ms) between retries of a query that failed due to a locking contention
|
|
Private Const miMaxQueryRetryDelay As Integer = 100 ' Max delay (ms) between retries of a query that failed due to a locking contention
|
|
|
|
Private moWorkspace As Object ' The workspace for the connection
|
|
Private moConnection As Object ' The connection established by calling the Initialize method
|
|
Private moDatabase As DAO.Database ' The database used for DAO operations
|
|
Private mvServiceConfiguration As Variant ' Service configuration options (array)
|
|
Private mbConnectionOpen As Boolean ' Flag indicating that there is a connection opened in the Initialize procedure
|
|
Private mbLogDatabaseEvents As Boolean
|
|
Private mbLogMTSTransactions As Boolean
|
|
Private mbShowMTSTransactions As Boolean
|
|
Private msServiceID As String
|
|
Private mDBType As ape_DbServerOptions ' Type of database that the service connects to
|
|
|
|
' Handles for the ODBC API calls
|
|
Private mhEnvironment As Long
|
|
Private mhConnection As Long
|
|
Private mhStatement As Long
|
|
Const msERROR_SOURCE As String = "AEService"
|
|
|
|
Public Sub Execute(ByRef sServiceID As String, ByRef sCommand As String, Optional ByRef vServiceData As Variant, Optional ByRef vReturn As Variant)
|
|
Attribute Execute.VB_Description = "AEWorker.Worker objects call this method when using late binding."
|
|
'-------------------------------------------------------------------------
|
|
'Purpose:
|
|
' Provides an interface for late binding. Late binding is only provided
|
|
' for test comparison. Other custom services should only use the implemented
|
|
' interface.
|
|
'-------------------------------------------------------------------------
|
|
Dim bDataMissing As Boolean
|
|
Dim bReturnMissing As Boolean
|
|
bDataMissing = IsMissing(vServiceData)
|
|
bReturnMissing = IsMissing(vReturn)
|
|
If bDataMissing And bReturnMissing Then
|
|
IService_Execute sServiceID, sCommand
|
|
ElseIf bReturnMissing Then
|
|
IService_Execute sServiceID, sCommand, vServiceData
|
|
ElseIf bDataMissing Then
|
|
IService_Execute sServiceID, sCommand, , vReturn
|
|
Else
|
|
IService_Execute sServiceID, sCommand, vServiceData, vReturn
|
|
End If
|
|
End Sub
|
|
|
|
Public Sub Initialize(vServiceConfiguration As Variant)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose:
|
|
' Provides an interface for late binding. Late binding is only provided
|
|
' for test comparison. Other custom services should only use the implemented
|
|
' interface.
|
|
'-------------------------------------------------------------------------
|
|
IService_Initialize vServiceConfiguration
|
|
End Sub
|
|
|
|
Private Sub IService_Execute(sServiceID As String, sCommand As String, Optional vServiceData As Variant, Optional vReturn As Variant)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose:
|
|
' In response to the data it receives, it may return data of different
|
|
' sizes are types and/or sleep or burn processor cycles for a certain
|
|
' amount of time.
|
|
'In:
|
|
' [sCommand]
|
|
' A string the represents what this procedure should do. It is intended
|
|
' be used to case and call an appropriate procedure in response if this
|
|
' was a real solution service provider. This object expects either
|
|
' "UseProcessor" or "DontUserProcessor".
|
|
' [vServiceData]
|
|
' This object expects a variant array or variant collection in which
|
|
' the elements of the array or collection specify how much data to
|
|
' return, what type of data to return, and how long to wait before
|
|
' releasing the calling worker.
|
|
'Out:
|
|
' [vReturn]
|
|
' This could be a variant array or collection of any specified size
|
|
' it will be returned by the calling worker to the client or the
|
|
' expediter
|
|
'-------------------------------------------------------------------------
|
|
'sCommand What to do. Ex: "Method"
|
|
'vServiceData The data needed to carrry out sCommand.
|
|
Dim iLensCommand As Integer
|
|
Dim iChar As Integer
|
|
Dim iLastChar As Integer
|
|
Dim lEndTicks As Long
|
|
Dim lRecordNumRows As Long
|
|
Dim lRecordRowSize As Long
|
|
Dim lRecordTaskDuration As Long, lRecordSleepPeriod As Long
|
|
Dim lRecordContainerType As Long
|
|
Dim sRecordDatabaseQuery As String
|
|
Dim rsService As Recordset
|
|
Dim s As String
|
|
Dim i As Integer
|
|
Dim v() As Variant
|
|
|
|
msServiceID = sServiceID
|
|
On Error GoTo Service_ExecuteError
|
|
If Not IsMissing(vServiceData) Then
|
|
'Are we using a Varriant Array or Collection?
|
|
If VarType(vServiceData) = (vbArray + vbVariant) Then
|
|
'It's an array
|
|
lRecordNumRows = vServiceData(giRECORD_NUMROWS)
|
|
lRecordRowSize = vServiceData(giRECORD_ROWSIZE)
|
|
lRecordTaskDuration = vServiceData(giRECORD_TASK_DURATION)
|
|
lRecordSleepPeriod = vServiceData(giRECORD_SLEEP_PERIOD)
|
|
lRecordContainerType = vServiceData(giRECORD_CONTAINER_TYPE)
|
|
sRecordDatabaseQuery = vServiceData(giRECORD_DATABASE_QUERY)
|
|
mvServiceConfiguration = vServiceData(giRECORD_SERVICE_CONFIGURATION)
|
|
Else
|
|
'It's a collection
|
|
lRecordNumRows = vServiceData.Item(CStr(giRECORD_NUMROWS))
|
|
lRecordRowSize = vServiceData.Item(CStr(giRECORD_ROWSIZE))
|
|
lRecordTaskDuration = vServiceData.Item(CStr(giRECORD_TASK_DURATION))
|
|
lRecordSleepPeriod = vServiceData.Item(CStr(giRECORD_SLEEP_PERIOD))
|
|
lRecordContainerType = vServiceData.Item(CStr(giRECORD_CONTAINER_TYPE))
|
|
sRecordDatabaseQuery = vServiceData.Item(CStr(giRECORD_DATABASE_QUERY))
|
|
mvServiceConfiguration = vServiceData.Item(CStr(giRECORD_SERVICE_CONFIGURATION))
|
|
End If
|
|
'Do we need to do anything?
|
|
If lRecordTaskDuration < 0 Or lRecordTaskDuration > glMAX_DURATION Then Err.Raise giBAD_DURATION
|
|
End If
|
|
|
|
Dim iCommand As Integer
|
|
iCommand = CInt(sCommand)
|
|
|
|
If (iCommand And giMASK_USE_CPU_TASK) Then 'If use processor always
|
|
If lRecordTaskDuration > 0 Then
|
|
lEndTicks = GetTickCount() + lRecordTaskDuration
|
|
Do While lEndTicks > GetTickCount()
|
|
'Using Cycles
|
|
Loop
|
|
End If
|
|
If lRecordSleepPeriod > 0 Then
|
|
Sleep lRecordSleepPeriod
|
|
End If
|
|
End If
|
|
|
|
If (iCommand And giMASK_USE_DB_TASK) Then 'If a database task
|
|
On Error GoTo 0 ' Do not trap MTS errors or PerformQuery errors.
|
|
If (iCommand And giMASK_WRITE_MTS_TRANSACTION) <> 0 Then
|
|
WriteMTSTransaction mvServiceConfiguration(ape_conConnectionString), mvServiceConfiguration(ape_conConnectionOption)
|
|
Else ' Perform query
|
|
PerformQuery sRecordDatabaseQuery
|
|
End If
|
|
On Error GoTo Service_ExecuteError
|
|
End If
|
|
|
|
If (Not IsMissing(vReturn)) And lRecordContainerType <> giCONTAINER_TYPE_NULL And lRecordNumRows <> 0 And lRecordRowSize <> 0 Then
|
|
'Return something
|
|
Select Case lRecordContainerType
|
|
Case giCONTAINER_TYPE_VARRAY
|
|
s = Space(lRecordRowSize)
|
|
ReDim v(lRecordNumRows - 1) As Variant
|
|
For i = 0 To lRecordNumRows - 1
|
|
v(i) = s
|
|
Next i
|
|
vReturn = v
|
|
Case giCONTAINER_TYPE_VCOLLECTION
|
|
Set vReturn = New Collection
|
|
s = Space(lRecordRowSize)
|
|
For i = 1 To lRecordNumRows
|
|
vReturn.Add s
|
|
Next i
|
|
Case giCONTAINER_TYPE_RECORDSET
|
|
'Not yet implemented
|
|
Set vReturn = Nothing
|
|
Case Else
|
|
'Some unknown ContainterTypeValue
|
|
Err.Raise giBAD_DATA_TYPE
|
|
End Select
|
|
End If
|
|
Exit Sub
|
|
|
|
Service_ExecuteError:
|
|
Dim lErrorNumber As Long
|
|
Dim sErrorDescription As String
|
|
lErrorNumber = Err.Number
|
|
sErrorDescription = Err.Description
|
|
Select Case lErrorNumber
|
|
Case ERR_TYPE_MISMATCH, ERR_OVER_FLOW
|
|
'vServiceData contained a bad data type. Raise an appliction defined error.
|
|
Err.Raise giBAD_DATA, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, LoadResString(giBAD_DATA))
|
|
Case giBAD_DURATION
|
|
'They wanted to sleep more than glMAX_DURATION
|
|
Err.Raise lErrorNumber, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, _
|
|
ReplaceString(LoadResString(giBAD_DURATION), gsNUMBER_TOKEN, CStr(glMAX_DURATION)))
|
|
Case Is > giERROR_THRESHOLD
|
|
'Application defined error. Since this is the only public method
|
|
'all errors raised there will be returned to the calling program.
|
|
Err.Raise lErrorNumber + vbObjectError, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, sErrorDescription)
|
|
Case Else
|
|
'VB error
|
|
Err.Raise lErrorNumber, msERROR_SOURCE, NestedErrorDescription(giERROR_EXECUTE_METHOD, sErrorDescription)
|
|
End Select
|
|
End Sub
|
|
|
|
Public Sub IService_Initialize(vServiceConfiguration As Variant)
|
|
|
|
' If a connection is already open, then close it (object is being reinitialized)
|
|
If Not IsEmpty(mvServiceConfiguration) Then
|
|
If (mvServiceConfiguration(ape_conConnectionOption) <> vServiceConfiguration(ape_conConnectionOption) Or _
|
|
mvServiceConfiguration(ape_conConnectionString) <> vServiceConfiguration(ape_conConnectionString)) Then
|
|
Debug.Assert mbConnectionOpen
|
|
Select Case mvServiceConfiguration(ape_conConnectionOption)
|
|
Case ape_idcODBC
|
|
SQLFreeHandle SQL_HANDLE_STMT, mhStatement
|
|
SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_COMMIT
|
|
SQLDisconnect mhConnection
|
|
Case Else
|
|
If Not moConnection Is Nothing Then
|
|
moConnection.Close
|
|
Set moConnection = Nothing
|
|
End If
|
|
End Select
|
|
mbConnectionOpen = False
|
|
End If
|
|
End If
|
|
mvServiceConfiguration = vServiceConfiguration
|
|
' Open a connection if a connection string is specified
|
|
If Not (mbConnectionOpen Or IsEmpty(mvServiceConfiguration(ape_conConnectionString))) Then
|
|
OpenServiceConnection
|
|
mbConnectionOpen = True
|
|
End If
|
|
mbLogMTSTransactions = mvServiceConfiguration(ape_conLogMTSTransactions)
|
|
If mbShowMTSTransactions <> mvServiceConfiguration(ape_conShowMTSTransactions) Then
|
|
mbShowMTSTransactions = mvServiceConfiguration(ape_conShowMTSTransactions)
|
|
If mbShowMTSTransactions Then
|
|
frmService.Show
|
|
Else
|
|
Unload frmService
|
|
End If
|
|
End If
|
|
mbLogDatabaseEvents = mvServiceConfiguration(ape_conLogDatabaseEvents)
|
|
frmService.Reset
|
|
End Sub
|
|
|
|
Private Sub ExecuteADOCommand(sQuery As String)
|
|
Dim conConnection As ADODB.Connection
|
|
Dim rsRecordset As New ADODB.Recordset
|
|
Dim s As String
|
|
Dim lErrorNumber As Long
|
|
Dim sa() As String
|
|
Dim iRetries As Integer
|
|
|
|
iRetries = 0
|
|
On Error GoTo ADOTransactionError
|
|
Set conConnection = moConnection
|
|
|
|
' Get array of queries
|
|
If GetArrayFromDelimited(sQuery, sa, "//") Then
|
|
TryAgain:
|
|
conConnection.BeginTrans
|
|
Dim i As Integer
|
|
For i = LBound(sa) To UBound(sa)
|
|
If Left(sa(i), 6) = "SELECT" Then
|
|
' Only SELECT queries return records
|
|
rsRecordset.Open sa(i), conConnection, adOpenKeyset ' Default CursorType (adOpenForwardOnly) doesn't support MoveLast
|
|
rsRecordset.MoveFirst
|
|
Do While Not rsRecordset.EOF
|
|
rsRecordset.MoveNext
|
|
Loop
|
|
rsRecordset.Close
|
|
Else
|
|
conConnection.Execute sa(i)
|
|
End If
|
|
Next
|
|
conConnection.CommitTrans
|
|
End If
|
|
Exit Sub
|
|
|
|
ADOTransactionError:
|
|
' If the error is due to a locking contention, roll back the transaction and try again
|
|
If Err.Number = -2147467259 And iRetries < giMAX_ALLOWED_RETRIES Then
|
|
conConnection.RollbackTrans
|
|
iRetries = iRetries + 1
|
|
Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions
|
|
Resume TryAgain
|
|
End If
|
|
Dim sErrorDescription As String
|
|
sErrorDescription = Err.Description
|
|
lErrorNumber = Err.Number
|
|
conConnection.RollbackTrans
|
|
Err.Raise lErrorNumber, , sErrorDescription
|
|
End Sub
|
|
|
|
Private Sub ExecuteRDOCommand(sQuery As String)
|
|
Dim conConnection As rdoConnection
|
|
Dim rsResultset As rdoResultset
|
|
Dim s As String
|
|
Dim lErrorNumber As Long
|
|
Dim sa() As String
|
|
Dim iRetries As Integer
|
|
|
|
iRetries = 0
|
|
On Error GoTo RDOTransactionError
|
|
|
|
Set conConnection = moConnection
|
|
If GetArrayFromDelimited(sQuery, sa, "//") Then
|
|
TryAgain:
|
|
conConnection.BeginTrans
|
|
Dim i As Integer
|
|
For i = LBound(sa) To UBound(sa)
|
|
If Left(sa(i), 6) = "SELECT" Then
|
|
' Only SELECT queries return records
|
|
Set rsResultset = conConnection.OpenResultset(sa(i), dbOpenDynaset)
|
|
rsResultset.MoveFirst
|
|
Do While Not rsResultset.EOF
|
|
rsResultset.MoveNext
|
|
Loop
|
|
rsResultset.Close
|
|
Else
|
|
conConnection.Execute sa(i)
|
|
End If
|
|
Next
|
|
conConnection.CommitTrans
|
|
End If
|
|
Exit Sub
|
|
|
|
RDOTransactionError:
|
|
' If the error is due to a locking contention, roll back the transaction and try again
|
|
If Err.Number = 40002 And iRetries < giMAX_ALLOWED_RETRIES Then
|
|
' First make sure the cause really is a locking contention
|
|
' Determine which database-specific error number to check for
|
|
Select Case mDBType
|
|
Case ape_idsJet
|
|
lErrorNumber = -1102
|
|
Case ape_idsSqlServer
|
|
lErrorNumber = 1205
|
|
Case Else
|
|
Err.Raise E_NOTIMPL
|
|
End Select
|
|
Dim RDOErr As RDO.rdoError
|
|
For Each RDOErr In rdoEngine.rdoErrors
|
|
If RDOErr.Number = lErrorNumber Then
|
|
conConnection.RollbackTrans
|
|
iRetries = iRetries + 1
|
|
Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions
|
|
Resume TryAgain
|
|
End If
|
|
Next
|
|
End If
|
|
Dim sErrorDescription As String
|
|
sErrorDescription = Err.Description
|
|
lErrorNumber = Err.Number
|
|
conConnection.RollbackTrans
|
|
Err.Raise lErrorNumber, , sErrorDescription
|
|
End Sub
|
|
|
|
Private Sub ExecuteDAOCommand(sQuery As String)
|
|
Dim rsRecordset As DAO.Recordset
|
|
Dim s As String
|
|
Dim lErrorNumber As Long
|
|
Dim sa() As String
|
|
Dim iRetries As Integer
|
|
|
|
iRetries = 0
|
|
On Error GoTo DAOTransactionError
|
|
|
|
If GetArrayFromDelimited(sQuery, sa, "//") Then
|
|
TryAgain:
|
|
moWorkspace.BeginTrans
|
|
Dim i As Integer
|
|
For i = LBound(sa) To UBound(sa)
|
|
If Left(sa(i), 6) = "SELECT" Then
|
|
' Only SELECT queries return records
|
|
Set rsRecordset = moDatabase.OpenRecordset(sa(i), dbOpenDynaset, dbSQLPassThrough)
|
|
rsRecordset.MoveFirst
|
|
Do While Not rsRecordset.EOF
|
|
rsRecordset.MoveNext
|
|
Loop
|
|
rsRecordset.Close
|
|
Else
|
|
moDatabase.Execute sa(i), dbSQLPassThrough
|
|
End If
|
|
Next
|
|
moWorkspace.CommitTrans
|
|
End If
|
|
Exit Sub
|
|
|
|
DAOTransactionError:
|
|
' If the error is due to a locking contention, roll back the transaction and try again
|
|
If Err.Number = 3146 And iRetries < giMAX_ALLOWED_RETRIES Then
|
|
' First make sure the cause really is a locking contention
|
|
' Determine which database-specific error number to check for
|
|
Select Case mDBType
|
|
Case ape_idsJet
|
|
lErrorNumber = -1102
|
|
Case ape_idsSqlServer
|
|
lErrorNumber = 1205
|
|
Case Else
|
|
Err.Raise E_NOTIMPL
|
|
End Select
|
|
Dim DAOErr As DAO.Error
|
|
For Each DAOErr In DBEngine.Errors
|
|
If DAOErr.Number = lErrorNumber Then
|
|
moWorkspace.Rollback
|
|
iRetries = iRetries + 1
|
|
Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions
|
|
Resume TryAgain
|
|
End If
|
|
Next
|
|
End If
|
|
Dim sErrorDescription As String
|
|
sErrorDescription = Err.Description
|
|
lErrorNumber = Err.Number
|
|
moWorkspace.Rollback
|
|
Err.Raise lErrorNumber, , sErrorDescription
|
|
End Sub
|
|
|
|
Private Sub ExecuteODBCAPICommand(sQuery As String)
|
|
Dim lErrorNumber As Long
|
|
Dim sa() As String
|
|
Dim iRetries As Integer
|
|
|
|
iRetries = 0
|
|
On Error GoTo ODBCAPITransactionError
|
|
|
|
If GetArrayFromDelimited(sQuery, sa, "//") Then
|
|
TryAgain:
|
|
Dim i As Integer
|
|
For i = LBound(sa) To UBound(sa)
|
|
If Left(sa(i), 6) = "SELECT" Then
|
|
' Only SELECT queries return records
|
|
If Not ODBCAPICallSuccessful(SQLExecDirect(mhStatement, sa(i), Len(sa(i)))) Then
|
|
Err.Raise ErrorExecuteQuery, , LoadResString(ErrorExecuteQuery)
|
|
End If
|
|
Dim bEOF As Boolean
|
|
Select Case SQLFetchScroll(mhStatement, SQL_FETCH_FIRST, 0)
|
|
Case SQL_NO_DATA
|
|
bEOF = True
|
|
Case SQL_SUCCESS, SQL_SUCCESS_WITH_INFO
|
|
bEOF = False
|
|
Case Else
|
|
SQLCloseCursor mhStatement
|
|
Err.Raise ErrorFetchRecord, , LoadResString(ErrorFetchRecord)
|
|
End Select
|
|
Do While Not bEOF
|
|
Select Case SQLFetchScroll(mhStatement, SQL_FETCH_NEXT, 0)
|
|
Case SQL_NO_DATA
|
|
bEOF = True
|
|
Case SQL_SUCCESS, SQL_SUCCESS_WITH_INFO
|
|
bEOF = False
|
|
Case Else
|
|
SQLCloseCursor mhStatement
|
|
Err.Raise ErrorFetchRecord, , LoadResString(ErrorFetchRecord)
|
|
End Select
|
|
Loop
|
|
SQLCloseCursor mhStatement
|
|
Else
|
|
If Not ODBCAPICallSuccessful(SQLExecDirect(mhStatement, sa(i), Len(sa(i)))) Then
|
|
Err.Raise ErrorExecuteQuery, , LoadResString(ErrorExecuteQuery)
|
|
End If
|
|
End If
|
|
Next
|
|
If Not ODBCAPICallSuccessful(SQLEndTran(SQL_HANDLE_DBC, mhConnection, SQL_COMMIT)) Then
|
|
Err.Raise ErrorEndTransaction, , LoadResString(ErrorEndTransaction)
|
|
End If
|
|
End If
|
|
Exit Sub
|
|
|
|
ODBCAPITransactionError:
|
|
' If the error is due to a resource deadlock, roll back the transaction and try again
|
|
If Err.Number = ErrorExecuteQuery And iRetries < giMAX_ALLOWED_RETRIES Then
|
|
Dim iRecNum As Integer, iTextLen As Integer
|
|
Dim sSQLState As String * 5, sMsgText As String * 1
|
|
Dim lNativeErrorPtr As Long
|
|
iRecNum = 1
|
|
Do While ODBCAPICallSuccessful(SQLGetDiagRec(SQL_HANDLE_STMT, mhStatement, iRecNum, sSQLState, lNativeErrorPtr, _
|
|
sMsgText, 0, iTextLen))
|
|
If sSQLState = "40001" Then
|
|
SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_ROLLBACK
|
|
iRetries = iRetries + 1
|
|
Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions
|
|
Resume TryAgain
|
|
End If
|
|
iRecNum = iRecNum + 1
|
|
Loop
|
|
End If
|
|
Dim sErrorDescription As String
|
|
sErrorDescription = Err.Description
|
|
lErrorNumber = Err.Number
|
|
SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_ROLLBACK
|
|
Err.Raise lErrorNumber, , sErrorDescription
|
|
End Sub
|
|
|
|
Private Sub PerformQuery(sRecordDatabaseQuery As String)
|
|
' Performs the database queries
|
|
Dim bConnectionOpenedInExecute As Boolean
|
|
|
|
On Error GoTo PerformQueryError
|
|
bConnectionOpenedInExecute = False
|
|
If mbLogDatabaseEvents Then
|
|
LogEvent giBEGIN_DATABASE_QUERY, msServiceID
|
|
End If
|
|
If Not mbConnectionOpen Then
|
|
On Error GoTo 0 ' Do not trap OpenServiceConnection errors.
|
|
OpenServiceConnection
|
|
On Error GoTo PerformQueryError
|
|
bConnectionOpenedInExecute = True
|
|
End If
|
|
ParseQuery sRecordDatabaseQuery
|
|
If mvServiceConfiguration(ape_conConnectionOption) = ape_idcODBC Then
|
|
ExecuteODBCAPICommand (sRecordDatabaseQuery)
|
|
If bConnectionOpenedInExecute Then
|
|
If Not ODBCAPICallSuccessful(SQLFreeHandle(SQL_HANDLE_STMT, mhStatement)) Then
|
|
Err.Raise ErrorFreeHandle, , LoadResString(ErrorFreeHandle)
|
|
End If
|
|
If Not ODBCAPICallSuccessful(SQLEndTran(SQL_HANDLE_DBC, mhConnection, SQL_COMMIT)) Then
|
|
Err.Raise ErrorEndTransaction, , LoadResString(ErrorEndTransaction)
|
|
End If
|
|
If Not ODBCAPICallSuccessful(SQLDisconnect(mhConnection)) Then
|
|
Err.Raise ErrorDisconnectDriver, , LoadResString(ErrorDisconnectDriver)
|
|
End If
|
|
End If
|
|
Else
|
|
Select Case mvServiceConfiguration(ape_conConnectionOption)
|
|
Case ape_idcADO
|
|
ExecuteADOCommand (sRecordDatabaseQuery)
|
|
Case ape_idcRDO
|
|
ExecuteRDOCommand (sRecordDatabaseQuery)
|
|
Case ape_idcDAO
|
|
ExecuteDAOCommand (sRecordDatabaseQuery)
|
|
Case Else
|
|
Err.Raise E_NOTIMPL
|
|
End Select
|
|
If bConnectionOpenedInExecute And Not moConnection Is Nothing Then
|
|
moConnection.Close
|
|
bConnectionOpenedInExecute = False
|
|
End If
|
|
End If
|
|
If mbLogDatabaseEvents Then
|
|
LogEvent giEND_DATABASE_QUERY, msServiceID
|
|
End If
|
|
Exit Sub
|
|
|
|
PerformQueryError:
|
|
Dim lErrorNumber As Long
|
|
Dim sErrorDescription As String
|
|
lErrorNumber = Err.Number
|
|
sErrorDescription = Err.Description
|
|
If bConnectionOpenedInExecute Then
|
|
Select Case mvServiceConfiguration(ape_conConnectionOption)
|
|
Case ape_idcODBC
|
|
SQLFreeHandle SQL_HANDLE_STMT, mhStatement
|
|
SQLEndTran SQL_HANDLE_DBC, mhConnection, SQL_COMMIT
|
|
SQLDisconnect mhConnection
|
|
Case Else
|
|
If Not moConnection Is Nothing Then
|
|
moConnection.Close
|
|
End If
|
|
End Select
|
|
End If
|
|
Err.Raise lErrorNumber, msERROR_SOURCE, NestedErrorDescription(giERROR_PERFORM_DATABASE_QUERY, sErrorDescription)
|
|
End Sub
|
|
|
|
Private Sub WriteMTSTransaction(ByVal sConnect As String, ByVal eConnectOptions As ape_DbConnectionOptions)
|
|
' Create the appropriate MoveMoney object
|
|
Dim objMoveMoney As APEInterfaces.IMTSMoveMoney
|
|
|
|
Const miMinQueryRetryDelay As Integer = 20 ' Min delay (ms) between retries of a query that failed due to a locking contention
|
|
Const miMaxQueryRetryDelay As Integer = 100 ' Max delay (ms) between retries of a query that failed due to a locking contention
|
|
Const miMAX_ALLOWED_RETRIES As Integer = 500 ' Maximum number of retries of a query that failed due to a locking contention
|
|
|
|
Dim iTransferRetries As Integer
|
|
iTransferRetries = 0
|
|
|
|
On Error GoTo ErrorHandler
|
|
Set objMoveMoney = CreateObject("AEMTSSvc.MoveMoney")
|
|
If mbLogMTSTransactions Then
|
|
LogEvent giBEGIN_MTS_TRANSACTION, msServiceID
|
|
End If
|
|
|
|
Const iMAX_ACCOUNT_NO = 1000 ' Highest account number (1 is presumed to be the lowest)
|
|
Dim lFromAccount As Long, lToAccount As Long
|
|
lFromAccount = 1 + Int(iMAX_ACCOUNT_NO * Rnd)
|
|
lToAccount = 1 + Int(iMAX_ACCOUNT_NO * Rnd)
|
|
objMoveMoney.Transfer sConnect, eConnectOptions, lFromAccount, lToAccount, 1
|
|
|
|
If mbLogMTSTransactions Then
|
|
LogEvent giEND_MTS_TRANSACTION_SUCCEEDED, msServiceID
|
|
End If
|
|
|
|
If mbShowMTSTransactions Then
|
|
frmService.MTSResults True
|
|
End If
|
|
Exit Sub
|
|
|
|
ErrorHandler:
|
|
' If the error is due to a locking contention, try again
|
|
If iTransferRetries < miMAX_ALLOWED_RETRIES Then
|
|
Dim bRetry As Boolean
|
|
bRetry = False
|
|
Select Case eConnectOptions
|
|
Case ape_idcADO
|
|
bRetry = (Err.Number = -2147467259)
|
|
Case ape_idcDAO
|
|
If Err.Number = 3146 Then
|
|
' First make sure the cause really is a locking contention
|
|
Dim DAOErr As DAO.Error
|
|
For Each DAOErr In DBEngine.Errors
|
|
If DAOErr.Number = 1205 Then ' 1205 = SQL Server record locking contention
|
|
bRetry = True
|
|
End If
|
|
Next
|
|
End If
|
|
Case ape_idcRDO
|
|
If Err.Number = 40002 Then
|
|
' First make sure the cause really is a locking contention
|
|
Dim RDOErr As RDO.rdoError
|
|
For Each RDOErr In rdoEngine.rdoErrors
|
|
If RDOErr.Number = 1205 Then ' 1205 = SQL Server record locking contention
|
|
bRetry = True
|
|
End If
|
|
Next
|
|
End If
|
|
Case ape_idcODBC
|
|
bRetry = (Err.Number = ErrorResourceDeadlock)
|
|
End Select
|
|
If bRetry Then
|
|
iTransferRetries = iTransferRetries + 1
|
|
Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd ' Randomize the delay to avoid repeated contentions
|
|
DoEvents
|
|
Resume
|
|
End If
|
|
End If
|
|
Dim lErrorNumber As Long
|
|
Dim sErrorSource As String
|
|
Dim sErrorDescription As String
|
|
lErrorNumber = Err.Number
|
|
sErrorSource = Err.Source
|
|
If Err.Number = ERR_CANT_CREATE_OBJECT Then
|
|
sErrorDescription = LoadResString(giERROR_CREATE_MTS_OBJECT)
|
|
Else
|
|
sErrorDescription = Err.Description
|
|
End If
|
|
If mbLogMTSTransactions Then
|
|
LogEvent giEND_MTS_TRANSACTION_FAILED, msServiceID
|
|
End If
|
|
If mbShowMTSTransactions Then
|
|
frmService.MTSResults False
|
|
End If
|
|
Err.Raise lErrorNumber, sErrorSource, sErrorDescription
|
|
End Sub
|
|
|
|
Private Sub OpenServiceConnection()
|
|
Debug.Assert Not IsEmpty(mvServiceConfiguration) ' mvServiceConfiguration must be set before calling this method
|
|
' Make the current directory the app path (usually starts out being the Windows System[32] directory) which is where the
|
|
' Jet database is stored.
|
|
On Error GoTo ErrorHandler
|
|
ChDir App.Path
|
|
ChDrive App.Path
|
|
' Set the database type
|
|
If InStr(mvServiceConfiguration(ape_conConnectionString), "DRIVER={" & msSQLServerDriver & "}") > 0 Then
|
|
mDBType = ape_idsSqlServer
|
|
ElseIf InStr(mvServiceConfiguration(ape_conConnectionString), "DRIVER={" & msAccessDriver & "}") > 0 Then
|
|
mDBType = ape_idsJet
|
|
Else
|
|
Err.Raise E_NOTIMPL
|
|
End If
|
|
Select Case mvServiceConfiguration(ape_conConnectionOption)
|
|
Case ape_idcADO
|
|
Set moConnection = New ADODB.Connection
|
|
moConnection.Open mvServiceConfiguration(ape_conConnectionString)
|
|
Case ape_idcRDO
|
|
Set moWorkspace = rdoEngine.rdoEnvironments(0)
|
|
Set moConnection = moWorkspace.OpenConnection("", rdDriverNoPrompt, , _
|
|
mvServiceConfiguration(ape_conConnectionString))
|
|
Case ape_idcDAO
|
|
Set moWorkspace = DBEngine.Workspaces(0)
|
|
' Special handling is required for Jet databases
|
|
If mDBType = ape_idsJet Then
|
|
Set moDatabase = DBEngine.OpenDatabase(msJetDBName, False, False)
|
|
Else
|
|
Set moDatabase = DBEngine.OpenDatabase("", False, False, "ODBC;" & mvServiceConfiguration(ape_conConnectionString))
|
|
End If
|
|
Case ape_idcODBC
|
|
Dim iConnectLength As Integer
|
|
If Not ODBCAPICallSuccessful(SQLDriverConnect(mhConnection, 0, mvServiceConfiguration(ape_conConnectionString), _
|
|
LenB(mvServiceConfiguration(ape_conConnectionString)), vbNullString, 0, iConnectLength, SQL_DRIVER_NOPROMPT)) Then
|
|
Err.Raise ErrorConnectDriver, , LoadResString(ErrorConnectDriver)
|
|
End If
|
|
If Not ODBCAPICallSuccessful(SQLAllocHandle(SQL_HANDLE_STMT, mhConnection, mhStatement)) Then
|
|
SQLDisconnect mhConnection
|
|
Err.Raise ErrorAllocateHandle, , LoadResString(ErrorAllocateHandle)
|
|
End If
|
|
If Not ODBCAPICallSuccessful(SQLSetStmtAttrLong(mhStatement, SQL_CURSOR_TYPE, SQL_CURSOR_STATIC, 0)) Then
|
|
SQLFreeHandle SQL_HANDLE_STMT, mhStatement
|
|
SQLDisconnect mhConnection
|
|
Err.Raise ErrorSetAttribute, , LoadResString(ErrorSetAttribute)
|
|
End If
|
|
Case Else
|
|
Err.Raise E_NOTIMPL
|
|
End Select
|
|
Exit Sub
|
|
|
|
ErrorHandler:
|
|
Err.Raise Err.Number, msERROR_SOURCE, NestedErrorDescription(giERROR_OPENING_SERVICE_CONNECTION, Err.Description)
|
|
End Sub
|
|
|
|
Private Sub Class_Initialize()
|
|
Randomize
|
|
mbConnectionOpen = False
|
|
mbLogMTSTransactions = False
|
|
mbShowMTSTransactions = False
|
|
|
|
If Not ODBCAPICallSuccessful(SQLAllocHandle(SQL_HANDLE_ENV, SQL_NULL_HANDLE, mhEnvironment)) Then
|
|
Err.Raise ErrorAllocateHandle, , LoadResString(ErrorAllocateHandle)
|
|
End If
|
|
If Not ODBCAPICallSuccessful(SQLSetEnvAttrLong(mhEnvironment, SQL_ATTR_ODBC_VERSION, SQL_OV_ODBC3, 0)) Then
|
|
SQLFreeHandle SQL_HANDLE_ENV, mhEnvironment
|
|
Err.Raise ErrorSetAttribute, , LoadResString(ErrorSetAttribute)
|
|
End If
|
|
If Not ODBCAPICallSuccessful(SQLAllocHandle(SQL_HANDLE_DBC, mhEnvironment, mhConnection)) Then
|
|
SQLFreeHandle SQL_HANDLE_ENV, mhEnvironment
|
|
Err.Raise ErrorAllocateHandle, , LoadResString(ErrorAllocateHandle)
|
|
End If
|
|
End Sub
|
|
|
|
Private Sub Class_Terminate()
|
|
On Error Resume Next
|
|
Unload frmService
|
|
If mbConnectionOpen Then
|
|
Select Case mvServiceConfiguration(ape_conConnectionOption)
|
|
Case ape_idcODBC
|
|
SQLDisconnect mhConnection
|
|
Case ape_idcDAO
|
|
moDatabase.Close
|
|
Case Else
|
|
moConnection.Close
|
|
End Select
|
|
End If
|
|
|
|
SQLFreeHandle SQL_HANDLE_DBC, mhConnection
|
|
SQLFreeHandle SQL_HANDLE_ENV, mhEnvironment
|
|
End Sub
|
|
|