LBdianziqianming/cadVb/COMMON/TOOLS/APE/SOURCE/AECLIENT/CLSPOOTL.CLS

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsPoolTestTool"
Attribute VB_GlobalNameSpace = True
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'-------------------------------------------------------------------------
'This class provides a RunTest method to be called to run a Pool
'Management model test.
'-------------------------------------------------------------------------

Public Sub RunTest()
    '-------------------------------------------------------------------------
    'Purpose:   Executes a loop for glNumberOfCalls each time calling
    '           AEWorker.Worker.DoActivity.  Before each call a Worker
    '           is Requested from AEPoolMgr.Pool after each call the
    '           Worker is released and PoolMgr is called again to
    '           notify of release.  This method actually runs
    '           a test according to set properties
    'Assumes:   All Client properties have been set.
    'Effects:
    '           Calls CompleteTest when finished calling Worker
    '   [gbRunning]
    '           Is true during procedure
    '   [glFirstServiceTick]
    '           becomes the tick count of when the test is started
    '   [glLastCallbackTick]
    '           becomes the tick count of when the last call is made
    '   [glCallsMade]
    '           is incremented every time the Worker is called
    ' Exceptions:
    '   If only an MTS transaction is being performed, the MTS, not APE's
    '   Pool Manager, provides the pool management services.
    '-------------------------------------------------------------------------
    
    'Called by tmrStartTest so that the StartTest method can release
    'the calling program.
    
    Const lMAX_COUNT = 2147483647
    Dim s As String         'Error message
    Dim sServiceID As String  'Service Request ID
    Dim lTicks As Long      'Tick Count
    Dim lEndTick As Long    'DoEvents loop until this Tick Count
    Dim lCallNumber As Long 'Number of calls to Worker
    Dim lNumberOfCalls As Long      'Test duration in number of calls
    Dim iDurationMode As Integer    'Test duration mode
    Dim lDurationTicksEnd As Long   'Tick that test should end on
    Dim bPostingServices As Boolean 'In main loop of procedure
    Dim iRetry As Integer           'Number of call reties made by error handling resume
    Dim vSendData As Variant        'Data to send with Service request
    Dim bRandomSendData As Boolean  'If true vSendData needs generated before each new request
    Dim sSendCommand As String      'Command string to be sent with Service Request
    Dim bRandomCommand As Boolean   'If true sSendCommand needs generated before each new request
    Dim lCallWait As Long           'Number of ticks to wait between calls
    Dim bRandomWait As Boolean      'If true lCallWait needs generated before each new request
    Dim bSendSomething As Boolean    'If true data needs passed with request
    Dim bReceiveSomething As Boolean 'If true data is expected back from request
    Dim oWorker As APEInterfaces.IWorker  'Local reference to the Worker
    Dim oPool As APEInterfaces.IPool
    Dim bLog As Boolean             'If true log records
    Dim bShow As Boolean            'If true update display
    Dim iPoolWaitRetryCount As Integer  'Number of times retry is need for each call loop
    Dim bReleaseWorker As Boolean       ' If True, the worker needs to be released before leaving the procedure
    
    bReleaseWorker = False
    
    On Error GoTo RunTestError
    'If there is reentry by a timer click exit sub
    If gbRunning Then Exit Sub
    gbRunning = True
    
    ' If only an MTS transaction is being performed, use MTS as pool manager
    If (giServiceTask = (giMASK_USE_DB_TASK Or giMASK_WRITE_MTS_TRANSACTION)) Then
        RunMTSTest
        Exit Sub
    End If
    
    'Set the local variables to direct the testing
    Set oPool = CreateObject("AEPoolMgr.Pool")
    
    bRandomSendData = GetTestData(bSendSomething, bReceiveSomething, vSendData)
    lCallWait = GetValueFromRange(gudtWaitPeriod, bRandomWait)
    sSendCommand = GetServiceCommand(bRandomCommand)
    bLog = gbLog
    bShow = gbShow
    
    s = LoadResString(giTEST_STARTED)
    If bLog Then AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
    DisplayStatus s
    glFirstServiceTick = GetTickCount()
    glLastCallbackTick = glFirstServiceTick     ' If 0 calls are completed, the time spent will be 0 ticks
    
    'Test duration variables
    iDurationMode = giTestDurationMode
    If iDurationMode = giTEST_DURATION_CALLS Then
        lNumberOfCalls = glNumberOfCalls
    ElseIf iDurationMode = giTEST_DURATION_TICKS Then
        lDurationTicksEnd = glFirstServiceTick + glTestDurationInTicks
    End If
    
    bPostingServices = True
    Do While Not gbStopping
        'Check if new data needs generated because of randomization
        If bRandomSendData Then bRandomSendData = GetTestData(bSendSomething, bReceiveSomething, vSendData)
        If bRandomWait Then lCallWait = GetValueFromRange(gudtWaitPeriod, bRandomWait)
        If bRandomCommand Then sSendCommand = GetServiceCommand(bRandomCommand)
        
        'Increment number of calls made
        lCallNumber = glCallsMade + 1
        'Get a Worker from the PoolMgr
        'Post the service to a worker
        'Post a synchronous service
        sServiceID = glClientID & "." & lCallNumber
        iRetry = 0
        iPoolWaitRetryCount = 0
RunTest_GetWorkerRetry:
        Set oWorker = oPool.GetWorker
        'Pool Manager may reject request for worker
        'If it does wait sometime and retry
        If oWorker Is Nothing Then GoTo RunTest_WaitForPool
        bReleaseWorker = True
        iRetry = 0
        iPoolWaitRetryCount = 0
        'Display CallsMade
        If bShow Then
            With frmClient
                .lblCallsMade = lCallNumber
                .lblCallsMade.Refresh
            End With
        End If
        If bSendSomething Then
            oWorker.DoService sServiceID, sSendCommand, vSendData
        Else
            oWorker.DoService sServiceID, sSendCommand
        End If
        glLastCallbackTick = GetTickCount
        Set oWorker = Nothing
        oPool.ReleaseWorker
        bReleaseWorker = False
        
        'Display CallsReturned
        If bShow Then
            With frmClient
                .lblCallsReturned = lCallNumber
                .lblCallsReturned.Refresh
            End With
        End If
        'If gbStopping Then Exit Do
        'Go into an idle loop util the next call.
        If lCallWait > 0 Then
            lEndTick = GetTickCount + lCallWait
            Do While GetTickCount() < lEndTick And Not gbStopping
                DoEvents
            Loop
        End If
        glCallsMade = lCallNumber
        glCallsReturned = lCallNumber
        
        'See if it is time to stop the test
        If iDurationMode = giTEST_DURATION_CALLS Then
            If lCallNumber >= lNumberOfCalls Then Exit Do
        ElseIf iDurationMode = giTEST_DURATION_TICKS Then
            If GetTickCount >= lDurationTicksEnd Then Exit Do
        End If
    Loop
StopTestNow:
    bPostingServices = False
    gbRunning = False
    Set oWorker = Nothing
    If gbStopping Then
        'Someone hit the stop button on the Explorer.
        gStopTest
        GoTo CleanupAndExit
    End If
    If bLog Then AddLogRecord gsNULL_SERVICE_ID, LoadResString(giSERVICES_POSTED), GetTickCount(), False
    CompleteTest
    GoTo CleanupAndExit
RunTest_WaitForPool:
    If iPoolWaitRetryCount <= giMAX_ALLOWED_RETRIES Then
        iPoolWaitRetryCount = iPoolWaitRetryCount + 1
        lEndTick = GetTickCount + lCallWait + giPOOL_WAIT_RETRY_MIN
        Do While GetTickCount() < lEndTick And Not gbStopping
            DoEvents
        Loop
        GoTo RunTest_GetWorkerRetry
    Else
        'We reached our max retries
        s = LoadResString(giPOOL_MGR_REJECTION_WAITS_EXHAUSTED)
        If bLog Then AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
        DisplayStatus s
        StopOnError s
        Exit Sub
    End If
    Exit Sub
RunTestError:
    Select Case Err.Number
        Case RPC_E_CALL_REJECTED
            'Collision error, the OLE server is busy
            Dim il As Integer
            Dim ir As Integer
            'First check if stopping test
            If gbStopping Then GoTo StopTestNow
            AddLogRecord gsNULL_SERVICE_ID, LoadResString(giQUEUE_SERVICE_COLLISION_RETRY), GetTickCount(), False
            If iRetry < giMAX_ALLOWED_RETRIES Then
                iRetry = iRetry + 1
                ir = Int((giRETRY_WAIT_MAX - giRETRY_WAIT_MIN + 1) * Rnd + giRETRY_WAIT_MIN)
                For il = 0 To ir
                    DoEvents
                Next il
                If gbStopping Then Resume Next Else Resume
            Else
                'We reached our max retries
                s = LoadResString(giCOLLISION_ERROR)
                AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
                DisplayStatus s
                StopOnError s
                GoTo CleanupAndExit
            End If
        Case ERR_OBJECT_VARIABLE_NOT_SET
            'Worker was not successfully created
            s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            DisplayStatus Err.Description
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
            StopOnError s
            Exit Sub
        Case ERR_CANT_FIND_KEY_IN_REGISTRY
            'AEInstancer.Instancer is a work around for error
            '-2147221166 which occurrs every time a client
            'object creates an instance of a remote server,
            'destroys it, registers it local, and tries to
            'create a local instance.  The client can not
            'create an object registered locally after it created
            'an instance while it was registered remotely
            'until it shuts down and restarts.  Therefore,
            'it works to call another process to create the
            'local instance and pass it back.
            Dim oInstancer As APEInterfaces.IInstancer
            Set oInstancer = CreateObject("AEInstancer.Instancer")
            Set oWorker = oInstancer.object("AEWorker.Worker")
            Set oInstancer = Nothing
            Resume Next
        Case RPC_S_UNKNOWN_AUTHN_TYPE
            'Tried to connect to a server that does not support
            'specified authentication level.  Display message and
            'switch to no authentication and try again
            Dim iResult As Integer
            s = LoadResString(giUSING_NO_AUTHENTICATION)
            DisplayStatus s
            AddLogRecord gsNULL_SERVICE_ID, s, 0, False
            glConnectionAuthentication = RPC_C_AUTHN_LEVEL_NONE
            iResult = goRegClass.SetAutoServerSettings(True, "AEPoolMgr.Pool", , gsConnectionAddress, gsConnectionProtocol, glConnectionAuthentication)
            Resume
        Case ERR_OVER_FLOW
            s = CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            lCallNumber = 0
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
        Case giRPC_ERROR_ACCESSING_COLLECTION
            Set oWorker = Nothing
            oPool.ReleaseWorker
            bReleaseWorker = False
            s = LoadResString(giRPC_ERROR_ACCESSING_COLLECTION)
            DisplayStatus s
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
            StopOnError s
            Exit Sub
        Case RPC_PROTOCOL_SEQUENCE_NOT_FOUND
            'Most probably because of an attempt to create a Named Pipe under Win95
            If frmClient.SysInfo.OSPlatform = 1 And gbConnectionNetOLE = False And gbConnectionRemote = True _
                    And gsConnectionProtocol = "ncacn_np" Then
                Set oWorker = Nothing
                oPool.ReleaseWorker
                bReleaseWorker = False
                s = LoadResString(giNO_NAMED_PIPES_UNDER_WIN95)
                AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
                DisplayStatus s
                StopOnError s
                Exit Sub
            End If
        Case Else
            s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            DisplayStatus Err.Description
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
            If bPostingServices Then
                StopOnError s
                GoTo CleanupAndExit
            Else
                Resume Next
            End If
    End Select

CleanupAndExit:
    On Error Resume Next
    If bReleaseWorker And Not oPool Is Nothing Then
        oPool.ReleaseWorker
    End If
End Sub

Public Sub RunMTSTest()
    ' Similar to RunTest, but specifically for using MTS, not APE's Pool Manager, for pooling objects.
    ' This occurs when an MTS transaction (and no CPU task) is being performed.
    Const lMAX_COUNT = 2147483647
    
    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
    
    Dim s As String         'Error message
    Dim lTicks As Long      'Tick Count
    Dim lEndTick As Long    'DoEvents loop until this Tick Count
    Dim lCallNumber As Long 'Number of calls to Worker
    Dim lNumberOfCalls As Long      'Test duration in number of calls
    Dim iDurationMode As Integer    'Test duration mode
    Dim lDurationTicksEnd As Long   'Tick that test should end on
    Dim bPostingServices As Boolean 'In main loop of procedure
    Dim iRetry As Integer           'Number of call reties made by error handling resume
    Dim lCallWait As Long           'Number of ticks to wait between calls
    Dim bRandomWait As Boolean      'If true lCallWait needs generated before each new request
    Dim bLog As Boolean             'If true log records
    Dim bShow As Boolean            'If true update display
    Dim oMoveMoney As APEInterfaces.IMTSMoveMoney
    Dim sConnect As String          ' Connect string
    Dim eConnectOptions As ape_DbConnectionOptions     ' Database connection option
    Dim bLogMTSTransactions  As Boolean     ' If True, log MTS events
    Dim bShowMTSTransactions  As Boolean     ' If True, show MTS events
    Dim iTransferRetries As Integer         ' Number of attempts at performing the transfer
    
    On Error GoTo RunMTSTestError
    bLog = gbLog
    bShow = gbShow
    
    ' Set up connect string and database connection options
    sConnect = gvServiceConfiguration(ape_conConnectionString)
    eConnectOptions = gvServiceConfiguration(ape_conConnectionOption)
    bLogMTSTransactions = gvServiceConfiguration(ape_conLogMTSTransactions)
    bShowMTSTransactions = gvServiceConfiguration(ape_conShowMTSTransactions)
    
    s = LoadResString(giTEST_STARTED)
    If bLog Then AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
    DisplayStatus s
    Randomize
    glFirstServiceTick = GetTickCount()
    glLastCallbackTick = glFirstServiceTick     ' If 0 calls are completed, the time spent will be 0 ticks
    
    'Test duration variables
    iDurationMode = giTestDurationMode
    If iDurationMode = giTEST_DURATION_CALLS Then
        lNumberOfCalls = glNumberOfCalls
    ElseIf iDurationMode = giTEST_DURATION_TICKS Then
        lDurationTicksEnd = glFirstServiceTick + glTestDurationInTicks
    End If
    
    bPostingServices = True
    Do While Not gbStopping
        'Increment number of calls made
        lCallNumber = glCallsMade + 1
        'Get a Worker from the PoolMgr
        'Post the service to a worker
        'Post a synchronous service
        iRetry = 0
        
        ' Create the appropriate MoveMoney object
        Set oMoveMoney = CreateObject("AEMTSSvc.MoveMoney")
        
        iRetry = 0
        If bLogMTSTransactions Then
            AddLogRecord gsNULL_SERVICE_ID, LoadResString(giBEGIN_MTS_TRANSACTION), GetTickCount(), False
        End If
        On Error Resume Next
        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)
        iTransferRetries = 0
        
        Dim bRetry As Boolean
        Do
            bRetry = False
            oMoveMoney.Transfer sConnect, eConnectOptions, lFromAccount, lToAccount, 1
            glLastCallbackTick = GetTickCount
            Dim lError As Long
            lError = Err.Number
            On Error GoTo RunMTSTestError
            ' If the error is due to a locking contention, try again
            If lError <> 0 And iTransferRetries < giMAX_ALLOWED_RETRIES Then
                Select Case eConnectOptions
                    Case ape_idcADO
                        bRetry = (lError = -2147467259)
                    Case ape_idcDAO
                        If lError = 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 lError = 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 = (lError = ErrorResourceDeadlock)
                End Select
                If bRetry Then
                    iTransferRetries = iTransferRetries + 1
                    Sleep miMinQueryRetryDelay + (miMaxQueryRetryDelay - miMinQueryRetryDelay) * Rnd      ' Randomize the delay to avoid repeated contentions
                    DoEvents
                End If
            End If
        Loop While bRetry
        If bLogMTSTransactions Then
            AddLogRecord gsNULL_SERVICE_ID, LoadResString(IIf(lError = 0, giEND_MTS_TRANSACTION_SUCCEEDED, _
                    giEND_MTS_TRANSACTION_FAILED)), GetTickCount(), False
        End If
        If bShowMTSTransactions Then
            frmService.MTSResults (lError = 0)
        End If
        Set oMoveMoney = Nothing
        
        'Display CallsMade
        If bShow Then
            With frmClient
                .lblCallsMade = lCallNumber
                .lblCallsReturned = lCallNumber
                .lblCallsMade.Refresh
                .lblCallsReturned.Refresh
            End With
        End If
        'If gbStopping Then Exit Do
        'Go into an idle loop util the next call.
        If lCallWait > 0 Then
            lEndTick = GetTickCount + lCallWait
            Do While GetTickCount() < lEndTick And Not gbStopping
                DoEvents
            Loop
        End If
        glCallsMade = lCallNumber
        glCallsReturned = lCallNumber
        
        'See if it is time to stop the test
        If iDurationMode = giTEST_DURATION_CALLS Then
            If lCallNumber >= lNumberOfCalls Then Exit Do
        ElseIf iDurationMode = giTEST_DURATION_TICKS Then
            If GetTickCount >= lDurationTicksEnd Then Exit Do
        End If
    Loop
StopMTSTestNow:
    bPostingServices = False
    gbRunning = False
    Set oMoveMoney = Nothing
    If gbStopping Then
        'Someone hit the stop button on the Explorer.
        gStopTest
        Exit Sub
    End If
    If bLog Then AddLogRecord gsNULL_SERVICE_ID, LoadResString(giSERVICES_POSTED), GetTickCount(), False
    CompleteTest
    Exit Sub
RunMTSTestError:
    Select Case Err.Number
        Case RPC_E_CALL_REJECTED
            'Collision error, the OLE server is busy
            Dim il As Integer
            Dim ir As Integer
            'First check if stopping test
            If gbStopping Then GoTo StopMTSTestNow
            AddLogRecord gsNULL_SERVICE_ID, LoadResString(giQUEUE_SERVICE_COLLISION_RETRY), GetTickCount(), False
            If iRetry < giMAX_ALLOWED_RETRIES Then
                iRetry = iRetry + 1
                ir = Int((giRETRY_WAIT_MAX - giRETRY_WAIT_MIN + 1) * Rnd + giRETRY_WAIT_MIN)
                For il = 0 To ir
                    DoEvents
                Next il
                If gbStopping Then Resume Next Else Resume
            Else
                'We reached our max retries
                s = LoadResString(giCOLLISION_ERROR)
                AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
                DisplayStatus s
                StopOnError s
                Exit Sub
            End If
        Case ERR_OBJECT_VARIABLE_NOT_SET
            'Worker was not successfully created
            s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            DisplayStatus Err.Description
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
            StopOnError s
            Exit Sub
        Case ERR_CANT_FIND_KEY_IN_REGISTRY
            'AEInstancer.Instancer is a work around for error
            '-2147221166 which occurrs every time a client
            'object creates an instance of a remote server,
            'destroys it, registers it local, and tries to
            'create a local instance.  The client can not
            'create an object registered locally after it created
            'an instance while it was registered remotely
            'until it shuts down and restarts.  Therefore,
            'it works to call another process to create the
            'local instance and pass it back.
            Dim oInstancer As APEInterfaces.IInstancer
            Set oInstancer = CreateObject("AEInstancer.Instancer")
            Set oMoveMoney = oInstancer.object("AEMTSService.MoveMoney")
            Set oInstancer = Nothing
            Resume Next
        Case ERR_OVER_FLOW
            s = CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            lCallNumber = 0
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
        Case ERR_CANT_CREATE_OBJECT    ' CreateObject failed
            s = LoadResString(giERROR_CREATE_MTS_OBJECT)
            DisplayStatus s
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
            StopOnError s
            Exit Sub
        Case Else
            s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            DisplayStatus Err.Description
            AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
            If bPostingServices Then
                StopOnError s
                Exit Sub
            Else
                Resume Next
            End If
    End Select

End Sub