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.
939 lines
42 KiB
939 lines
42 KiB
Attribute VB_Name = "modClient"
|
|
Option Explicit
|
|
'-------------------------------------------------------------------------
|
|
'The project is the Client component of the Application Performance Explorer
|
|
'This client is designed to be instanciated by and configured by the APE
|
|
'Manager. It can generate Service Request by calling the QueueManager.
|
|
'Or it can call the Worker to produce synchronous work. In either of these
|
|
'sinarios the frequency can vary, and the type and size of data it passes
|
|
'can vary.
|
|
'
|
|
'Key Files:
|
|
' frmClnt.frm The only form in the app
|
|
' Client.cls Single-use, creatable, public class that provides
|
|
' OLE interface for Manager to instanciate and configure
|
|
' clsCalbk.cls Not creatable, but public class that is passed to the
|
|
' QueueMgr to receive call backs
|
|
' clsCntSv.cls Class used to store data on expected callbacks
|
|
' clsDrtTl.cls Class providing a runtest method for running direct
|
|
' instanciation tests
|
|
' clsPosFm.cls Tool form saving form position to registry
|
|
' clsQueTl.cls Class providing a runtest method for running Queue
|
|
' manager tests
|
|
'-------------------------------------------------------------------------
|
|
|
|
'Declares
|
|
#If UNICODE Then
|
|
Declare Function GetTempFileName Lib "Kernel32" Alias "GetTempFileNameW" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
|
|
Declare Function GetTempPath Lib "Kernel32" Alias "GetTempPathW" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
|
|
Public Declare Function GetComputerName Lib "Kernel32" Alias "GetComputerNameW" (ByVal lpBuffer As String, nSize As Long) As Long
|
|
#Else
|
|
Declare Function GetTempFileName Lib "Kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
|
|
Declare Function GetTempPath Lib "Kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
|
|
Public Declare Function GetComputerName Lib "Kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
|
|
#End If
|
|
Public Declare Function GetTickCount Lib "Kernel32" () As Long
|
|
Public Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)
|
|
|
|
'Caption String Constants
|
|
Public Const giFORM_CAPTION As Integer = 101 'Form Caption
|
|
Public Const giCALLS_MADE_CAPTION As Integer = 102
|
|
Public Const giCALLS_RETURNED_CAPTION As Integer = 103
|
|
|
|
'Log String Constants
|
|
Public Const giCOMPONENT_NAME As Integer = 2
|
|
Public Const giCALLBACK_RECEIVED As Integer = 3
|
|
Public Const giCALLBACK_ERROR_RECEIVED As Integer = 4
|
|
Public Const giQUEUE_SERVICE As Integer = 5
|
|
Public Const giQUEUE_SERVICE_ERROR As Integer = 7
|
|
Public Const giQUEUE_SERVICE_COLLISION_RETRY As Integer = 9
|
|
Public Const giWAIT_PERIOD_ERROR As Integer = 12
|
|
Public Const giSTART_TEST As Integer = 13
|
|
Public Const giSTOP_TEST As Integer = 14
|
|
Public Const giTEST_STARTED As Integer = 16
|
|
Public Const giTEST_COMPLETE As Integer = 17
|
|
Public Const giSERVICES_POSTED As Integer = 18
|
|
Public Const giCALLBACKS_COMPLETE As Integer = 19
|
|
Public Const giINITIALIZING_TEST As Integer = 20
|
|
Public Const giDIRECT_SERVICE As Integer = 21
|
|
Public Const giWRITING_TEMP_FILE As Integer = 23
|
|
Public Const giUSING_NO_AUTHENTICATION As Integer = 24
|
|
Public Const giDISK_FULL As Integer = 26
|
|
Public Const giPOOL_MGR_REJECTION_WAITS_EXHAUSTED As Integer = 27
|
|
Public Const giERROR_CREATE_MTS_OBJECT As Integer = 28
|
|
|
|
Public Const giFONT_CHARSET_INDEX As Integer = 30
|
|
Public Const giFONT_NAME_INDEX As Integer = 31
|
|
Public Const giFONT_SIZE_INDEX As Integer = 32
|
|
|
|
Public Const giERROR_PREFIX As Integer = 50 ' "Error: "
|
|
|
|
' MTS Transaction-related text
|
|
Public Const giSUCCEEDED_TRANSACTIONS_CAPTION As Integer = 110
|
|
Public Const giABORTED_TRANSACTIONS_CAPTION As Integer = 111
|
|
Public Const giBEGIN_MTS_TRANSACTION As Integer = 112
|
|
Public Const giEND_MTS_TRANSACTION_FAILED As Integer = 113
|
|
Public Const giEND_MTS_TRANSACTION_SUCCEEDED As Integer = 114
|
|
Public Const giMTS_FORM_CAPTION As Integer = 115
|
|
|
|
Public Const giRACREG_ERROR_CODE_OFFSET As Integer = 200 'Add offset to racreg32 error codes
|
|
'to make corresponding resource string key
|
|
'Application Error Constants
|
|
Public Const giCOLLISION_ERROR As Integer = 32767 'OLE collision retries exausted
|
|
Public Const giREQUIRED_PARAMETER_IS_MISSING As Integer = 32765
|
|
Public Const giPOOLMGR_RETURNED_NOTHING As Integer = 32766
|
|
Public Const giCONNECTION_SETTING_FAILED As Integer = 32750 'An error was returned by RacReg32
|
|
Public Const giNO_NAMED_PIPES_UNDER_WIN95 As Integer = 32739 ' Named pipes cannot be created under Win95
|
|
'Queue Manager errors
|
|
Public Const giQUEUE_MGR_IS_BUSY As Integer = 32749
|
|
|
|
'Other Constants
|
|
Public Const giCALL_SENT_AND_RECEIVED_MAX_DIFFERENCE As Integer = 200 'If the number of calls that the
|
|
'client has made is this much greater than
|
|
'the number of calls received back then
|
|
'pause making calls until callbacks catch up
|
|
Public Const giREDIM_CHUNK_SIZE As Integer = 100 'Size of redimension chunks of log array
|
|
Public Const giNO_RECORD As Integer = -1 'Flag value meaning no records
|
|
Public Const giMAX_ALLOWED_RETRIES As Integer = 500 'Max allowed OLE automation call retries
|
|
Public Const giRETRY_WAIT_MIN As Integer = 1000 'Retry Wait is measure in DoEvent cyles
|
|
Public Const giRETRY_WAIT_MAX As Integer = 5000
|
|
Public Const giROWS_RETURNED_PER_GET_RECORDS As Integer = 500 'Max number of records returned for
|
|
'each call of GetRecords
|
|
Public Const RPC_C_AUTHN_LEVEL_NONE As Integer = 1 'Remote Automation Authentication level constant
|
|
Public Const giPOOL_WAIT_RETRY_MIN As Integer = 1000 'The minum milliseconds to wait if the Pool Manager
|
|
'rejects request for a Worker
|
|
Public Const giQUEUE_WAIT_RETRY_MIN As Integer = 3000 'The minimum to wait in milliseconds if the Queue
|
|
'raises an error that it is to busy to process
|
|
'a Service Request
|
|
Public Const glMAX_LONG As Long = 2147483647
|
|
Public Const giDEFAULT_TIMER_INTERVAL As Integer = 100
|
|
Public Const giSLEEP_INCREMENT As Integer = 500 ' Time (ms) to sleep on each iteration of a delay loop
|
|
|
|
'Type
|
|
Public Type RANDOM_DATA_GROUP
|
|
Random As Boolean
|
|
SpecificValue As Long
|
|
UpperValue As Long
|
|
LowerValue As Long
|
|
End Type
|
|
|
|
'Global Variables and Objects
|
|
Public goTestTool As Object 'Object of a class having RunTest method
|
|
'actually runs the test. Different classes
|
|
'are used for different types of tests
|
|
Public gcServices As Collection 'Collection of clsCllietnService class objects
|
|
'stores expected callback information
|
|
Public gaLog() As Variant 'Array that stores log records
|
|
Public glCallsMade As Long 'Number of calls made in test
|
|
Public glCallsReturned As Long 'Number of callbacks made in a test
|
|
Public glInstances As Long 'Count of intances of Client class
|
|
Public glLogThresholdRecs As Long 'Log threshold in record count
|
|
Public goRegClass As RacReg.RegClass 'RacReg used to change connection settings
|
|
Public glLastAddedRecord As Long 'Last added log record array index
|
|
Public glFirstServiceTick As Long 'Milliseconds of test start
|
|
Public glLastCallbackTick As Long 'Milliseconds of end of test
|
|
Public gsTempFile As String 'Temporary log file name
|
|
|
|
'Flags
|
|
Public gbTestInProcess As Boolean 'If true, test is in process
|
|
Public gbStopping As Boolean 'If true, stopping test, procedures check it
|
|
Public gbShutDown As Boolean 'If true, shutting down client
|
|
Public gbRunCompleteProcedure As Boolean 'Timer will run CompleteTest
|
|
Public gbRunning As Boolean 'In a RunTest method
|
|
Public gbGetWrittenLogCalled As Boolean 'GetWritten log was called
|
|
|
|
'Public Property Variables
|
|
Public gsServiceCommand As String 'Command string to pass to Queue.Add
|
|
Public gbUseDefaultService As Boolean 'If true use default service object
|
|
Public gudtWaitPeriod As RANDOM_DATA_GROUP 'How long to wait between calls
|
|
Public glNumberOfCalls As Long 'Number of Calls to make in test
|
|
Public glTestDurationInTicks As Long 'Number of Milliseconds for Test to last
|
|
Public giTestDurationMode As Integer 'Mode of determining test duration
|
|
Public gudtSendNumRows As RANDOM_DATA_GROUP 'Number of rows of data to send with Service request
|
|
Public gudtSendRowSize As RANDOM_DATA_GROUP 'Number of bytes of data to put in each row of data
|
|
Public glSendContainerType As Long 'Type of data to send with Service request
|
|
Public gudtReceiveNumRows As RANDOM_DATA_GROUP 'Number of rows to request back from Service request
|
|
Public gudtReceiveRowSize As RANDOM_DATA_GROUP 'Size of each row in bytes to request back
|
|
Public glReceiveContainerType As Long 'Container type to request back from Service request
|
|
Public gudtTaskDuration As RANDOM_DATA_GROUP 'Length of time a Service request should use the processor
|
|
Public gudtSleepPeriod As RANDOM_DATA_GROUP 'Length of time a Service request should sleep
|
|
Public giServiceTask As Integer 'Code for whether Service should use processor cycles during
|
|
Public gsDatabaseQuery As String 'Query for the Service to use to execute a database request
|
|
Public giUseProcPercent As Integer 'Percentage of requests that services should use processor
|
|
Public gvServiceConfiguration As Variant 'Service configuration information
|
|
|
|
Public gbShow As Boolean 'If true, show frmClient during test
|
|
Public gbLog As Boolean 'If true log events during test
|
|
Public glCallbackMode As Long 'Determines if and how client receives results from
|
|
'services requested from QueueManager
|
|
'see "Callback mode keys" in modAEConstants
|
|
Public gbLogWorker As Boolean 'If true, have directly instanciated worker log
|
|
Public gbPreloadServices As Boolean 'If true, have directly instanciated worker preload
|
|
'needed service object
|
|
Public gbPersistentServices As Boolean 'If true, have directly instanciated worker retain
|
|
'references to Service objects
|
|
Public gbEarlyBindServices As Boolean 'If true, have directly instanciated workers use
|
|
'earlybound service objects
|
|
Public glModel As Long 'APE framework model to use during test
|
|
Public glClientID As Long 'Client ID Manager uses to manager Client object
|
|
Public gsConnectionAddress As String 'Net address of APE server objects to use
|
|
Public gsConnectionProtocol As String 'Protocol to connect with
|
|
Public glConnectionAuthentication As String 'Authentiation level to use
|
|
Public gbConnectionRemote As Boolean 'If true, connect to a remote server not local
|
|
Public gbConnectionNetOLE As Boolean 'If true, use NetOLE (DCOM) instead of Remote Automation
|
|
Public goExplorer As APEInterfaces.IManagerCallback 'Explorer object passed to client from Manager
|
|
'Client calls manager back with this
|
|
Public glLogThreshold As Long 'Log threshodl in kilobytes
|
|
|
|
Public Sub CompleteTest()
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Release objects used during test, and call Manager with
|
|
' notification the test.
|
|
'Effects:
|
|
' [gbTestInProcess]
|
|
' becomes false
|
|
' [goTesttool] destroyed
|
|
' [goExplorer] destroyed
|
|
' [gcServices] destroyed
|
|
'-------------------------------------------------------------------------
|
|
Dim s As String
|
|
Static stbInCompleteTest As Boolean 'If true already in this procedure
|
|
|
|
'Exit if reentry caused by timer click
|
|
'while calling goExplorer
|
|
|
|
If stbInCompleteTest Then Exit Sub
|
|
stbInCompleteTest = True
|
|
On Error GoTo CompleteTestError
|
|
s = LoadResString(giTEST_COMPLETE)
|
|
If gbLog Then AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
|
|
DisplayStatus s
|
|
If Not goExplorer Is Nothing Then goExplorer.Done ape_ctClient
|
|
Set goTestTool = Nothing
|
|
Set gcServices = Nothing
|
|
stbInCompleteTest = False
|
|
gbTestInProcess = False
|
|
Exit Sub
|
|
CompleteTestError:
|
|
Select Case Err.Number
|
|
Case RPC_E_CALL_REJECTED
|
|
'Collision error, the OLE server is busy
|
|
Dim iRetry As Integer
|
|
Dim il As Integer
|
|
Dim ir As Integer
|
|
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
|
|
Resume
|
|
Else
|
|
'We reached our max retries
|
|
AddLogRecord gsNULL_SERVICE_ID, LoadResString(giCOLLISION_ERROR), GetTickCount(), False
|
|
Resume Next
|
|
End If
|
|
Case Else
|
|
s = LoadResString(giQUEUE_SERVICE_ERROR) & CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
|
|
AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
|
|
stbInCompleteTest = False
|
|
Err.Raise Err.Number, Err.Source, Err.Description
|
|
Exit Sub
|
|
End Select
|
|
End Sub
|
|
|
|
|
|
Public Sub gStopTest()
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: To stop cancel the current test
|
|
'Assumes: If gbRunning is true, a method procedure or a callback method
|
|
' are being processed. We can exit this procedure and one of those
|
|
' methods will check the gbStopping flag and call gStopTest again
|
|
' If gbShutDown is true, then this procedure was called by the
|
|
' Terminate event of the Client class on the release of its last
|
|
' reference
|
|
'Effects:
|
|
' [gbTestInProcess]
|
|
' becomes false
|
|
' [goTesttool] destroyed
|
|
' [goExplorer] destroyed
|
|
' [gcServices] destroyed
|
|
' [goRegClass]
|
|
' If gbShutDown is true destroy goRegClass
|
|
' [frmClient]
|
|
' If gbShutDown is true unload
|
|
'-------------------------------------------------------------------------
|
|
Dim oCA As clsClientService
|
|
Dim s As String
|
|
On Error GoTo gStopTestError
|
|
|
|
gbStopping = True
|
|
s = LoadResString(giSTOP_TEST)
|
|
If gbLog Then AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
|
|
DisplayStatus s
|
|
'Make sure we are not in the middle of queueing an Service.
|
|
'If we are, get out. QueueService will check the gbStopping flag
|
|
'and call the gStopTest method again when it's done.
|
|
If gbRunning Then Exit Sub
|
|
Set goTestTool = Nothing
|
|
Set gcServices = Nothing
|
|
gbTestInProcess = False
|
|
'See if this was called by Terminate if it was unload form
|
|
If gbShutDown Then
|
|
Set goRegClass = Nothing
|
|
Unload frmClient
|
|
End If
|
|
Exit Sub
|
|
gStopTestError:
|
|
Select Case Err.Number
|
|
Case Else
|
|
LogError Err
|
|
If glInstances > 0 Then Err.Raise Err.Number, Err.Source, Err.Description
|
|
Resume Next
|
|
End Select
|
|
End Sub
|
|
|
|
|
|
Public Sub AddServiceRecord(sID As String, sCommand As String, lTicks As Long)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Put a new Service Request in the Service collection.
|
|
'In:
|
|
' [sID] Service Request ID
|
|
' [sCommand]
|
|
' Service Request Command sent to QueueMgr
|
|
' [lTicks]
|
|
' Tick count at time of call to QueueMgr
|
|
'Effects:
|
|
' [gcServices]
|
|
' Adds a clsClientService class object to collection
|
|
'-------------------------------------------------------------------------
|
|
Dim oCA As clsClientService 'Object with properties designed to store
|
|
'Service request information
|
|
|
|
Set oCA = New clsClientService
|
|
With oCA
|
|
.sID = sID
|
|
.sCommand = sCommand
|
|
.lStartTicks = lTicks
|
|
End With
|
|
gcServices.Add oCA, oCA.sID
|
|
End Sub
|
|
|
|
Public Sub WriteLog()
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Writes the current log records to a temp file and
|
|
' removes the records from memory
|
|
'Assumes: If gbGetWrittenLogCalled is true, any records currently in the
|
|
' temporary file are no longer needed, but the file may still be
|
|
' open.
|
|
'Effects:
|
|
' All records currently in gaLog are written to a temporary file
|
|
' and removed from the array
|
|
' [gbGetWrittenLogCalled]
|
|
' becomes false
|
|
' [glLastAddedRecord]
|
|
' becomes giNO_RECORD
|
|
' [gaLog] becomes redimension to store new records
|
|
'-------------------------------------------------------------------------
|
|
'Don't save the Component name because the component
|
|
'is always the same
|
|
Dim sServiceID As String
|
|
Dim sComment As String
|
|
Dim lMilliseconds As Long
|
|
Dim lFile As Long
|
|
Dim l As Long
|
|
On Error GoTo WriteLogError
|
|
If glLastAddedRecord > giNO_RECORD Then
|
|
If gbLog Then
|
|
AddLogRecord gsNULL_SERVICE_ID, LoadResString(giWRITING_TEMP_FILE), GetTickCount, False
|
|
End If
|
|
|
|
'Check to see if the contents of the temp file
|
|
'need deleted first, the reason it is not delete
|
|
'when the flag is flipped is to give one the chance
|
|
'of rescueing it if the Manager fails to retreive
|
|
'the records from it
|
|
If gbGetWrittenLogCalled Then
|
|
Close 'Close in case last GetWrittenLogs cancelled
|
|
Kill gsTempFile
|
|
gbGetWrittenLogCalled = False
|
|
End If
|
|
|
|
lFile = FreeFile
|
|
Open gsTempFile For Append As lFile
|
|
For l = 0 To glLastAddedRecord
|
|
sServiceID = gaLog(giSERVICE_ELEMENT, l)
|
|
sComment = gaLog(giCOMMENT_ELEMENT, l)
|
|
lMilliseconds = gaLog(giMILLI_SECONDS_ELEMENT, l)
|
|
Write #lFile, sServiceID, sComment, lMilliseconds
|
|
'Reset logrecord counter no after writing the first record
|
|
'so that records are not added after the count that is being
|
|
'written and therefore, lost. This also protects from
|
|
'Addlogrecord trying to write a record greater than
|
|
'giREDIM_CHUNK_SIZE write after gaLog is redimensioned
|
|
If l = 0 Then glLastAddedRecord = giNO_RECORD
|
|
Next
|
|
Close #lFile
|
|
'Remove LogRecords from memory
|
|
'Preserve is used because there is a potential
|
|
'for a log record to be added after the above line
|
|
'but before the following one
|
|
ReDim Preserve gaLog(giLOG_ARRAY_DIMENSION_ONE, giREDIM_CHUNK_SIZE)
|
|
End If
|
|
Exit Sub
|
|
WriteLogError:
|
|
Select Case Err.Number
|
|
Case ERR_DISK_FULL
|
|
'Turn off logging erase array
|
|
'leave present file for later retrieval
|
|
DisplayStatus LoadResString(giDISK_FULL)
|
|
Close lFile
|
|
Erase gaLog
|
|
gbLog = False
|
|
Exit Sub
|
|
Case ERR_FILE_NOT_FOUND
|
|
'There is no temp file to kill
|
|
Resume Next
|
|
Case Else
|
|
Close lFile
|
|
Err.Raise Err.Number, Err.Source, Err.Description
|
|
Exit Sub
|
|
End Select
|
|
End Sub
|
|
|
|
|
|
Public Sub GetWrittenLog()
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Checks to see if there is log records written to a temp file
|
|
' If there are it inputs it and adds it to the gaLog array
|
|
' If it reaches the chunk size for passing log records it will
|
|
' exit the loop, leaving the file open. It is necessary to keep
|
|
' calling this function until no records or added. Do not call
|
|
' this function more than once until the array that was filled
|
|
' was erased. The external process that is calling a method that
|
|
' calls this procedure should be responsible for calling until
|
|
' all records have been attained.
|
|
'Effects:
|
|
' [gbGetWrittenLogCalled] becomes true
|
|
' Temp file may be left open if all records are not read
|
|
' AddlogRecord is called for each record read
|
|
'Assumption:
|
|
' If gbGetWrittenLogCalled is true then the temp file is already
|
|
' open, ready for the next record to be read.
|
|
' If the EOF is not reached before the glROWS_RETURNED_PER_GET_RECORDS
|
|
' is reached then the external process that called Logger.GetRecords
|
|
' will call it again, to get the rest of the records
|
|
'-------------------------------------------------------------------------
|
|
|
|
Static stlFile As Long 'File number
|
|
Dim sPath As String 'Path and file name of temporary file
|
|
Dim sServiceID As String 'Service Request ID
|
|
Dim sComment As String 'Comment in log record
|
|
Dim lMilliseconds As Long 'Milliseconds in log record
|
|
Dim lAddedCount As Long 'Count of how many records have been read and added to memory
|
|
|
|
On Error GoTo GetWrittenLogError
|
|
sPath = gsTempFile
|
|
|
|
'Open file if it is not open yet
|
|
If Not gbGetWrittenLogCalled Then
|
|
'Write records in memory first to order the records
|
|
'with any records that may have already been written
|
|
WriteLog
|
|
gbGetWrittenLogCalled = True
|
|
stlFile = FreeFile
|
|
Open sPath For Input As stlFile
|
|
End If
|
|
|
|
Do Until EOF(stlFile)
|
|
'Component was not saved to temp file because
|
|
'the component name is always the same in this file
|
|
Input #stlFile, sServiceID, sComment, lMilliseconds
|
|
AddLogRecord sServiceID, sComment, lMilliseconds, True
|
|
lAddedCount = lAddedCount + 1
|
|
'Exit here if max record size was reached
|
|
If lAddedCount = giROWS_RETURNED_PER_GET_RECORDS Then Exit Sub
|
|
Loop
|
|
Close
|
|
Exit Sub
|
|
GetWrittenLogError:
|
|
Select Case Err.Number
|
|
Case ERR_FILE_NOT_FOUND
|
|
'There are no written records so exit
|
|
Exit Sub
|
|
Case ERR_BAD_FILE_NAME
|
|
'We have already reached the end of the file
|
|
'and it has been closed
|
|
Exit Sub
|
|
Case Else
|
|
Close
|
|
Err.Raise Err.Number, Err.Source, Err.Description
|
|
Exit Sub
|
|
End Select
|
|
End Sub
|
|
|
|
|
|
Public Function GetTempFile() As String
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Gets a temp file name from the system
|
|
'Return: a valid temporary file name
|
|
'-------------------------------------------------------------------------
|
|
Dim lSize As Long
|
|
Dim sPath As String
|
|
Dim sName As String
|
|
Dim lResult As Long
|
|
|
|
sPath = Space(255)
|
|
lResult = GetTempPath(255, sPath)
|
|
sPath = Left$(sPath, lResult)
|
|
sName = Space(255)
|
|
lResult = GetTempFileName(sPath, "AEC", 0, sName)
|
|
lResult = InStr(sName, vbNullChar)
|
|
sName = Left$(sName, lResult - 1)
|
|
|
|
GetTempFile = sName
|
|
End Function
|
|
|
|
Public Sub DisplayString(s As String)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Adds the passed text to to the list box. Only used if conditional
|
|
' compile ccShowList is true.
|
|
'Assumes: If gbShow is true, form is visible
|
|
' If ccShowList is true, lstLog is visible and positioned
|
|
'-------------------------------------------------------------------------
|
|
If gbShow Then
|
|
With frmClient.lstLog
|
|
If .ListCount = giLIST_BOX_MAX Then .Clear
|
|
.AddItem s, 0
|
|
End With
|
|
End If
|
|
End Sub
|
|
|
|
Public Sub DisplayStatus(s As String)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: If gbShow is true, displays passed string on forms status box
|
|
'Assumes: If gbShow is true, form is loaded and visible
|
|
'-------------------------------------------------------------------------
|
|
If gbShow Then
|
|
AlignTextToBottom frmClient.lblStatus, s
|
|
End If
|
|
End Sub
|
|
|
|
|
|
'Puts a new log record into the private log array and updates the listbox
|
|
'if the the UI is visible. The logs will besent to the manager later.
|
|
Public Sub AddLogRecord(sServiceID As String, sComment As String, lMilliseconds As Long, bIgnoreThreshod As Boolean)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Called to add a record to the gaLog.
|
|
'In: [sServiceID] Service ID that will be added
|
|
' [sComment] Comment that will be added
|
|
' [lMilliseconds] Milliseconds that will be added
|
|
' [bIgnoreThreshold]
|
|
' If true, procedure ignores the Threshold property
|
|
' It will not write the records to a file and
|
|
' remove them from the array
|
|
'Effects: [gaLog] May be redimensioned (preserve) to increase
|
|
' its size
|
|
' [glLastAddedRecord]
|
|
' will be increased by one
|
|
'-------------------------------------------------------------------------
|
|
Dim lU As Long 'Ubound of array
|
|
Dim lIndex As Long 'array index to put records in
|
|
|
|
On Error GoTo AddLogRecordError
|
|
AddLogRecordTop:
|
|
|
|
'Check if the array needs dimensioned
|
|
If glLastAddedRecord = giNO_RECORD Then
|
|
ReDim gaLog(giLOG_ARRAY_DIMENSION_ONE, giREDIM_CHUNK_SIZE)
|
|
glLastAddedRecord = 0
|
|
lIndex = glLastAddedRecord
|
|
Else
|
|
lU = UBound(gaLog, 2)
|
|
glLastAddedRecord = glLastAddedRecord + 1
|
|
lIndex = glLastAddedRecord
|
|
If glLastAddedRecord > lU Then
|
|
'Redim gaRecords to increase size
|
|
lU = lU + giREDIM_CHUNK_SIZE
|
|
ReDim Preserve gaLog(giLOG_ARRAY_DIMENSION_ONE, lU)
|
|
End If
|
|
End If
|
|
gaLog(giCOMPONENT_ELEMENT, lIndex) = LoadResString(giCOMPONENT_NAME) & Str$(glClientID)
|
|
gaLog(giSERVICE_ELEMENT, lIndex) = sServiceID
|
|
gaLog(giCOMMENT_ELEMENT, lIndex) = sComment
|
|
gaLog(giMILLI_SECONDS_ELEMENT, lIndex) = lMilliseconds
|
|
If Not bIgnoreThreshod And glLogThresholdRecs > 0 And glLogThresholdRecs = glLastAddedRecord Then
|
|
'Write the log file
|
|
WriteLog
|
|
End If
|
|
#If ccShowList Then
|
|
DisplayString sServiceID & gsSEPERATOR & sComment: DoEvents
|
|
#End If
|
|
Exit Sub
|
|
AddLogRecordError:
|
|
Select Case Err.Number
|
|
Case ERR_SUBSCRIPT_OUT_OF_RANGE
|
|
'Synchronicity issues caused this
|
|
'Got the glLastAddedRecord write before it got changed
|
|
'but tried to put record in array right after it got redim'ed
|
|
Dim bTried
|
|
'If already tried raise error
|
|
If bTried Then Err.Raise Err.Number, Err.Source, Err.Description
|
|
bTried = True
|
|
'Try the at the top again, getting a new glLastAddedRecord
|
|
GoTo AddLogRecordTop
|
|
Case Else
|
|
DisplayStatus Err.Description
|
|
Exit Sub
|
|
End Select
|
|
End Sub
|
|
|
|
Public Sub LogError(ByVal oErr As ErrObject)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Display error description on forms Status box if the form is
|
|
' visible
|
|
'In: [oErr]
|
|
' Valid error object
|
|
'-------------------------------------------------------------------------
|
|
Dim s As String
|
|
s = LoadResString(giERROR_PREFIX) & Str$(oErr.Number) & gsSEPERATOR & oErr.Source & gsSEPERATOR & oErr.Description
|
|
AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
|
|
DisplayStatus oErr.Description
|
|
End Sub
|
|
|
|
Function GetValueFromRange(udtRangeData As RANDOM_DATA_GROUP, bRandomValueRequired As Boolean) As Long
|
|
Dim lReturn As Long
|
|
|
|
With udtRangeData
|
|
If .Random Then
|
|
Randomize
|
|
lReturn = CLng((.UpperValue - .LowerValue + 1) * Rnd + .LowerValue)
|
|
Else
|
|
lReturn = .SpecificValue
|
|
End If
|
|
If Not bRandomValueRequired Then bRandomValueRequired = .Random
|
|
End With
|
|
GetValueFromRange = lReturn
|
|
End Function
|
|
|
|
Function GetServiceCommand(bRandomCommandRequired As Boolean) As String
|
|
Dim sSendCommand As String
|
|
Dim iRandom As Integer
|
|
|
|
bRandomCommandRequired = False
|
|
'Get ServiceCommand to use
|
|
If gbUseDefaultService Then
|
|
sSendCommand = gsSERVICE_LIB_CLASS & "." & giServiceTask
|
|
Else
|
|
sSendCommand = gsServiceCommand
|
|
End If
|
|
GetServiceCommand = sSendCommand
|
|
End Function
|
|
|
|
|
|
Function GetTestData(bSendSomething As Boolean, bReceiveSomething As Boolean, vSendData As Variant) As Boolean
|
|
Dim s As String
|
|
Dim i As Integer
|
|
Dim lSendNumRows As Long
|
|
Dim lSendRowSize As Long
|
|
Dim lReceiveNumRows As Long
|
|
Dim lReceiveRowSize As Long
|
|
Dim cData As Collection
|
|
Dim aData() As Variant
|
|
Dim lSendContainerType As Long
|
|
Dim lReceiveContainerType As Long
|
|
Dim bRandomDataRequired As Boolean
|
|
Dim lTaskDuration As Long, lSleepPeriod As Long
|
|
|
|
lReceiveContainerType = glReceiveContainerType
|
|
lSendContainerType = glSendContainerType
|
|
|
|
'Get Data that will be worked with
|
|
lSendNumRows = GetValueFromRange(gudtSendNumRows, bRandomDataRequired)
|
|
lSendRowSize = GetValueFromRange(gudtSendRowSize, bRandomDataRequired)
|
|
lReceiveNumRows = GetValueFromRange(gudtReceiveNumRows, bRandomDataRequired)
|
|
lReceiveRowSize = GetValueFromRange(gudtReceiveRowSize, bRandomDataRequired)
|
|
lTaskDuration = GetValueFromRange(gudtTaskDuration, bRandomDataRequired)
|
|
lSleepPeriod = GetValueFromRange(gudtSleepPeriod, bRandomDataRequired)
|
|
|
|
'Check if we are sending or receiving any data
|
|
'Clear the data structures
|
|
bSendSomething = True
|
|
bReceiveSomething = False
|
|
|
|
Set cData = New Collection
|
|
ReDim aData(0) As Variant
|
|
'Anything to send to the Service?
|
|
If (lSendNumRows = 0 Or lSendRowSize = 0) And (lReceiveNumRows = 0 Or lReceiveRowSize = 0) And _
|
|
lTaskDuration = 0 And lSleepPeriod = 0 Then
|
|
'Nothing to send to the Service
|
|
' bSendSomething = False We need to send the service configuration information with each call
|
|
Else
|
|
bSendSomething = True
|
|
'Fill the data class send data for passing to the Service
|
|
s = Space(lSendRowSize)
|
|
Select Case lSendContainerType
|
|
Case giCONTAINER_TYPE_VARRAY
|
|
ReDim Preserve aData(giRECORD_DATA_BEGIN + lSendNumRows - 1) As Variant
|
|
For i = giRECORD_DATA_BEGIN To giRECORD_DATA_BEGIN + lSendNumRows - 1
|
|
aData(i) = s
|
|
Next i
|
|
Case giCONTAINER_TYPE_VCOLLECTION
|
|
For i = 1 To lSendNumRows
|
|
cData.Add s
|
|
Next i
|
|
End Select
|
|
End If
|
|
'Anything to receive back from the Service?
|
|
If (lReceiveNumRows = 0 Or lReceiveRowSize = 0 Or lReceiveContainerType = giCONTAINER_TYPE_NULL) Then
|
|
bReceiveSomething = False
|
|
lReceiveNumRows = 0
|
|
lReceiveRowSize = 0
|
|
lReceiveContainerType = giCONTAINER_TYPE_NULL
|
|
Else
|
|
bReceiveSomething = True
|
|
End If
|
|
'Some data may actually be sent if something is expected back or a
|
|
'Milliseconds to be used is specified, but only enough data to instruct
|
|
'the Service on what to do.
|
|
If bReceiveSomething Or bSendSomething Then
|
|
'Fill the global data class receive parameters for passing to the Service
|
|
Select Case lSendContainerType
|
|
Case giCONTAINER_TYPE_VARRAY
|
|
'Make sure we have records in our array to fill
|
|
If UBound(aData) < giRECORD_DATA_BEGIN - 1 Then
|
|
ReDim aData(giRECORD_DATA_BEGIN - 1) As Variant
|
|
End If
|
|
aData(giRECORD_NUMROWS) = lReceiveNumRows
|
|
aData(giRECORD_ROWSIZE) = lReceiveRowSize
|
|
aData(giRECORD_TASK_DURATION) = lTaskDuration
|
|
aData(giRECORD_SLEEP_PERIOD) = lSleepPeriod
|
|
aData(giRECORD_CONTAINER_TYPE) = lReceiveContainerType
|
|
aData(giRECORD_DATABASE_QUERY) = gsDatabaseQuery
|
|
aData(giRECORD_SERVICE_CONFIGURATION) = gvServiceConfiguration
|
|
Case giCONTAINER_TYPE_VCOLLECTION
|
|
cData.Add lReceiveNumRows, CStr(giRECORD_NUMROWS)
|
|
cData.Add lReceiveRowSize, CStr(giRECORD_ROWSIZE)
|
|
cData.Add lTaskDuration, CStr(giRECORD_TASK_DURATION)
|
|
cData.Add lSleepPeriod, CStr(giRECORD_SLEEP_PERIOD)
|
|
cData.Add lReceiveContainerType, CStr(giRECORD_CONTAINER_TYPE)
|
|
cData.Add gsDatabaseQuery, CStr(giRECORD_DATABASE_QUERY)
|
|
cData.Add gvServiceConfiguration, CStr(giRECORD_SERVICE_CONFIGURATION)
|
|
End Select
|
|
End If
|
|
|
|
'Set return value and out parameters
|
|
Select Case lSendContainerType
|
|
Case giCONTAINER_TYPE_VARRAY
|
|
vSendData = aData()
|
|
Case giCONTAINER_TYPE_VCOLLECTION
|
|
Set vSendData = cData
|
|
End Select
|
|
GetTestData = bRandomDataRequired
|
|
End Function
|
|
|
|
Sub ConfigureTest()
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Configure the Client to run a test according to its current
|
|
' properties.
|
|
'Effects: U/I is reset for a new test
|
|
' Remote Connection settings are made useing RacReg
|
|
' [glCallsMade]
|
|
' becomes 0
|
|
' [glCallsReturned]
|
|
' becomes 0
|
|
' [gbTestInProcess]
|
|
' becomes true
|
|
' [gbStopping]
|
|
' becomes false
|
|
' [gcServices]
|
|
' is destroyed and reinstanciated
|
|
' [goTestTool]
|
|
' is instanciated with the correct class having a RunTest method
|
|
'Assumption:
|
|
' A test is not already in process
|
|
'-------------------------------------------------------------------------
|
|
'Configure test mode and connection settings
|
|
Dim iResult As Integer
|
|
|
|
'Set the global status flags
|
|
'If there is reentry by a timer click exit sub
|
|
If gbTestInProcess Then Exit Sub
|
|
gbTestInProcess = True
|
|
'Clear the Services collection
|
|
Set gcServices = Nothing
|
|
Set gcServices = New Collection
|
|
'Set global variables
|
|
glCallsMade = 0
|
|
glCallsReturned = 0
|
|
'Display the stautus defaults
|
|
If gbShow Then
|
|
With frmClient
|
|
.lblCallsMade.Caption = 0
|
|
.lblCallsReturned.Caption = 0
|
|
.lblCallsMade.Refresh
|
|
.lblCallsReturned.Refresh
|
|
End With
|
|
End If
|
|
'Set the connection settings for AEWorker.Worker, AEQueueMgr.Queue, AEPoolMgr.Pool
|
|
With goRegClass
|
|
If gbConnectionRemote Then
|
|
If gbConnectionNetOLE Then
|
|
iResult = .SetNetOLEServerSettings(True, "AEQueueMgr.Queue", , gsConnectionAddress)
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
iResult = .SetNetOLEServerSettings(True, "AEWorker.Worker", , gsConnectionAddress)
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
iResult = .SetNetOLEServerSettings(True, "AEPoolMgr.Pool", , gsConnectionAddress)
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
Else
|
|
iResult = .SetAutoServerSettings(True, "AEQueueMgr.Queue", , gsConnectionAddress, gsConnectionProtocol, glConnectionAuthentication)
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
iResult = .SetAutoServerSettings(True, "AEWorker.Worker", , gsConnectionAddress, gsConnectionProtocol, glConnectionAuthentication)
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
iResult = .SetAutoServerSettings(True, "AEPoolMgr.Pool", , gsConnectionAddress, gsConnectionProtocol, glConnectionAuthentication)
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
End If
|
|
Else
|
|
iResult = .SetAutoServerSettings(False, "AEQueueMgr.Queue")
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
iResult = .SetAutoServerSettings(False, "AEWorker.Worker")
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
iResult = .SetAutoServerSettings(False, "AEPoolMgr.Pool")
|
|
If iResult <> 0 Then GoTo ConfigureTest_RacRegError
|
|
End If
|
|
End With
|
|
'Check our mode and create instances of the correct objects.
|
|
Select Case glModel
|
|
Case giMODEL_QUEUE
|
|
Set goTestTool = New clsQueueTestTool
|
|
Case giMODEL_DIRECT
|
|
Set goTestTool = New clsDirectTestTool
|
|
Case giMODEL_POOL
|
|
Set goTestTool = New clsPoolTestTool
|
|
End Select
|
|
Exit Sub
|
|
ConfigureTest_RacRegError:
|
|
Err.Raise giCONNECTION_SETTING_FAILED, , ReplaceString(LoadResString(giCONNECTION_SETTING_FAILED), gsNAME_TOKEN, LoadResString(giRACREG_ERROR_CODE_OFFSET + iResult))
|
|
End Sub
|
|
|
|
Sub StopOnError(sMessage As String)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Stop current test immediately
|
|
'Effects:
|
|
' Calls goExplorer.Done
|
|
' [glLastCallbackTick]
|
|
' becomes value of GetTickCount
|
|
' [goTestTool] is destroyed
|
|
' [gcServices] is destroyed
|
|
' [goExplorer] is destroyed
|
|
' [gbTestInProcess]
|
|
' becomes false
|
|
'-------------------------------------------------------------------------
|
|
On Error GoTo StopOnError_Error
|
|
glLastCallbackTick = GetTickCount()
|
|
gbRunning = False
|
|
gbStopping = True 'This flags will cause callbacks to be ignored
|
|
If gbLog Then AddLogRecord gsNULL_SERVICE_ID, LoadResString(giSERVICES_POSTED), GetTickCount(), False
|
|
goExplorer.Done ape_ctClient, sMessage
|
|
Set goTestTool = Nothing
|
|
Set gcServices = Nothing
|
|
gbTestInProcess = False
|
|
Exit Sub
|
|
StopOnError_Error:
|
|
If gbLog Then AddLogRecord gsNULL_SERVICE_ID, LoadResString(giSERVICES_POSTED), GetTickCount(), False
|
|
LogError Err
|
|
Resume Next
|
|
End Sub
|
|
|
|
Public Sub CallBackHandler(sServiceID As String, vServiceReturn As Variant, sServiceError As String)
|
|
'-------------------------------------------------------------------------
|
|
'Purpose: Called by clsCallback Callback method or .
|
|
'IN:
|
|
' [sServiceID]
|
|
' Service Request ID
|
|
' [vServiceReturn]
|
|
' Data returned by Service Request
|
|
' [sServiceError]
|
|
' Error information for errors that occured processing Service Request.
|
|
' Information is delimited by a semi-colon and a space in the following
|
|
' format: "number; source; description"
|
|
'Effects:
|
|
' May call CompleteTest procedure if all ServiceRequest have been returned
|
|
' [glCallsReturned]
|
|
' Increments by one
|
|
' [gcServices]
|
|
' Removes respective item
|
|
'-------------------------------------------------------------------------
|
|
Dim lTicks As Long 'Milliseconds
|
|
Dim oClientService As clsClientService 'Object storing Service Request information
|
|
'one will be removed from gcServices
|
|
Dim s As String
|
|
|
|
On Error GoTo CallBackHandlerError
|
|
'Grab the tics, keep a global copy of the last callback tick count for statistics.
|
|
glLastCallbackTick = GetTickCount()
|
|
'Exit sub if Stopping test
|
|
If gbStopping Then Exit Sub
|
|
'Lookup the Service
|
|
If IsNumeric(sServiceID) Then
|
|
'This is a valid Service.
|
|
'Look up the ID in our collection.
|
|
Set oClientService = gcServices.Item(sServiceID)
|
|
'No error. This Service is in our Service collection
|
|
'Increment the CallsReturned global
|
|
glCallsReturned = glCallsReturned + 1
|
|
If gbShow Then
|
|
With frmClient.lblCallsReturned
|
|
.Caption = glCallsReturned
|
|
.Refresh
|
|
End With
|
|
End If
|
|
If gbLog Then AddLogRecord sServiceID, LoadResString(giCALLBACK_RECEIVED), glLastCallbackTick, False
|
|
'Remove the Service from the collection
|
|
gcServices.Remove (sServiceID)
|
|
End If
|
|
If Len(sServiceError) > 0 Then
|
|
'It's an error message. Log it.
|
|
'And abort test
|
|
s = LoadResString(giCALLBACK_ERROR_RECEIVED) & gsSEPERATOR & sServiceError
|
|
If gbLog Then AddLogRecord sServiceID, s, lTicks, False
|
|
StopOnError s
|
|
|
|
End If
|
|
'Are we through with the test yet?
|
|
Dim bDone As Boolean
|
|
Select Case giTestDurationMode
|
|
Case giTEST_DURATION_CALLS
|
|
bDone = (glCallsReturned = glNumberOfCalls)
|
|
Case giTEST_DURATION_TICKS
|
|
bDone = (glCallsReturned = glCallsMade) And Not gbRunning
|
|
Case Else
|
|
bDone = False
|
|
End Select
|
|
If bDone Then
|
|
'All Services have been queud and callbacks received.
|
|
If gbLog Then AddLogRecord gsNULL_SERVICE_ID, LoadResString(giCALLBACKS_COMPLETE), GetTickCount(), False
|
|
'Release the Explorer before running CompleteTest
|
|
gbRunCompleteProcedure = True
|
|
frmClient.tmrStartTest.Enabled = True
|
|
End If
|
|
Exit Sub
|
|
CallBackHandlerError:
|
|
Select Case Err.Number
|
|
Case ERR_INVALID_PROCEDURE_CALL
|
|
'The ServiceID was not found in the Services collection.
|
|
LogError Err
|
|
Case ERR_OVER_FLOW
|
|
s = CStr(Err.Number) & gsSEPERATOR & Err.Source & gsSEPERATOR & Err.Description
|
|
glCallsReturned = 0
|
|
DisplayStatus Err.Description
|
|
AddLogRecord gsNULL_SERVICE_ID, s, GetTickCount(), False
|
|
Case Else
|
|
'Do not raise an error back to the expediter
|
|
LogError Err
|
|
End Select
|
|
Exit Sub
|
|
End Sub
|
|
|