vwemirror/firestorm
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial full mirror of c:\VWE (source + assets + toolchain + outputs) via Git LFS

Browse Source 
Complete disaster-recovery snapshot: engine/game source, game data assets,
VC6 toolchain + DX SDKs, build outputs, deployed game, and _UNUSED archive.
Large binaries in Git LFS; text preserved byte-for-byte (core.autocrlf=false,
no eol attributes). See RECOVERY.md for the one-clone rebuild procedure.
This commit is contained in:
Cyd
2026-06-24 21:28:16 -05:00
commit 2b8ca921cb
66341 changed files with 7923174 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/AEPOOL.RC
+43
View File
@@ -0,0 +1,43 @@
STRINGTABLE DISCARDABLE
BEGIN
1 "*** Do *NOT* Localize any string that starts with '***'. They are comments to be used by localizers to identify sections. They also mark the beginning of a new 'section' within the String Table."
2 "Pool Manager"
3 "GetWorker Method received"
4 "ReleaseWorker Method received"
11 "Call rejected retry"
12 "Because the specified authentication level is not supported on the remote machine, Worker will be created with no authentication on the machine, <NAME>."
13 "Only <NUMBER> workers were created and configured, because available machines were lacking."
//Remote Worker creation error message
14 "Could not create or configure a worker on machine, <NAME>."
//No errors creating remote workers message
15 "All requested workers were successfully created."
16 "Could not create or configure local worker object."
17 "Error: "
29 "*** Font information for all forms. Index 30 is the Character set, Index 31 is Font name, Index 32 is Font Size"
30 "0"
31 "Tahoma"
32 "10"
49 "*** Form U/I captions"
50 "Requests Satisfied"
51 "Requests Rejected"
52 "Number of Workers"
53 "Pool Manager"
200 "*** Racreg32 error codes with 200 added for offset"
201 "Unknown run time error occurred"
202 "No protocol was specified"
203 "No server machine name was specified"
204 "An error occurred reading from the registry"
205 "An error occurred writing to the registry"
206 "Both the ProgID and CLSID parameters were missing"
207 "There is no local server (either in-process or cross-process, 16-bit or 32-bit)"
208 "There was an error looking for the Proxy DLLs, check that they were installed properly"
32700 "*** Error Descriptions"
32750 "An error occurred changing server connection settings: <NAME>."
32765 "Invalid Parameter"
32764 "No Workers could be created."
END
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/AEPOOL.RES
LFS
BIN
View File
Binary file not shown.
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/AEPOOL.VBP
+55
View File
@@ -0,0 +1,55 @@
Type=OleExe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINNT\System32\STDOLE2.TLB#OLE Automation
Reference=*\G{244D13BD-AFDB-11CE-85D1-00AA00695286}#1.1#0#..\..\EXTERNAL\racreg32.dll#RacReg
Reference=*\G{C93809A0-684C-11D1-9D3E-0020781039AF}#1.0#9#..\AEIntrfc\AEIntrfc.TLB#Application Performance Explorer 2.0 Interfaces
Module=modPoolMgr; modpool.bas
Form=frmpool.frm
Class=Pool; pool.cls
Class=PoolMgr; poolmgr.cls
Module=modAEConstants; ..\AEInclud\modaecon.bas
Class=clsPositionForm; ..\AEInclud\clsposfm.cls
Class=clsWorker; ..\AEInclud\clsworkr.cls
Module=modWin32Errors; ..\AEInclud\modwiner.bas
Class=clsWorkerMachines; ..\AEInclud\clswkmac.cls
Module=modVBErrors; ..\AEInclud\modvberr.bas
Module=modAEGlobals; ..\AEInclud\modAEGlb.bas
Module=Utility; ..\AEInclud\Utility.bas
Module=Localize; ..\AEInclud\Localize.bas
ResFile32="aepool.res"
IconForm="frmPoolMgr"
Startup="Sub Main"
HelpFile=""
Title="APE Pool Manager"
ExeName32="AEPool.exe"
Path32="..\..\Retail"
Command32=""
Name="AEPoolMgr"
HelpContextID="0"
Description="Application Performance Explorer Pool Manager"
CompatibleMode="1"
CompatibleEXE32="..\AECompat\AEPool.cmp"
MajorVer=2
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="Microsoft Corporation"
VersionFileDescription="Application Performance Explorer Pool Manager"
VersionLegalCopyright="Copyright © 1996-1998 Microsoft Corp."
VersionLegalTrademarks="Microsoft® is a registered trademark of Microsoft Corporation. Windows(TM) is a trademark of Microsoft Corporation"
VersionProductName="Application Performance Explorer Pool Manager"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=1
Unattended=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/FRMPOOL.FRM
+204
View File
@@ -0,0 +1,204 @@
VERSION 5.00
Begin VB.Form frmPoolMgr
BorderStyle = 1 'Fixed Single
Caption = "Pool Manager"
ClientHeight = 2175
ClientLeft = 6780
ClientTop = 1620
ClientWidth = 3915
ClipControls = 0 'False
Icon = "frmpool.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 2175
ScaleWidth = 3915
StartUpPosition = 3 'Windows Default
Begin VB.ListBox lstLog
Height = 645
IntegralHeight = 0 'False
Left = 3270
TabIndex = 0
Top = 540
Visible = 0 'False
Width = 855
End
Begin VB.Label lblSatisfiedCap
BackStyle = 0 'Transparent
Caption = "Requests Satisfied"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 200
TabIndex = 7
Top = 120
Width = 2535
End
Begin VB.Label lblRejectedCap
BackStyle = 0 'Transparent
Caption = "Requests Rejected"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 200
TabIndex = 6
Top = 480
Width = 2535
End
Begin VB.Label lblWorkersCap
BackStyle = 0 'Transparent
Caption = "Number of Workers"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 200
TabIndex = 5
Top = 840
Width = 2535
End
Begin VB.Label lblSatisfied
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2820
TabIndex = 4
Top = 120
Width = 1000
End
Begin VB.Label lblRejected
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2820
TabIndex = 3
Top = 480
Width = 1000
End
Begin VB.Label lblWorkers
BackStyle = 0 'Transparent
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 300
Left = 2820
TabIndex = 2
Top = 840
Width = 1000
End
Begin VB.Label lblStatus
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 780
Left = 195
TabIndex = 1
Top = 1200
Width = 3570
WordWrap = -1 'True
End
End
Attribute VB_Name = "frmPoolMgr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub Form_Load()
'Use clsPositionForm object to move
'Form to settings saved in registry
Dim oPosition As clsPositionForm
Set oPosition = New clsPositionForm
'Set U/I captions
ApplyFontToForm Me
lblRejectedCap.Caption = LoadResString(giLBL_REJECTED)
lblSatisfiedCap.Caption = LoadResString(giLBL_SATISFIED)
lblWorkersCap.Caption = LoadResString(giLBL_NUM_WORKERS)
Caption = LoadResString(giPOOLMGR_CAPTION)
#If ccShowList Then
oPosition.Move Me, True
lstLog.Visible = True
lblStatus.Visible = False
#Else
oPosition.Move Me, False
Width = giDEFAULT_FORM_WIDTH
Height = giDEFAULT_FORM_HEIGHT
#End If
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'Don't unload unless called from code.
If UnloadMode = vbFormControlMenu Then Cancel = False
End Sub
Private Sub Form_Resize()
#If ccShowList Then
Dim lX As Long
Dim lY As Long
If Me.ScaleHeight >= 2 * glFORM_MARGIN Then lY = (Me.ScaleHeight - (2 * glFORM_MARGIN)) Else lY = (2 * glFORM_MARGIN) - Me.ScaleHeight
If Me.ScaleWidth >= 2 * glFORM_MARGIN Then lX = (Me.ScaleWidth - (2 * glFORM_MARGIN)) Else lX = (2 * glFORM_MARGIN) - Me.ScaleWidth
lstLog.Move glFORM_MARGIN, glFORM_MARGIN, lX, lY
#End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Use clsPositionForm object to save
'forms position in registry
Dim oPosition As clsPositionForm
Set oPosition = New clsPositionForm
oPosition.Save Me
gbShow = False
End Sub
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/FRMPOOL.FRX
BIN
View File
Binary file not shown.
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/MODPOOL.BAS
+540
View File
@@ -0,0 +1,540 @@
Attribute VB_Name = "modPoolMgr"
Option Explicit
'Declarations
Declare Function GetTickCount Lib "Kernel32" () As Long
'Constants
Public Const gbSHOW_FORM_DEFAULT As Boolean = False
Public Const gbLOG_DEFAULT As Boolean = False
Public Const glWORKER_QUANTITY_DEFAULT As Long = 1
Public Const glLIST_BOX_MAX As Long = 500
Public Const giMAX_ALLOWED_RETRIES = 500
Public Const giRETRY_WAIT_MIN As Integer = 500 'Retry Wait is measure in DoEvent cycles
Public Const giRETRY_WAIT_MAX As Integer = 2500
Public Const gsPROTOCOL_DEFAULT As String = "ncacn_ip_tcp"
Public Const glAUTHENTICATION_DEFAULT As Long = 1
Public Const giWORKER_QUANTITY_DEFAULT As Integer = 1
Public Const gbWORKER_EARLYBIND_DEFAULT As Integer = True
Public Const giERROR_THRESHOLD As Integer = 32700
Public Const glMAX_LONG As Long = 2147483647
'User Defined Errors which also serve as string
'resource indexes
Public Const giNO_WORKERS_CREATED As Integer = 32764
Public Const giINVALID_PARAMETER As Integer = 32765
Public Const giCONNECTION_SETTING_FAILED As Integer = 32750 'An error was returned by RacReg32
'String resourse keys for logging messages
Public Const giPOOL_NAME As Integer = 2
Public Const giGET_WORKER As Integer = 3
Public Const giRELEASE_WORKER As Integer = 4
Public Const giCALL_REJECTED_RETRY As Integer = 11
Public Const giUSING_NO_AUTHENTICATION As Integer = 12
Public Const giONLY_N_WORKERS_CREATED As Integer = 13
Public Const giCOULD_NOT_CREATE_WORKER_ON_MACHINE As Integer = 14
Public Const giALL_WORKERS_CREATED As Integer = 15
Public Const giCOULD_NOT_CREATE_LOCAL_WORKER As Integer = 16
Public Const giERROR_PREFIX As Integer = 17
Public Const giFONT_CHARSET_INDEX As Integer = 30
Public Const giFONT_NAME_INDEX As Integer = 31
Public Const giFONT_SIZE_INDEX As Integer = 32
'String resource keys for Form captions
Public Const giLBL_SATISFIED As Integer = 50
Public Const giLBL_REJECTED As Integer = 51
Public Const giLBL_NUM_WORKERS As Integer = 52
Public Const giPOOLMGR_CAPTION As Integer = 53
Public Const giRACREG_ERROR_CODE_OFFSET = 200 'Add offset to racreg32 error codes
'to make corresponding resource string key
'Public variables
Public gcWorkers As Collection 'This is basically the pool of available workers
Public gcWorkerMachines As Collection 'Collection of clsWorkerMachines objects used
'keep track of how many worker objects are on
'each remote worker machine.
Public glInstances As Long 'A count of the number of instances made of PoolMgr
Public gbShow As Boolean 'If true show PoolMgr form
Public gbLog As Boolean 'If True log PoolMgr Events
Public goLogger As APEInterfaces.ILogger
Public gbLogWorkers As Boolean 'Flag to track status of
'Worker property Log
Public gbUnloading As Boolean 'Flag used by Class_terminate
Public giWorkerCount As Integer 'Number of Worker instanciated, This can be different
'than gcWorkers.Count if a Worker in the collection
'is marked for removal it will not be included in giWorkerCount
Public gbPersistentServices As Boolean 'Flag keeps track of Worker
'property PersistentServices
'If true Workers keep reference to
'all Service objects used else they
'drop references after each use.
Public gbEarlyBindServices As Boolean 'Flag to track status of
'Worker property EarlyBound
Public gbStopTest As Boolean 'Stop Test flag, checked by many procedures
'that will discontinue their processes if true
Public gsProtocol As String 'Protocol sequence to use when connecting to Workers
Public glAuthentication As Long 'Authentication level to use when connecting to Workers
Public gbUseDCOM As Boolean 'If true use DCOM to create workers instead of Remote Automation
Public glRequestsSatisfied As Long
Public glRequestsRejected As Long
Public Sub CountInitialize()
'-------------------------------------------------------------------------
'Purpose: Keep track of number instances of PoolMgr and Pool
' To be called by a public creatable class in its initialize
' event. To keep track of how many public creatable objects
' are initialized. Initialize the PoolMgr application if
' this is the first time it is called.
'Effects:
' If this is the first instanciation
' Put the PoolMgr in a "Ready" state. Load Workers
' Set default properties, Show form and load logger if necessary.
' [glInstances]
' increments by one
'-------------------------------------------------------------------------
Dim i As Integer
Dim oWork As clsWorker 'Object storing Workers and related informantion
Dim oWorkerMachine As clsWorkerMachines 'Object that stores how many
'Workers are on what machines
Dim sReturn As String 'Return of SetWorkersOnMachine function
On Error GoTo CountInitializeError
glInstances = glInstances + 1
If glInstances = 1 Then
App.OleServerBusyRaiseError = True
App.OleServerBusyTimeout = 10000
'Set default property values
gbShow = gbSHOW_FORM_DEFAULT
gbLog = gbLOG_DEFAULT
gsProtocol = gsPROTOCOL_DEFAULT
glAuthentication = glAUTHENTICATION_DEFAULT
gbEarlyBindServices = gbWORKER_EARLYBIND_DEFAULT
'Create Logger class object early so
'potential errors could be logged
If gbLog Then Set goLogger = CreateObject("AELogger.Logger")
'Create collection objects
Set gcWorkers = New Collection
Set gcWorkerMachines = New Collection
'Add an item to represent number of workers on the local machine
Set oWorkerMachine = New clsWorkerMachines
gcWorkerMachines.Add oWorkerMachine
'Load the default amount of workers and add
'them to the gcWorkers Collection
sReturn = SetWorkersOnMachine(False, "", giWORKER_QUANTITY_DEFAULT)
'Only show the form if gbShow is true
If gbShow Then
With frmPoolMgr
.Show
.lblStatus.Caption = ""
.lblWorkers.Caption = CStr(giWorkerCount)
.lblSatisfied.Caption = 0
.lblRejected.Caption = 0
End With
End If
gbUnloading = False
End If
Exit Sub
CountInitializeError:
Select Case Err.Number
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 goLogger = oInstancer.Object("AELogger.Logger")
Set oInstancer = Nothing
Resume Next
Case Else
LogError Err
Resume Next
End Select
End Sub
Public Sub CountTerminate()
'-------------------------------------------------------------------------
'Purpose: Keep track of number instances of PoolMgr and Pool
' To be called by a public creatable class in its terminate
' event. To keep track of how many public creatable objects
' are initialized. Terminate the PoolMgr application if
' this is the last time called.
'Effects:
' Unload all objects, and unload form so that this application
' will close
' [glInstances]
' decrements by one
'-------------------------------------------------------------------------
Dim oWorker As clsWorker
On Error GoTo Class_TerminateError
glInstances = glInstances - 1
'If already started unloading don't check
'instance count again
If Not gbUnloading Then
If glInstances = 0 Then
gbUnloading = True
For Each oWorker In gcWorkers
Set oWorker.Worker = Nothing
Set oWorker = Nothing
Next
Set goLogger = Nothing
Set gcWorkers = Nothing
Set gcWorkerMachines = Nothing
giWorkerCount = 0
Unload frmPoolMgr
End If
End If
Exit Sub
Class_TerminateError:
LogError Err
Resume Next
End Sub
Public Sub LogEvent(intMessage As Integer)
'Receives Message key which is used to look
'up a resource string. The logrecord is sent to the
'Logger object if gbLog is true
On Error GoTo LogEventError
If gbLog Then
goLogger.Record LoadResString(giPOOL_NAME), 0, LoadResString(intMessage), GetTickCount()
End If
#If ccShowList Then
'If the form is visible display log on form
If gbShow Then
DisplayString "0" & gsSEPERATOR & LoadResString(intMessage)
End If
#End If
Exit Sub
LogEventError:
LogError Err
Exit Sub
End Sub
Public Sub LogError(ByVal oErr As ErrObject)
'Display error on form with no user input required
'Log error if logging is on
Dim s As String
s = LoadResString(giERROR_PREFIX) & Str$(oErr.Number) & gsSEPERATOR & oErr.Source & gsSEPERATOR & oErr.Description
#If ccShowList Then
If Not gbShow Then
frmPoolMgr.Show
gbShow = True
End If
DisplayString s
#Else
DisplayStatus s
#End If
If gbLog And glInstances <> 0 Then
goLogger.Record LoadResString(giPOOL_NAME), 0, LoadResString(giERROR_PREFIX) & Str$(oErr.Number) & gsSEPERATOR & oErr.Source & gsSEPERATOR & oErr.Description, GetTickCount()
End If
End Sub
Sub DisplayStatus(sText As String)
If gbShow Then AlignTextToBottom frmPoolMgr.lblStatus, sText
End Sub
Sub DisplayString(sText As String)
#If ccShowList Then
'Controls the length of the list box
'and sets ListIndex
Dim lstLog As ListBox
If gbShow Then
Set lstLog = frmPoolMgr.lstLog
If lstLog.ListCount = glLIST_BOX_MAX Then lstLog.Clear
lstLog.AddItem sText, 0
End If
#End If
End Sub
Sub Main()
End Sub
Public Function SetWorkersOnMachine(bRemote As Boolean, sMachineName As String, lQuantityOnMachine As Long) As String
'-------------------------------------------------------------------------
'Purpose: Sets the quantity of instanciated Workers on a particular machine
'IN:
' [bRemote]
' If true adjust number of workers on a remote machine; else,
' adjust the number on the local machine.
' [sMachineName]
' Name of machine to adjust the level of instanciated Workers
' [lQuantityOnMachine]
' Number of Instantiated Workers that should be on specified
' machine.
'Return: Discription of Errors that should be displayed to user
'Effects:
' [gcWorkers]
' The number of Workers in this collection will be adjusted
' [gcWorkerMachines]
' An item may be added or removed or edited
'-------------------------------------------------------------------------
Dim oRacReg As RacReg.RegClass 'Object to set automation connection settings
Dim oWorkerMachine As clsWorkerMachines 'Object that stores how many workers are on
'a machine, retrieved from global collection
Dim oWorkerProvider As APEInterfaces.IWorkerProvider 'Server that can be instanciated on remote
'machines to provide Worker objects
Dim lWorkerToRemove As Long 'ID of Worker found to remove
Dim oWork As clsWorker 'clsWorker object that hold reference to a Worker
'and information related to it
Dim lAdd As Long 'New ID for New Worker
Dim sErrors As String 'Discription of Errors that will be returned
Dim bAddingWorker As Boolean 'If true, adding and configuring worker
'used by error handling
Dim iRetry As Integer 'Error retry counter
Dim iResult As Integer 'RacReg error code
On Error GoTo SetWorkersOnMachineError
'Validate lQuantityOnMachine
If lQuantityOnMachine < 0 Then lQuantityOnMachine = 0
'Set registry for local or remote machine name
Set oRacReg = New RacReg.RegClass
If bRemote Then
If gbUseDCOM Then
iResult = oRacReg.SetDCOMServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName)
Else
iResult = oRacReg.SetAutoServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName, gsProtocol, glAuthentication)
End If
Else
'Make sure the Machine name string is zero length
sMachineName = ""
'Make sure AEWorker.Worker is registered for local instanciation
'Because Clients may have been run on this machine and may have
'left the connection settings remote if they did not unload properly
iResult = oRacReg.SetAutoServerSettings(False, "AEWorker.Worker")
End If
If iResult <> 0 Then GoTo SetWorkersOnMachine_RacRegError
'Get the clsWorkerMachines object to store information in
If Not bRemote Then
'it is definitely the first item in the collection
Set oWorkerMachine = gcWorkerMachines.Item(1)
Else
'if it is in the collection it is stored by a key
'equaling the machine name
'If error equals ERR_INVALID_PROCEDURE_CALL there
'are no Workers on specified machine and no clsWorkerMachines
'class object to represent them
On Error Resume Next
Set oWorkerMachine = gcWorkerMachines.Item(sMachineName)
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
On Error GoTo SetWorkersOnMachineError
'Don't create a new clsWorkerMachine object of
'lQuantityOnMachine is zero
If lQuantityOnMachine <= 0 Then Exit Function
Set oWorkerMachine = New clsWorkerMachines
'If an error occurs creating WorkerProvider the current machine name
'can not be used. Treat error as if a Worker can not be created on
'paticular machine.
bAddingWorker = True
Set oWorkerMachine.WorkerProvider = CreateObject("AEWorkerProvider.WorkerProvider")
bAddingWorker = False
gcWorkerMachines.Add oWorkerMachine, sMachineName
With oWorkerMachine
.Remote = True
.MachineName = sMachineName
End With
End If
On Error GoTo SetWorkersOnMachineError
Set oWorkerProvider = oWorkerMachine.WorkerProvider
End If
'Now see if more workers need destroyed on this machine
With oWorkerMachine
If .WorkerKeys.Count > lQuantityOnMachine Then
Do Until .WorkerKeys.Count <= lQuantityOnMachine
Debug.Assert .WorkerKeys.Count = gcWorkers.Count
'Find a worker on this machine
lWorkerToRemove = .WorkerKeys(.WorkerKeys.Count)
.WorkerKeys.Remove .WorkerKeys.Count
'Remove the found worker
'Do not destroy the Worker if it is busy
'instead just flip its RemoveMe flag
giWorkerCount = giWorkerCount - 1
If gcWorkers.Item(CStr(lWorkerToRemove)).Busy Then
gcWorkers.Item(CStr(lWorkerToRemove)).RemoveMe = True
Else
iRetry = 0
Set oWork = gcWorkers.Item(CStr(lWorkerToRemove))
oWork.Worker.ShutDown
Set gcWorkers.Item(CStr(lWorkerToRemove)).Worker = Nothing
gcWorkers.Remove CStr(lWorkerToRemove)
End If
Loop
Else
'Else lQuantityOnMachine must be greater than .WorkerKeys.count
'So add to the collection
bAddingWorker = True
Do Until .WorkerKeys.Count = lQuantityOnMachine
'Choose a unique key
lAdd = gcWorkers.Count + 1
Set oWork = New clsWorker
oWork.Busy = False
oWork.ID = lAdd
'Get a new Worker object
If bRemote Then
Set oWork.Worker = oWorkerProvider.GetWorker
Else
Set oWork.Worker = CreateObject("AEWorker.Worker")
End If
'Set the WorkerID property of AEWorker.Worker
'Set the new worker property to the properties
'that have been set for the any other workers
iRetry = 0
oWork.Worker.SetProperties gbLogWorkers, gbEarlyBindServices, _
gbPersistentServices, lAdd
'Add the clsWorker class object which holds a
'reference to the Worker class object to gcWorkers collection
'Use the WorkerID as the key
.WorkerKeys.Add lAdd
gcWorkers.Add oWork, CStr(lAdd)
giWorkerCount = giWorkerCount + 1
iRetry = 0
Loop
bAddingWorker = False
End If
End With
SetWorkersOnMachineEnd:
'Update the WorkerCount label in the U/I
'Set connection settings back to local
iResult = oRacReg.SetAutoServerSettings(False, "AEWorkerProvider.WorkerProvider")
If iResult <> 0 Then GoTo SetWorkersOnMachine_RacRegError
If gbShow Then
With frmPoolMgr.lblWorkers
.Caption = gcWorkers.Count
.Refresh
End With
End If
'If the WorkerKeys.count = 0 and bRemote is true
'then the clsWorkerMachines class
'object in gcWorkerMachines should be removed
'Don't remove the clsWorkerMachines object representing the
'local machine. Index one is reserved for the local machine.
If oWorkerMachine.WorkerKeys.Count = 0 And bRemote Then
On Error Resume Next
gcWorkerMachines.Remove sMachineName
End If
SetWorkersOnMachine = sErrors
Exit Function
SetWorkersOnMachine_RacRegError:
Err.Raise giCONNECTION_SETTING_FAILED
SetWorkersOnMachineError:
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 for stop test
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
LogEvent giCALL_REJECTED_RETRY
Resume
Else
'We reached our max retries
GoTo SetWorkersOnMachineUnexpectedError
End If
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 oWorkerProvider = oInstancer.Object("AEWorkerProvider.WorkerProvider")
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 s As String
s = ReplaceString(LoadResString(giUSING_NO_AUTHENTICATION), gsNAME_TOKEN, sMachineName)
LogText s
sErrors = s & vbCrLf
iResult = oRacReg.SetAutoServerSettings(True, "AEWorkerProvider.WorkerProvider", , sMachineName, gsProtocol, glAUTHENTICATION_DEFAULT)
Resume
Case giCONNECTION_SETTING_FAILED
sErrors = ReplaceString(LoadResString(giCONNECTION_SETTING_FAILED), gsNAME_TOKEN, LoadResString(giRACREG_ERROR_CODE_OFFSET + iResult))
Err.Raise giNO_WORKERS_CREATED, , sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
Case Else
SetWorkersOnMachineUnexpectedError:
'There are three cases to respond to if there is an unexpected error
'1- If the error occured while NOT adding a worker it most likely
' occured while removing one. Resume Next to insure that the worker
' is removed from the workers collection.
'2- If we were adding a worker and the worker class was registered local
' log the error, and add it to the sError string, but raise the
' giNO_WORKERS_CREATED error, because the system has a critical problem
' if a local worker can not be created.
'3- If we were adding a worker and the worker class was registered remote
' log the error, and add it to the sError string. Exit procedure so
' that calling procedure can try creating workers on another machine
Dim sSource As String
sSource = Err.Source
sErrors = sErrors & sMachineName & gsSEPERATOR & sSource & gsSEPERATOR & Err.Description & vbCrLf
LogError Err
If Not bAddingWorker Then
Resume Next
Else
If bRemote Then
sErrors = sErrors & vbCrLf & ReplaceString(LoadResString(giCOULD_NOT_CREATE_WORKER_ON_MACHINE), gsNAME_TOKEN, sMachineName)
Resume SetWorkersOnMachineEnd
Else
iResult = oRacReg.SetAutoServerSettings(False, "AEWorkerProvider.WorkerProvider")
sErrors = sErrors & vbCrLf & LoadResString(giCOULD_NOT_CREATE_LOCAL_WORKER)
Err.Raise giNO_WORKERS_CREATED, sSource, sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
End If
End If
End Select
End Function
Public Sub LogText(sMsg As String)
'-------------------------------------------------------------------------
'Purpose: Passes that passed string as a log record
' to the logger
'In: [sMsg]
' String to be logged
'Assumption:
' If gbLog is true then goLogger is a valid reference to
' AELogger.Logger class object
'-------------------------------------------------------------------------
On Error GoTo LogTextError
If gbLog And Not gbStopTest Then
goLogger.Record LoadResString(giPOOL_NAME), 0, sMsg, GetTickCount()
End If
'If the form is visible display log on form
#If ccShowList Then
DisplayString sMsg
#End If
Exit Sub
LogTextError:
LogError Err
Exit Sub
End Sub
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/MSCREATE.DIR
View File
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/POOL.CLS
+130
View File
@@ -0,0 +1,130 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'False
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
END
Attribute VB_Name = "Pool"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "APE Pool Manager"
Option Explicit
Implements APEInterfaces.IPool
'Private variable to hold the WorkerID of the Worker which was
'passed to a client
Private mlWorkerID As Long
'A count of references is kept to keep track of
'how many references to this same worker it has.
'When the count is 0, moWorker is added back into
'the global collection and set to nothing.
Private mlReferenceCount As Long
Public Function IPool_GetWorker() As APEInterfaces.IWorker
Attribute IPool_GetWorker.VB_Description = "Returns a AEWorker.Worker object and reserves it for the calling applications use."
'A client uses this method to get a reference to a worker
'Find a worker that is not busy (passed to another client).
'Mark the Worker as busy
'Store the WorkerID in the Private Class Module level
'mlWorkerID
Dim oWork As clsWorker
Dim bFoundWorker As Boolean
On Error GoTo GetWorkerError
LogEvent giGET_WORKER
'If mlWorkerID does not equal zero then the client
'that has reference to this instance of this class
'already has a worker. Therefore just pass a reference
'to the same worker.
If mlWorkerID <> 0 Then
mlReferenceCount = mlReferenceCount + 1
Set IPool_GetWorker = gcWorkers.Item(CStr(mlWorkerID)).Worker
glRequestsSatisfied = glRequestsSatisfied + 1
If gbShow Then
With frmPoolMgr.lblSatisfied
.Caption = CStr(glRequestsSatisfied)
.Refresh
End With
End If
Else
'The client does not have any other references to a Worker
'Find a worker that does not have any connections made
'by other clients
bFoundWorker = False
For Each oWork In gcWorkers
If Not oWork.Busy Then
oWork.Busy = True
mlWorkerID = oWork.ID
mlReferenceCount = mlReferenceCount + 1
bFoundWorker = True
Set IPool_GetWorker = oWork.Worker
'Update statistics
glRequestsSatisfied = glRequestsSatisfied + 1
If gbShow Then
With frmPoolMgr.lblSatisfied
.Caption = CStr(glRequestsSatisfied)
.Refresh
End With
End If
Exit For
End If
Next oWork
If Not bFoundWorker Then
'All workers are being used by other clients
'set function equal to nothing
Set IPool_GetWorker = Nothing
glRequestsRejected = glRequestsRejected + 1
If gbShow Then
With frmPoolMgr.lblRejected
.Caption = CStr(glRequestsRejected)
.Refresh
End With
End If
End If
End If
Exit Function
GetWorkerError:
Select Case Err.Number
Case ERR_OVER_FLOW
LogError Err
If glRequestsSatisfied = glMAX_LONG Then glRequestsSatisfied = 0
If glRequestsRejected = glMAX_LONG Then glRequestsRejected = 0
Resume Next
Case Else
LogError Err
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Function
Public Sub IPool_ReleaseWorker()
Attribute IPool_ReleaseWorker.VB_Description = "Notifies the AEPoolMgr that an AEWorker.Worker object received by GetWorker is no longer referenced by the calling application."
'Called by a client when it destroys a reference to
'a worker that it received by calling GetWorker
'Check to see if the client has another reference to
'the worker. If it does not, mark the worker that was passed
'to the client as not busy and set mlWorkerID = to 0.
LogEvent giRELEASE_WORKER
'If ReferenceCount is zero then this method is being called without
'having an unreleased reference to the worker
If mlReferenceCount = 0 Then Exit Sub
mlReferenceCount = mlReferenceCount - 1
'If ReferenceCount = 0 now then client has released
'its only reference to a worker
If mlReferenceCount = 0 Then
gcWorkers.Item(CStr(mlWorkerID)).Busy = False
mlWorkerID = 0
End If
End Sub
Private Sub Class_Initialize()
CountInitialize
End Sub
Private Sub Class_Terminate()
CountTerminate
End Sub
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/POOL.ICO
LFS
BIN
View File
Binary file not shown.
build-env/VisualStudio6/Common/Tools/APE/Source/Aepool/POOLMGR.CLS
+599
View File
@@ -0,0 +1,599 @@
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'False
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
END
Attribute VB_Name = "PoolMgr"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Description = "APE Pool Manager"
Option Explicit
'-------------------------------------------------------------------------
'This public multi-use class provides the OLE interface for the APE Manager
'or another application designed to be the Manager
' It implements the IPoolManager interface
'-------------------------------------------------------------------------
Implements APEInterfaces.IPoolManager
'***********************
'Public Properties
'***********************
Public Property Let IPoolManager_ShowPool(ByVal bShow As Boolean)
Attribute IPoolManager_ShowPool.VB_Description = "Determines whether the AEPoolMgr shows a form."
'-------------------------------------------------------------------------
'Purpose: Show property determines whether or not a form
' is displayed while PoolMgr is loaded
'Effects: [gbShow] becomes value of parameter
' If parameter is true frmPoolMgr is show, else form
' is Unloaded.
'-------------------------------------------------------------------------
If Not gbShow = bShow Then
gbShow = bShow
If bShow Then
With frmPoolMgr
.Show
.lblWorkers.Caption = gcWorkers.Count
.lblSatisfied.Caption = CStr(glRequestsSatisfied)
.lblRejected.Caption = CStr(glRequestsRejected)
End With
Else
Unload frmPoolMgr
End If
End If
End Property
Public Property Get IPoolManager_ShowPool() As Boolean
IPoolManager_ShowPool = gbShow
End Property
Public Property Let IPoolManager_LogPool(ByVal bLog As Boolean)
Attribute IPoolManager_LogPool.VB_Description = "Determines if the AEPoolMgrr logs its events and errors to the AELogger.Logger object."
'-------------------------------------------------------------------------
'Purpose: If log is true create logger class object and log Services
'Effects: [gbLog] becomes value of parameter
' [goLogger] is set to a new AELogger.Logger object if parameter
' is true. If false goLogger is destroyed
'-------------------------------------------------------------------------
On Error GoTo LogPoolError
If Not gbLog = bLog Then
gbLog = bLog
If bLog Then
Set goLogger = CreateObject("AELogger.Logger")
Else
Set goLogger = Nothing
End If
End If
Exit Property
LogPoolError:
Select Case Err.Number
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 goLogger = oInstancer.Object("AELogger.Logger")
Set oInstancer = Nothing
Resume Next
Case Else
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Property
Public Property Get IPoolManager_LogPool() As Boolean
IPoolManager_LogPool = gbLog
End Property
'********************
'Worker Properties
'********************
Public Property Let IPoolManager_LogWorkers(ByVal bLog As Boolean)
Attribute IPoolManager_LogWorkers.VB_Description = "Sets the value that is used to set the Log property of AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the Log property of all the Workers
'Effects:
' [gbLogWorkers]
' becomes equal to the passed parameter
'Assumes: There is a collection of one or more valid Worker objects
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to all the Workers
Dim oWork As clsWorker
If Not bLog = gbLogWorkers Then
For Each oWork In gcWorkers
oWork.Worker.Log = bLog
Next oWork
gbLogWorkers = bLog
End If
End Property
Public Property Get IPoolManager_LogWorkers() As Boolean
IPoolManager_LogWorkers = gbLogWorkers
End Property
Public Property Let IPoolManager_PersistentServices(ByVal bPersistent As Boolean)
Attribute IPoolManager_PersistentServices.VB_Description = "Sets the value that is used to set the PersistentServices property of AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the PersistentServices property of all the Workers
'Effects:
' [gbPersistentServices]
' becomes equal to the passed parameter
'Assumes: There is a collection of one or more valid Worker objects
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to all the Workers
Dim oWork As clsWorker
If Not bPersistent = gbPersistentServices Then
For Each oWork In gcWorkers
oWork.Worker.PersistentServices = bPersistent
Next oWork
gbPersistentServices = bPersistent
End If
End Property
Public Property Get IPoolManager_PersistentServices() As Boolean
IPoolManager_PersistentServices = gbPersistentServices
End Property
Public Property Let IPoolManager_EarlyBindServices(ByVal bEarlyBind As Boolean)
Attribute IPoolManager_EarlyBindServices.VB_Description = "Sets the value that is used to set the EarlyBindServices property of AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the EarlyBindServices property of all the Workers
'Effects:
' [gbEarlyBindServices]
' becomes equal to the passed parameter
'Assumes: There is a collection of one or more valid Worker objects
'-------------------------------------------------------------------------
'If the property setting actually
'changes the current property pass
'the property change to all the Workers
Dim oWork As clsWorker
If Not bEarlyBind = gbEarlyBindServices Then
For Each oWork In gcWorkers
oWork.Worker.EarlyBindServices = bEarlyBind
Next oWork
gbEarlyBindServices = bEarlyBind
End If
End Property
Public Property Get IPoolManager_EarlyBindServices() As Boolean
IPoolManager_EarlyBindServices = gbEarlyBindServices
End Property
'****************************
'Public Methods
'****************************
Public Sub IPoolManager_SetProperties(ByVal bShow As Boolean, Optional ByVal bLog As Variant)
Attribute IPoolManager_SetProperties.VB_Description = "Sets all of the AEPoolMgr.PoolMgr related properties in one method call."
'-------------------------------------------------------------------------
'Purpose: To set the PoolMgr properties in one method call
'Effects: Sets the following properties to parameter values
' ShowPool, LogPool, WorkerQuantity
'-------------------------------------------------------------------------
With Me
.IPoolManager_ShowPool = bShow
If Not IsMissing(bLog) Then .IPoolManager_LogPool = bLog
End With
End Sub
Public Sub IPoolManager_SetWorkerProperties(ByVal bLog As Boolean, Optional ByVal bEarlyBindServices As Variant, _
Optional ByVal bPersistentServices As Variant)
Attribute IPoolManager_SetWorkerProperties.VB_Description = "Sets all of the AEWorker.Worker related properties on one method call."
'-------------------------------------------------------------------------
'Purpose: To set the Worker properties in one method call
'Effects: Sets the following properties to parameter values
' ShowWorkers, LogWorkers, EarlyBindServices, PersistentServices
'-------------------------------------------------------------------------
Dim oWork As clsWorker
gbLogWorkers = bLog
If Not IsMissing(bEarlyBindServices) Then gbEarlyBindServices = bEarlyBindServices
If Not IsMissing(bPersistentServices) Then IPoolManager_PersistentServices = bPersistentServices
For Each oWork In gcWorkers
oWork.Worker.SetProperties gbLogWorkers, gbEarlyBindServices, gbPersistentServices
Next oWork
End Sub
Public Sub IPoolManager_SetConnectionProperties(ByVal bUseDCOM As Boolean, Optional ByVal sProtocol As Variant, _
Optional ByVal lAuthentication As Variant)
Attribute IPoolManager_SetConnectionProperties.VB_Description = "Sets the connection parameters to be used when creating remote AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: To set the Connection Settings that the PoolMgr will use
' to connect to remote Workers
'In:
' [bUseDCOM]
' If true workers will be created using DCOM instead of
' Remote Automation.
' [sProtocol]
' Protocol sequence to use when connecting to remote objects
' [lAuthentication]
' Authentication level to use
'Effects:
' [gbUseDCOM]
' becomes equal to bUseDCOM parameter
' [gsProtocol]
' becomes equal to sProtocol parameter
' [glAuthentication]
' becomes equal to lAuthentication parameter
'-------------------------------------------------------------------------
Dim iVarType As Integer 'Variant type code of lAuthentication
gbUseDCOM = bUseDCOM
If Not IsMissing(sProtocol) Then
If VarType(sProtocol) = vbString Then gsProtocol = sProtocol
End If
If Not IsMissing(lAuthentication) Then
iVarType = VarType(lAuthentication)
If iVarType = vbLong Or iVarType = vbInteger Or iVarType = vbDouble Or iVarType = vbSingle Then
glAuthentication = lAuthentication
End If
End If
End Sub
Public Function IPoolManager_CreateWorkers(ByVal bRemoteWorkers As Boolean, Optional ByVal lWorkerQuantity As Variant, _
Optional ByVal lWorkersPerMachine As Variant, Optional ByVal vaMachineList As Variant, _
Optional ByVal bUseLocalMachine As Variant) As String
Attribute IPoolManager_CreateWorkers.VB_Description = "Creates AEWorker.Worker objects. Returns a string that describes any errors that occurred."
'-------------------------------------------------------------------------
'Purpose: Sets the settings for remote workers. These settings provide
' The PoolMgr the information needed to create Workers on several
' remote machines rather than just the local one.
'IN:
' [bRemoteWorkers]
' If true, the PoolMgr will create Workers on remote machines.
' If false, the PoolMgr will only create Workers on the local machine.
' [lWorkerQuantity]
' The total number of Workers to be created.
' [lWorkersPerMachine]
' A variant long specifing the maximum allowed number of Workers
' to create on a single machine.
' [vaMachineList]
' A string array, providing the list of machine names
' to create the workers on. If this is not a valid
' array of strings it will be treated like no machine
' names were specified
' [bUseLocalMachine]
' If true, include local machine in list of remote machine names
'Return: String to display to user and print to log file. Will contain
' any error information and the total number of workers created
'-------------------------------------------------------------------------
Static stbUseDCOM As Boolean 'Last DCom automation setting used
Static stsProtocol As String 'Last Automation protocol setting used
Static stlAuthentication As Long 'Last Automation Authentication setting used
Dim sResult As String 'Result of SetWorkersOnMachine function
Dim sErrors As String 'String with error descriptions to return for
'display to user
Dim oWorkerMachine As clsWorkerMachines 'Object in gcWorkerMachines collection
'that stores how many workers are instanciated
'on a particular machine
Dim lUB As Long 'Ubound of passed array
Dim bListExists As Boolean 'True if a array of machine names exists
Dim bInList As Boolean 'If true the Machine Name is in the passed array
Dim i As Integer 'For...Next loop counter
Dim lAdd As Long 'Number of Workers to add on machine
Dim lNumOnMach As Long 'Number of workers on a machine
Dim iVarType As Integer 'Variant data type of a parameter
On Error GoTo CreateWorkersError
'Validate the parameters
'validate lWorkerQuantity
iVarType = VarType(lWorkerQuantity)
If Not (iVarType = vbLong Or iVarType = vbInteger Or iVarType = vbSingle Or iVarType = vbDouble) Then
Err.Raise giINVALID_PARAMETER, , LoadResString(giINVALID_PARAMETER)
End If
If bRemoteWorkers Then
'validate vaMachineList
iVarType = VarType(vaMachineList)
If (iVarType = vbArray + vbString) Or (iVarType = vbArray + vbVariant) Then
On Error Resume Next
lUB = UBound(vaMachineList)
If Err.Number <> ERR_SUBSCRIPT_OUT_OF_RANGE Then
bListExists = True
End If
On Error GoTo CreateWorkersError
End If
'validate lworkerspermachine
iVarType = VarType(lWorkersPerMachine)
If Not (iVarType = vbLong Or iVarType = vbInteger Or iVarType = vbSingle Or iVarType = vbDouble) Then
Err.Raise giINVALID_PARAMETER, , LoadResString(giINVALID_PARAMETER)
End If
'validate bUseLocalMachine
On Error Resume Next
bUseLocalMachine = CBool(bUseLocalMachine)
If Err.Number = ERR_TYPE_MISMATCH Then
On Error GoTo CreateWorkersError
Err.Raise giINVALID_PARAMETER, , LoadResString(giINVALID_PARAMETER)
Else
On Error GoTo CreateWorkersError
End If
End If
'First destroy all workers that can not be used any more
'If connection settings have been changed or if bRemoteWorkers
'is false all Workers on remote machines must be destroyed
If (Not bRemoteWorkers) Or (stbUseDCOM <> gbUseDCOM) Or (stsProtocol <> gsProtocol) Or (stlAuthentication <> glAuthentication) Then
'Reset the Last Connection setting static variables
stbUseDCOM = gbUseDCOM
stsProtocol = gsProtocol
stlAuthentication = glAuthentication
'Destroy all remote Workers
For Each oWorkerMachine In gcWorkerMachines
If oWorkerMachine.Remote Then
sResult = SetWorkersOnMachine(True, oWorkerMachine.MachineName, 0)
sErrors = sErrors & sResult
End If
Next
Else
'If we did not destroy all workers on remote machines
'destroy workers that are on machines that are not
'in the passed list of remote worker machines
'Check if the machine names currently in gcWorkerMachines
'are in the passed array
For Each oWorkerMachine In gcWorkerMachines
If oWorkerMachine.Remote Then
bInList = False
If bListExists Then
For i = 0 To lUB
If vaMachineList(i) = oWorkerMachine.MachineName Then
bInList = True
Exit For
End If
Next
End If
If Not bInList Then
sResult = SetWorkersOnMachine(True, oWorkerMachine.MachineName, 0)
sErrors = sErrors & sResult
End If
End If
Next
End If
'See if Workers on local machine need destroyed
If bRemoteWorkers Then
If Not bUseLocalMachine Then
sResult = SetWorkersOnMachine(False, "", 0)
sErrors = sErrors & sResult
End If
End If
'Create Workers
If Not bRemoteWorkers Then
'Just create all workers on local machine
sResult = SetWorkersOnMachine(False, "", CLng(lWorkerQuantity))
sErrors = sErrors & sResult
Else
'Now loop through machine name list and add workers
'to each machine until giWorkerCount equals
'lWorkerQuantity or the end of the machine list is
'reached
If giWorkerCount <= lWorkerQuantity Then
'First create workers on local machine
If bUseLocalMachine Then
'Get the number of workers currently on this machine
lNumOnMach = gcWorkerMachines.Item(1).WorkerKeys.Count
'Set number of Workers to be on current machine
lAdd = lWorkersPerMachine
If lAdd > (lWorkerQuantity + lNumOnMach) - giWorkerCount Then lAdd = (lWorkerQuantity + lNumOnMach) - giWorkerCount
sResult = SetWorkersOnMachine(False, "", lAdd)
sErrors = sErrors & sResult
End If
If bListExists Then
Do Until (i > lUB Or giWorkerCount = lWorkerQuantity)
On Error Resume Next
'Get the number of workers currently on this machine
Set oWorkerMachine = gcWorkerMachines.Item(vaMachineList(i))
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
lNumOnMach = 0
Else
lNumOnMach = oWorkerMachine.WorkerKeys.Count
End If
On Error GoTo CreateWorkersError
'Set number of Workers to be on current machine
lAdd = lWorkersPerMachine
If lAdd > (lWorkerQuantity + lNumOnMach) - giWorkerCount Then lAdd = (lWorkerQuantity + lNumOnMach) - giWorkerCount
sResult = SetWorkersOnMachine(True, CStr(vaMachineList(i)), lAdd)
sErrors = sErrors & sResult
i = i + 1
Loop
End If
Else
'There may be too many workers, so destroy workers to
'make the right count
If bListExists Then
i = lUB
Do While i >= 0
On Error Resume Next
'Get the number of workers currently on this machine
Set oWorkerMachine = gcWorkerMachines.Item(vaMachineList(i))
If Err.Number = ERR_INVALID_PROCEDURE_CALL Then
lNumOnMach = 0
Else
lNumOnMach = oWorkerMachine.WorkerKeys.Count
End If
On Error GoTo CreateWorkersError
If lNumOnMach > 0 Then
lAdd = 0
If lNumOnMach > (giWorkerCount - lWorkerQuantity) Then lAdd = lNumOnMach - (giWorkerCount - lWorkerQuantity)
sResult = SetWorkersOnMachine(True, CStr(vaMachineList(i)), lAdd)
sErrors = sErrors & sResult
End If
i = i - 1
Loop
End If
'if there are still too many workers
'reduce the number of workers on the local machine
If giWorkerCount > lWorkerQuantity Then
lNumOnMach = gcWorkerMachines.Item(1).WorkerKeys.Count
lAdd = 0
If lNumOnMach > (giWorkerCount - lWorkerQuantity) Then lAdd = lNumOnMach - (giWorkerCount - lWorkerQuantity)
sResult = SetWorkersOnMachine(False, "", lAdd)
sErrors = sErrors & sResult
End If
End If
End If
'Check if any workers were created and raise error if none were created
If giWorkerCount < lWorkerQuantity Then
If giWorkerCount = 0 Then
Err.Raise giNO_WORKERS_CREATED, , sErrors & vbCrLf & LoadResString(giNO_WORKERS_CREATED)
Else
sErrors = sErrors & vbCrLf & ReplaceString(LoadResString(giONLY_N_WORKERS_CREATED), gsNUMBER_TOKEN, CStr(giWorkerCount))
End If
Else
sErrors = sErrors & vbCrLf & LoadResString(giALL_WORKERS_CREATED)
End If
IPoolManager_CreateWorkers = sErrors
Exit Function
CreateWorkersError:
Select Case Err.Number
Case Is > giERROR_THRESHOLD
Err.Raise Err.Number + vbObjectError, Err.Source, Err.Description
Case Else
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Function
Public Function IPoolManager_GetRemoteLoggerCollection() As Collection
Attribute IPoolManager_GetRemoteLoggerCollection.VB_Description = "Returns a collection of remote AELogger.Logger objects that were created by remote AEWorker.Worker objects."
'-------------------------------------------------------------------------
'Purpose: Returnse the collection of loggers created on the same
' machines as remote Workers
'Assumes:
' [gcWorkerMachines]
' a valid collection of clsWorkerMachines object
' [clsWorkerMachines]
' If .Remote is true .WorkerKeys.Count is > 0
'-------------------------------------------------------------------------
Dim cRemoteLoggers As Collection 'Collection to return
Dim oWorkerMachine As clsWorkerMachines 'Object representing each Worker machine
Dim oLogger As APEInterfaces.ILogger 'Valid logger object or nothing
Set cRemoteLoggers = New Collection
For Each oWorkerMachine In gcWorkerMachines
With oWorkerMachine
If .Remote Then
Dim oWork As clsWorker
Set oWork = gcWorkers.Item(CStr(.WorkerKeys(1)))
Set oLogger = oWork.Worker.GetLogger
If Not oLogger Is Nothing Then
cRemoteLoggers.Add oLogger
End If
End If
End With
Next
If cRemoteLoggers.Count = 0 Then Set cRemoteLoggers = Nothing
Set IPoolManager_GetRemoteLoggerCollection = cRemoteLoggers
End Function
Public Sub IPoolManager_LoadServiceObject(ByVal ServiceLibClass As String, ByVal vServiceConfiguration As Variant)
Attribute IPoolManager_LoadServiceObject.VB_Description = "Causes all created AEWorker.Worker objects to create an object whose ProgID matches ServiceLibClass."
'-------------------------------------------------------------------------
'Purpose: Purpose is to call LoadServiceObject method in each
' instanciated worker. It is ignored if gbPeristentServices
' is false
'Assumes:
' [gcWorkers]
' Is a collection of valid AEWorker.Worker objects
'-------------------------------------------------------------------------
Dim oWork As clsWorker
If gbPersistentServices Then
For Each oWork In gcWorkers
oWork.Worker.LoadServiceObject ServiceLibClass, vServiceConfiguration
Next oWork
End If
End Sub
Public Sub IPoolManager_StopTest()
Attribute IPoolManager_StopTest.VB_Description = "Notifies AEPoolMgr that Worker requests and releases are being stopped."
'-------------------------------------------------------------------------
'Purpose: Stops all Pool Managers processes
' [gbStopTest]
' Becomes true
'-------------------------------------------------------------------------
'Call this to halt the Pool Manager and the Expediter
gbStopTest = True
Exit Sub
End Sub
Public Sub IPoolManager_StartTest()
Attribute IPoolManager_StartTest.VB_Description = "Prepares the AEPoolMgr to manage AEWorker.Worker objects after StopTest has been called."
'-------------------------------------------------------------------------
'Purpose: Call this to allow processing of GetWorker calls
'Effects:
' Resets U/I to look like PoolMgr just started
' Call Workers StartTest method to reset them
' [gbStopTest]
' Becomes False
'-------------------------------------------------------------------------
Dim oWork As clsWorker
Dim iRetry As Integer
'Reset stats
gbStopTest = False
glRequestsSatisfied = 0
glRequestsRejected = 0
If gbShow Then
With frmPoolMgr
.lblStatus.Caption = ""
.lblWorkers.Caption = CStr(giWorkerCount)
.lblSatisfied.Caption = 0
.lblRejected.Caption = 0
End With
End If
Exit Sub
StartTestError:
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 for stop test
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
LogEvent giCALL_REJECTED_RETRY
Resume
Else
'We reached our max retries
Resume Next
End If
Case Else
Err.Raise Err.Number, Err.Source, Err.Description
End Select
End Sub
'********************
'Private Procedures
'********************
Private Sub Class_Initialize()
CountInitialize
End Sub
Private Sub Class_Terminate()
CountTerminate
End Sub