Programming Languages Suite/ProgramD2.iso/Visual Database/Visual BASIC 5.0 (Ent. Edition)/Vb5ent Extractor.EXE/VB/SAMPLES/ENTRPRIS/APE/AECLIENT/CLSPOOTL.CLS

Visual Basic class definition | 1996-11-16 | 10.7 KB | 251 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
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
    '-------------------------------------------------------------------------

    'Called by tmrStartTest so that the StartTest method can release
    'the calling program.

    Const lMAX_COUNT = 2147483647
    Dim s As String         'Error message
    Dim lServiceID As Long  '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 AEWorker.Worker  'Local reference to the Worker
    Dim oPool As AEPoolMgr.Pool
    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

    On Error GoTo RunTestError
    'If there is reentry by a timer click exit sub
    If gbRunning Then Exit Sub
    gbRunning = True

    'Set the local variables to direct the testing
    Set oPool = New 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 0, s, GetTickCount(), False
    DisplayStatus s
    glFirstServiceTick = GetTickCount()

    '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
        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
        iRetry = 0
        If bSendSomething Then
            oWorker.DoService lServiceID, sSendCommand, vSendData
        Else
            oWorker.DoService lServiceID, sSendCommand
        End If
        Set oWorker = Nothing
        oPool.ReleaseWorker

        '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

        '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
    glLastCallbackTick = GetTickCount()
    gbRunning = False
    Set oWorker = Nothing
    If gbStopping Then
        'Someone hit the stop button on the Explorer.
        gStopTest
        Exit Sub
    End If
    If bLog Then AddLogRecord 0, LoadResString(giSERVICES_POSTED), GetTickCount(), False
    CompleteTest
    Exit Sub
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 0, 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
            If bLog Then AddLogRecord 0, 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)
                If bLog Then AddLogRecord 0, 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
            If gbLog Then AddLogRecord 0, 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 AEInstancer.Instancer
            Set oInstancer = New 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 0, 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
            If gbLog Then AddLogRecord 0, s, GetTickCount(), False
        Case Else
            s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
            DisplayStatus Err.Description
            If gbLog Then AddLogRecord 0, s, GetTickCount(), False
            If bPostingServices Then
                StopOnError s
                Exit Sub
            Else
                Resume Next
            End If
    End Select
End Sub