Option Explicit ' Must "Dim" all variables
'<% ' <- turn on code coloring in Visual Interdev editor
'
' --------------------
' BBBBBB | |
' BB BB | aaaaa aaaaa | nn nnn
' BB BB | aa aa aa aa | nn nn Baan Company N.V.
' BBBBB | aa aa aa aa | nn nn (c) 1999, Baan E-Enterprise
' BB BB | aa aa a aa aa a | nn nn All Rights Reserved.
' BB BB | aaa aa aaa aa | nn nn
' BBBBBB | | http://www.baan.com
' --------------------'
'
'
' Setup.vbs
' =========
' This script is normally invoked from the E-Enterprise 2.x setup program, as part of the
' E-Enterprise installation process.
' However, it can also be invoked from the command line as a stand-alone utility.
'
' Context: Visual Basic script (.vbs), executed through CSCRIPT.EXE (Windows Scripting Host:
' WSH, version 4 or higher).
' For convenvience, the script can also be included in an ASP file and tested/debugged
' through IIS and Visual Interdev. This is done by including this file in an ASP file
' using the command:
'
'
'########################################################################
'# Constants & Globals
'########################################################################
' Set this constant to False if you want to debug program errors.
' Can also be done via command line switch /errorhandler
Const ERRORHANDLER = True
' Max. length of result message returned from the script
Const MAXLEN_RESULT = 400
' Globals
Public g_Arguments, g_ArgCount
' Membership ProgID's
Const MBS_OBJ_BROKCFG = "MemAdmin.BrokConfig"
Const MBS_OBJ_BROKSERVERS = "MemAdmin.BrokServers"
Const MBS_OBJ_LDAPCFG = "MemAdmin.LDAPConfig"
Const MBS_OBJ_DMAILCFG = "MemAdmin.DMailConfig"
Const MBS_OBJ_AUOCFG = "MemAdmin.AuoConfig"
Const MBS_OBJ_SETUPSTORE = "MemAdmin.DSConfig"
Const MBS_OBJ_DSCFG = "DSConfig.DSAccounts"
Const MBS_OBJ_DSPREP = "DSConfig.DSPrep"
Const MBS_OBJ_CREATOR = "ObjCreator.ObjCreator.1"
'########################################################################
'# Program entry point & main routine
'########################################################################
DoTheWork
'========================================================================
' DoTheWork
'
Sub DoTheWork()
' Separate handling for the "test_wsh" command (CSCRIPT Setup.vbs test_wsh)
On Error Resume Next
Dim Arg0
Arg0 = WScript.Arguments(0)
if Err.Number = 0 then ' no error, there is an argument present
if LCase(Arg0) = "test_wsh" then
' perform test_wsh and exit program
DoTestWSH
Exit Sub
end if
end if
On Error Goto 0
RetrieveArguments
ProcessArguments
If g_ErrorHandler Then On Error Resume Next
If IsRunningInASP() then
Response.Write "
"
End If
Select Case LCase(gCommand)
Case "install_site"
DoInstallSite
Case "reinstall_site"
DoReinstallSite
Case "uninstall_site"
DoUninstallSite
Case "secure_site"
DoSecureSite
Case "add_connections"
DoAddConnectionsToMap
Case "remove_connections"
DoRemoveConnectionsFromMap
Case "add_dsns"
DoAddSystemDsns
Case "remove_dsns"
DoRemoveSystemDsns
Case "create_container"
DoCreateContainer
Case "create_class"
DoCreateClass
Case "create_memserver"
DoCreateMembershipServer
Case "recreate_memserver"
DoRecreateMembershipServer
Case "delete_memserver"
DoDeleteMembershipServer
Case "config_memserver" ' <== THIS COMMAND IS ONLY MEANT
DoConfigMembershipServer ' <== FOR INTERNAL USE!!
Case "create_secauo"
DoCreateSecAuoProvider
Case "delete_secauo"
DoDeleteSecAuoProvider
Case "create_ssadmingroup"
DoCreateSSAdminGroup
Case "create_eeadmingroup"
DoCreateEEAdminGroup
Case "set_memauth"
DoSetMemAuthMethods
Case "add_memattr"
DoAddMembershipAttributes
Case "logon_sql"
DoLogonSql
Case "check_sqlconn"
DoCheckSqlConnection
Case "create_databases"
DoCreateDatabases
Case "delete_databases"
DoDeleteDatabases
Case "exec_sqlcmd"
DoExecSqlCommand
Case "exec_sqlcmd2"
DoExecSqlCommand2
Case "install_components"
DoInstallComponents
Case "uninstall_components"
DoUninstallComponents
Case "check_mtspkg"
DoCheckMTSPackage
Case "remove_mtspkg"
DoRemoveMTSPackage
Case "stop_services"
DoStopServices
Case "start_services"
DoStartServices
Case "config_buildserver"
DoConfigBuildServer
Case "unconfig_buildserver"
DoUnconfigBuildServer
Case "remove_searchcatalog"
DoRemoveSearchCatalog
Case "add_memuser"
DoAddMembershipUser
Case "check_ntuser"
DoCheckNTUser
Case "check_memuser"
DoCheckMemUser
Case "query_fldhasstring"
DoCheckQueryFieldHasString
Case "update_metabase"
DoUpdateMetabase
Case "fix_meta2_0"
DoFixMeta2_0
Case "check_meta_fileversions"
DoCheckMetaFileVersions
Case Else
Yell Format1("Unknown command ""%1""" & vbCRLF & _
"Invoke script without parameters for a list of commands", gCommand), vbCritical
End Select
RaiseOnError2 Format1("Failed to execute command: %1.", gCommand), false
if Len(GlobalError) > 0 then
Trace "*** CRITICAL ERROR: ***"
Yell GlobalError, vbCritical
end if
' terminate normally: exit code 0 (= SUCCESS)
Echo "Setup.vbs: Command executed OK"
End Sub
'########################################################################
'# Check / parse arguments / switches
'########################################################################
Public Wizard
Public gCurrentDir
Public gInstallMode
Public gCommand
Public Switches
'============================================================================
' ProcessCmdLine
'
Function ProcessCmdLine(ByRef Switches)
If g_ErrorHandler Then On Error Resume Next
Set Switches = CreateObj("Scripting.Dictionary")
Dim nArg, List
For nArg = 0 To g_ArgCount-1
Dim Arg
Arg = g_Arguments(nArg)
If InStr(1, "/-", Left(Arg,1)) <> 0 Then
Dim Switch
Arg = Mid(Arg,2)
Switch = Split(Arg, ":")(0)
Arg = Mid(Arg, Len(Switch)+2)
if not defined(Switches(Switch)) then
Switches(Switch) = Arg
else
' Switch already present, so multiple switches with the same name.
' Solve this by creating a new list and putting the switches in it.
if VarType( Switches(Switch) ) = vbObject then
Set List = Switches(Switch)
else
Set List = CreateObj("Scripting.Dictionary") '"Commerce.SimpleList")
List.Add Switches(Switch), ""
Set Switches(Switch) = List
end if
List.Add Arg, ""
end if
Else
ProcessCmdLine = ProcessCmdLine + "." + Arg
End If
Next
ProcessCmdLine = Mid(ProcessCmdLine, 2)
End Function
'========================================================================
' ProcessArguments
'
Sub ProcessArguments()
g_ErrorHandler = ERRORHANDLER
if IsRunningInASP() then Response.Write "
"
If g_ErrorHandler Then On Error Resume Next
Set Wizard = DefineGlobalResources
gCommand = ProcessCmdLine(switches)
If Not defined(Switches("interactive")) then
Switches("interactive") = "N"
End If
If defined(Switches("break_dbg")) then
If UCase(Switches("break_dbg")) = "Y" then
Stop ' break into debugger
End If
End If
If defined(Switches("tracing")) then
If UCase(Switches("tracing")) = "Y" then
SetTracingFlag True
End If
End If
If defined(Switches("errorhandler")) then
If UCase(Switches("errorhandler")) = "N" then
SetErrorHandler False
On Error Goto 0
End If
End If
If IsNull(gCommand) or IsEmpty(gCommand) or gCommand = "" Then
YellExt _
"No Arguments supplied", _
"No arguments supplied. Usage: CScript setup.vbs " + vbCRLF + vbCRLF +_
"Commands:" + vbCRLF +_
vbTab+ "install_site/reinstall_site/"+vbTab+vbTab+ _
"Install / reinstall /" + vbCRLF +_
vbTab+ "uninstall_site"+vbTab+vbTab+vbTab+vbTab+ _
"uninstall Commerce site" + vbCRLF +_
vbTab+ "secure_site"+vbTab+vbTab+vbTab+vbTab+"Secure Commerce site" + vbCRLF +_
vbTab+ "add_connections/remove_connections"+vbTab+"Add/remove conn. map entries" + vbCRLF +_
vbTab+ "add_dsns/remove_dsns"+vbTab+vbTab+vbTab+"Add/remove ODBC DSNs" + vbCRLF +_
vbTab+ "create_memserver/"+vbTab+vbTab+vbTab+"Create / recreate /" + vbCRLF +_
vbTab+ "recreate_memserver/delete_memserver"+vbTab+"delete Membership Server" + vbCRLF +_
vbTab+ "create_container"+vbTab+"Create Membership OrganizationalUnitdelete" + vbCRLF +_
vbTab+ "create_secauo"+vbTab+vbTab+vbTab+vbTab+"Create secondary AUO provider" + vbCRLF +_
vbTab+ "create_ssadmingroup"+vbTab+vbTab+vbTab+"Create SiteServer Admin group" + vbCRLF +_
vbTab+ "logon_sql"+vbTab+vbTab+vbTab+vbTab+"Log on to SQL Server" + vbCRLF +_
vbTab+ "check_sqlconn"+vbTab+vbTab+vbTab+vbTab+"Check ODBC connection string" + vbCRLF +_
vbTab+ "set_memauth"+vbTab+vbTab+vbTab+vbTab+"Set Memb. authent. method" + vbCRLF +_
vbTab+ "add_memattr"+vbTab+vbTab+vbTab+vbTab+"Add Memb. attributes" + vbCRLF +_
vbTab+ "create_databases/delete_databases"+vbTab+"Create/delete databases" + vbCRLF +_
vbTab+ "exec_sqlcmd"+vbTab+vbTab+vbTab+vbTab+"Execute SQL command via SQL-DMO" + vbCRLF +_
vbTab+ "exec_sqlcmd2"+vbTab+vbTab+vbTab+vbTab+"Execute SQL command via ODBC" + vbCRLF +_
vbTab+ "install_components/uninstall_components"+vbTab+"Inst./Uninst. COM / MTS comp." + vbCRLF +_
vbTab+ "check_mtspkg"+vbTab+vbTab+vbTab+vbTab+"Check if MTS package exists" + vbCRLF +_
vbTab+ "remove_mtspkg"+vbTab+vbTab+vbTab+vbTab+"Remove MTS package" + vbCRLF +_
vbTab+ "stop_services"+vbTab+vbTab+vbTab+vbTab+vbTab+"Stop services and MTS" + vbCRLF +_
vbTab+ "start_services"+vbTab+vbTab+vbTab+vbTab+"Start services" + vbCRLF +_
vbTab+ "config_buildserver"+vbTab+vbTab+vbTab+"Configure Catalog Build Server" + vbCRLF +_
vbTab+ "unconfig_buildserver"+vbTab+vbTab+vbTab+"Unconfig. Catalog Build Server" + vbCRLF +_
vbTab+ "remove_searchcatalog"+vbTab+vbTab+vbTab+"Remove Site Server Search cat." + vbCRLF +_
vbTab+ "add_memuser"+vbTab+vbTab+vbTab+vbTab+"Add membership user" + vbCRLF +_
vbTab+ "check_ntuser"+vbTab+vbTab+vbTab+vbTab+"Check NT user account" + vbCRLF +_
vbTab+ "check_memuser"+vbTab+vbTab+vbTab+vbTab+"Check Membership user account" + vbCRLF +_
vbTab+ "query_fldhasstring"+vbTab+vbTab+vbTab+"Check if query field has a" + vbCRLF +_
vbTab+ vbTab+vbTab+vbTab+vbTab+vbTab+"non-empty string value" + vbCRLF +_
vbTab+ "update_metabase"+vbTab+vbTab+vbTab+vbTab+"Update metabase w. curr. status" + vbCRLF +_
vbTab+ "fix_meta2_0"+vbTab+vbTab+vbTab+vbTab+"Fix metabase info for rel. 2.0" + vbCRLF +_
vbTab+ "check_meta_fileversions"+vbTab+vbTab+vbTab+"Check file versions in metabase" + vbCRLF +_
vbTab+ "test_wsh"+vbTab+vbTab+vbTab+vbTab+"Test command for testing WSH" + vbCRLF +_
"General switches (use these with any command):"+ vbCRLF + _
vbTab+"/interactive:y|n"+vbTab+vbTab+vbTab+"Run interactively" + vbCRLF +_
vbTab+"/tracing:y|n"+vbTab+vbTab+vbTab+vbTab+"Set tracing on" + vbCRLF +_
vbTab+"/break_dbg:y|n"+vbTab+vbTab+vbTab+vbTab+"Break into debugger" + vbCRLF +_
vbTab+"/errorhandler:y|n"+vbTab+vbTab+vbTab+"Set error handler on/off" + vbCRLF +_
vbCRLF +_
"Names of commands and switches are case insensitive." + vbCRLF +_
"Values may be enclosed in double quotes. Example:" + vbCRLF +_
"CSCRIPT setup.vbs install /websiteid:1 /name:""E-Enterprise 1.1""" + vbCRLF + vbCRLF +_
"For help on a command, type: CScript setup.vbs ",_
vbExclamation
End If
'---- Set defaults first
On Error Resume Next
Dim AdminLanMan
Set AdminLanMan = CreateObject("Commerce.AdminLanManager")
AdminLanMan.User = AdminLanMan.GetCurrentUser
' The preceding code will fail when not run on a Site Server computer.
' Therefore, ignore this error
Err.Clear
If g_ErrorHandler Then
On Error Resume Next
Else
On Error Goto 0
End If
if (0 = StrComp("install_site",GetCommand(),1)) then
gInstallMode = TRUE
end if
if IsRunningInWSH() then
gCurrentDir = WScript.ScriptFullName
gCurrentDir = Left(gCurrentDir, InstrRev(gCurrentDir, "\")-1)
else
gCurrentDir = g_CurrentDirFromASP
end if
'---- ignore any errors because of missing params
Err.Clear
End Sub
'========================================================================
' CheckSwitches
'
Sub CheckSwitches( ByRef RequiredSwitches, ByRef MissingSwitches )
Dim i, Count, Switch, OK
Count = 0
MissingSwitches = ""
for i=LBound(RequiredSwitches) to UBound(RequiredSwitches)
OK = true
Switch = RequiredSwitches(i)
' check if switch has been entered witch a value (or multiple values)
if not defined(Switches(Switch)) then
OK = false
' SimpleList: multi-valued switch
elseif VarType(Switches(Switch)) = vbObject then
Dim Value
for each Value in Switches(Switch)
if Value = "" then
OK = false
end if
next
' Single-valued switch
elseif Switches(Switch) = "" then
OK = false
end if
if not OK then
Count = Count + 1
if Count > 1 then
MissingSwitches = MissingSwitches & ", "
end if
MissingSwitches = MissingSwitches & Switch
end if
next
if Count > 0 then
if Count = 1 then
MissingSwitches = "Missing switch: " & MissingSwitches
else
MissingSwitches = "Missing switches: " & MissingSwitches
end if
end if
End Sub
'========================================================================
' GetValuesFromSwitch
'
Function GetValuesFromSwitch( ByRef SwitchValue )
Dim Values
if VarType( SwitchValue ) = vbObject then ' Multi-valued: List-type
Set Values = SwitchValue
else ' Single-valued: String-type
Set Values = CreateObj("Scripting.Dictionary")
' if switch is empty (type = vbNull or vbEmpty), the value list remains empty
if VarType( SwitchValue ) <> vbNull and VarType( SwitchValue ) <> vbEmpty then
Values.Add SwitchValue, ""
end if
end if
Set GetValuesFromSwitch = Values
End Function
'========================================================================
' DisplayHelp
'
Sub DisplayHelp( ByVal MissingSwitches, ByVal SwitchesText )
Yell _
"Command: " & GetCommand() + vbCRLF +_
MissingSwitches + vbCRLF +_
vbCRLF +_
"Switches are:"+ vbCRLF +_
SwitchesText,_
vbExclamation
End Sub
'========================================================================
' GetCommand
'
function GetCommand()
If g_ErrorHandler Then On Error Resume Next
GetCommand = gCommand
end function
'########################################################################
'# Do... routines: validate and execute a command.
'#
'# These routines validate the supplied command line params and (if OK)
'# call another subroutine to perform the 'real' work, or (if parameters
'# are missing/incorrect), display help text on using the command.
'########################################################################
'========================================================================
' DoInstallSite
'
Sub DoInstallSite
CheckSiteSwitches
CreateSite switches("websiteid"), switches("sitename"), switches("displayname"), _
switches("path"), "", _
switches("connectionstring"), switches("accounts"), switches("aspsessions"), "",_
switches("hostname"), switches("aclfile1"), switches("aclfile2"), FALSE
End Sub
'========================================================================
' DoReinstallSite
'
Sub DoReinstallSite
CheckSiteSwitches
CreateSite switches("websiteid"), switches("sitename"), switches("displayname"), _
switches("path"), "", _
switches("connectionstring"), switches("accounts"), switches("aspsessions"), "",_
switches("hostname"), switches("aclfile1"), switches("aclfile2"), TRUE
End Sub
'========================================================================
' DoUninstallSite
'
Sub DoUninstallSite
CheckSiteSwitches
DeleteSite switches("websiteid"), switches("sitename"), False, False, ""
End Sub
'========================================================================
' CheckSiteSwitches
'
Sub CheckSiteSwitches
Dim MissingSwitches
CheckSwitches Array("websiteid", "sitename"), MissingSwitches
' base switches OK
if MissingSwitches = "" then
' if web site running under membership, then also the /dsadminpassword must be specified
if IsMembership(Switches("websiteid"), "") then
CheckSwitches Array("websiteid", "sitename", "dsadminpassword"), MissingSwitches
end if
end if
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+vbTab+"Web Site instance (virtual web server)" + vbCRLF +_
vbTab+"/sitename:string"+vbTab+vbTab+"Virtual Directory Name" + vbCRLF +_
vbTab+"/displayname:string"+vbTab+vbTab+"Display name of the Commerce Site" + vbCRLF +_
vbTab+"/hostname:string"+vbTab+vbTab+"Hostname to use in the URL (optional)" + vbCRLF +_
vbTab+"/path:string"+vbTab+vbTab+vbTab+"Destination directory" + vbCRLF +_
vbTab+"/connectionstring:string"+vbTab+"Database connection string" + vbCRLF +_
vbTab+"/dsadminpassword:string"+vbTab+vbTab+"Membership administrator password" + vbCRLF +_
vbTab+"/aspsessions:y|n"+vbTab+vbTab+"Switch on or off ASP Session support" + vbCRLF +_
vbCRLF +_
vbTab+"(for commands Reinstall and Uninstall, specify only" + vbCRLF +_
vbTab+" /websiteid, /sitename and /dsadminpassword)"
end if
if not defined(Switches("path")) then
Dim Web, Prop
Set Web = CreateObject("Commerce.AdminWebServer")
Set Prop = Web.GetWebSiteProperties(Switches("websiteid"))
Switches("path") = Prop.VrPath + "\" + switches("sitename")
end if
' If you are installing a site with membership authentication
if defined(Switches("dsadminpassword")) then
SetDSAccountInfo switches("websiteid"), "administrator", switches("dsadminpassword")
' administrator and password are the membership administrator and password
' respectively
MembershipRequired
end if
End Sub
'========================================================================
' DoSecureSite
'
Sub DoSecureSite
CheckSecureSiteSwitches
SecureSite switches("websiteid"), switches("sitename"), switches("path"), _
switches("aclfile1"), switches("aclfile2")
End Sub
'========================================================================
' CheckSecureSiteSwitches
'
Sub CheckSecureSiteSwitches
Dim MissingSwitches
CheckSwitches Array("websiteid", "sitename", "path"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+vbTab+"Web Site instance (virtual web server)" + vbCRLF +_
vbTab+"/sitename:string"+vbTab+vbTab+"Virtual Directory Name" + vbCRLF +_
vbTab+"/path:string"+vbTab+vbTab+vbTab+"Destination directory" + vbCRLF +_
vbTab+"/aclfile1:string"+vbTab+vbTab+"ACL file with admin permiss. (optional)" + vbCRLF +_
vbTab+"/aclfile2:string"+vbTab+vbTab+"ACL file with public permiss. (optional)"
end if
End Sub
'========================================================================
' DoAddConnectionsToMap
'
Sub DoAddConnectionsToMap
CheckConnSwitches
Dim ConnectionStrings
Set ConnectionStrings = GetConnectionStrings()
ModifyConnectionMap switches("websiteid"), switches("sitename"), "", ConnectionStrings,_
True, False
End Sub
'========================================================================
' DoRemoveConnectionsFromMap
'
Sub DoRemoveConnectionsFromMap
CheckConnSwitches
Dim ConnectionStrings
Set ConnectionStrings = GetConnectionStrings()
ModifyConnectionMap switches("websiteid"), switches("sitename"), "", ConnectionStrings,_
False, False
End Sub
'========================================================================
' CheckConnSwitches
'
Sub CheckConnSwitches
Dim MissingSwitches
CheckSwitches Array("websiteid", "sitename", "conn"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+vbTab+"Web Site instance (virtual web server)" + vbCRLF +_
vbTab+"/sitename:string"+vbTab+vbTab+"Virtual Directory Name" + vbCRLF +_
vbTab+"/conn:="""""+vbTab+"Connection to add/remove" + vbCRLF +_
vbCRLF +_
"Can specify multiple connection strings to add remove. Examples:" + vbCRLF +_
vbCRLF +_
"CSCRIPT setup.vbs add_connections /websiteid:1 /sitename:ee11 " + vbCRLF +_
"/conn:EECommon=""DSN=EECommon;UID=wwwapps;""" + vbCRLF +_
"/conn:EECommon2=""DSN=EECommon2;UID=sa;PWD=;""" + vbCRLF +_
vbCRLF +_
"CSCRIPT setup.vbs remove_connections /websiteid:1 /sitename:ee11 " + vbCRLF +_
"/conn:EECommon /conn:EECommon2" + vbCRLF +_
vbCRLF +_
"Nota bene: the connection string is case sensitive. E.g. specify UID and not Uid or uid."
end if
End Sub
'========================================================================
' DoCreateMembershipServer
'
Sub DoCreateMembershipServer
CheckMembershipSwitches
CreateMembershipServer switches("websiteid"), switches("ldaphost"), switches("ldapport"), _
switches("dsname"), switches("dsroot"), _
switches("dbserver"), switches("database"), switches("dbuser"), _
switches("dbpassword"), switches("dsadminpassword"), false
End Sub
'========================================================================
' DoRecreateMembershipServer
'
Sub DoRecreateMembershipServer
CheckMembershipSwitches
CreateMembershipServer switches("websiteid"), switches("ldaphost"), switches("ldapport"), _
switches("dsname"), switches("dsroot"), _
switches("dbserver"), switches("database"), switches("dbuser"), _
switches("dbpassword"), switches("dsadminpassword"), true
End Sub
'========================================================================
' DoDeleteMembershipServer
'
Sub DoDeleteMembershipServer
CheckDeleteMembershipSwitches
if g_ErrorHandler then on error resume next
' Delete first membership server which conforms to the given root name
'Dim MemServerID
'FindMembershipServer switches("dsroot"), MemServerID
'
'if MemServerID = 0 then
' RaiseError Wizard("MemDel_NotFound")
'else
' DeleteMembershipServer MemServerID, true
'end if
' Delete ALL membership servers which conform to the given root name
DisplayActionStart "DELETING MEMBERSHIP SERVERS FOR DSROOT = " & switches("dsroot")
Dim MemServerID
MemServerID = -1
do while MemServerID <> 0
Trace "Search for membership server:"
FindMembershipServer switches("dsroot"), MemServerID
if MemServerID = 0 then ' finished deleting membership servers
''RaiseError Wizard("MemDel_NotFound")
else
Trace "Found membership server, ID = " & CStr(MemServerID)
DeleteMembershipServer MemServerID, true
end if
loop
DisplayActionFinish "DELETING MEMBERSHIP SERVERS FOR DSROOT = " & switches("dsroot")
End Sub
'========================================================================
' CheckMembershipSwitches
'
Sub CheckMembershipSwitches
Dim MissingSwitches
CheckSwitches Array("ldaphost", "dsname", "dsroot", "dbserver", "database", _
"dbuser", "dsadminpassword"), MissingSwitches
if defined(Switches("ldapport")) then
Dim LDAPPort
LDAPPort = StrToNumber(Switches("ldapport"))
if LDAPPort = 0 then
if MissingSwitches <> "" then
MissingSwitches = MissingSwitches & vbCRLF
end if
MissingSwitches = MissingSwitches & "Incorrect value for switch /ldapport"
end if
end if
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+"Web Site on which to map the membership server" + vbCRLF +_
vbTab+vbTab+vbTab+vbTab+"(omit if you do not want to map to a web site)" + vbCRLF +_
vbTab+"/ldaphost:string"+vbTab+"Server on which LDAP runs" + vbCRLF +_
vbTab+"/ldapport:number"+vbTab+"Port on which LDAP runs (optional)" + vbCRLF +_
vbTab+"/dsname:string"+vbTab+vbTab+"Membership Server name (description)" + vbCRLF +_
vbTab+"/dsroot:string"+vbTab+vbTab+"Directory root name, e.g.: E-Enterprise" + vbCRLF +_
vbTab+"/dsadminpassword:string"+vbTab+"Membership Administrator password" + vbCRLF +_
vbTab+"/dbserver:string"+vbTab+"SQL Server machine for Membership database" + vbCRLF +_
vbTab+"/database:string"+vbTab+"SQL Server database to create or connect to" + vbCRLF +_
vbTab+"/dbuser:string"+vbTab+vbTab+"SQL Server user name for Membership database" + vbCRLF +_
vbTab+"/dbpassword:string"+vbTab+"SQL Server password for Membership database"
end if
End Sub
'========================================================================
' CheckDeleteMembershipSwitches
'
Sub CheckDeleteMembershipSwitches
Dim MissingSwitches
CheckSwitches Array("dsroot"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dsroot:string"+vbTab+vbTab+"Directory root name, e.g.: E-Enterprise"
end if
End Sub
'========================================================================
' DoCreateSecAuoProvider
'
Sub DoCreateSecAuoProvider
CheckCreateSecAuoProviderSwitches
CreateSecAuoProvider switches("dsroot"), switches("name"), switches("path"), _
switches("schema"), switches("class"), switches("suffix"), _
switches("depobj"),switches("depprop"), _
switches("bindasname"),switches("bindaspassword")
End Sub
'========================================================================
' CheckCreateSecAuoProviderSwitches
'
Sub CheckCreateSecAuoProviderSwitches
Dim MissingSwitches
CheckSwitches Array("dsroot", "name", "path", "schema", "class", "suffix"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dsroot:string"+vbTab+vbTab+"Directory root name, e.g.: E-Enterprise" + vbCRLF +_
vbTab+"/name:string"+vbTab+vbTab+"Sec. AUO provider name" + vbCRLF +_
vbTab+"/path:string"+vbTab+vbTab+"ADS path prefix" + vbCRLF +_
vbTab+"/schema:string"+vbTab+vbTab+"ADS schema string" + vbCRLF +_
vbTab+"/class:string"+vbTab+vbTab+"Sec. AUO provider class" + vbCRLF +_
vbTab+"/suffix:string"+vbTab+vbTab+"Sec. AUO provider suffix value" + vbCRLF +_
vbTab+"/depobj:string"+vbTab+vbTab+"Sec. AUO provider DepObj value" + vbCRLF +_
vbTab+"/depprop:string"+vbTab+vbTab+"Sec. AUO provider DepProp value" + vbCRLF +_
vbTab+"/bindasname:string"+vbTab+"User account to log on to Membership" + vbCRLF +_
vbTab+"/bindaspassword:string"+vbTab+"Password to log on to Membership" + vbCRLF +_
vbCRLF +_
"Note: the LDAP port in the ADS schema string can be specified as an actual port " +_
"number or as , in the latter case the correct LDAP port will be substituted."
end if
End Sub
'========================================================================
' DoDeleteSecAuoProvider
'
Sub DoDeleteSecAuoProvider
CheckDeleteSecAuoProviderSwitches
DeleteSecAuoProvider switches("dsroot"), switches("name")
End Sub
'========================================================================
' CheckDeleteSecAuoProviderSwitches
'
Sub CheckDeleteSecAuoProviderSwitches
Dim MissingSwitches
CheckSwitches Array("dsroot", "name"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dsroot:string"+vbTab+vbTab+"Directory root name, e.g.: E-Enterprise" + vbCRLF +_
vbTab+"/name:string"+vbTab+vbTab+"Sec. AUO provider name"
end if
End Sub
'========================================================================
' DoCreateSSAdminGroup
'
Sub DoCreateSSAdminGroup
CheckCreateSSAdminGroupSwitches
CreateSSAdminGroup switches("websiteid"), switches("dsadminpassword")
End Sub
'========================================================================
' DoCreateEEAdminGroup
'
Sub DoCreateEEAdminGroup
CheckCreateSSAdminGroupSwitches
CreateEEAdminGroup switches("websiteid"), switches("dsadminpassword")
End Sub
'========================================================================
' DoCreateContainer
'
Sub DoCreateContainer
CreateSSContainer switches("websiteid"), switches("dsadminpassword")
End Sub
'========================================================================
' DoCreateClass
'
Sub DoCreateClass
CreateSSClass switches("websiteid"), switches("dsadminpassword")
End Sub
'========================================================================
' CheckCreateSSAdminGroupSwitches
'
Sub CheckCreateSSAdminGroupSwitches
Dim MissingSwitches
CheckSwitches Array("websiteid", "dsadminpassword"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+"Web Site mapped to the membership server" + vbCRLF +_
vbTab+"/dsadminpassword:string"+vbTab+"Membership Administrator password"
end if
End Sub
'========================================================================
' DoSetMemAuthMethods
'
Sub DoSetMemAuthMethods
CheckMemAuthSwitches
if g_ErrorHandler then on error resume next
Dim MemAuthEntries
Set MemAuthEntries = CreateObj("Scripting.Dictionary")
if defined( Switches("cfg_file") ) then
GetMemAuthFromFile MemAuthEntries, Switches("cfg_file")
end if
if defined( Switches("auth") ) then
GetMemAuthFromSwitch MemAuthEntries, Switches("auth")
end if
if Not IsErrorClear() then
exit sub
end if
Dim WebsiteID
WebsiteID = Switches("websiteid")
Dim WebSiteName
WebSiteName = Switches("websitename")
SetMemAuthMethods WebsiteID, MemAuthEntries, WebSiteName
SetIISPermissions WebsiteID, MemAuthEntries, WebSiteName
End Sub
'========================================================================
' CheckSetMemAuthSwitches
'
Sub CheckMemAuthSwitches
Dim MissingSwitches
if not defined(Switches("websiteid")) or _
not defined(Switches("websitename")) or _
( not defined(Switches("auth")) and not defined(Switches("cfg_file")) ) then
MissingSwitches = "You must specify /websiteid, and /auth or /cfg_file (or both)."
end if
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+"Web Site to which the command should apply" + vbCRLF +_
vbTab+"/websitename:string"+vbTab+"Web Site Name (IIS virtual directory)" + vbCRLF +_
vbTab+"/auth:string"+vbTab+vbTab+"Authentication settings on an URL" + vbCRLF + _
vbTab+"/cfg_file:string"+vbTab+"Config file with auth. settings on URLs" + vbCRLF + _
vbCRLF +_
"You can specify authentication settings in two ways: using one or more /auth switches, " +_
"or using a config file. Each /auth switch or each line in the config" + vbCRLF +_
"file must have the following form: ,[,]" + vbCRLF +_
vbCRLF +_
" can be a file or folder. E.g.: ""EE11/formslogin.asp"" or ""EE11""." + vbCRLF +_
"Value for can be: " + vbCRLF +_
"0 = Leave unchanged, 1 = Forms authentication, 2 = Anonymous." + vbCRLF +_
" is optional, values can be:" + vbCRLF +_
"0 = Leave unchanged, 1 = READ, 2 = WRITE, 3 = EXECUTE, 4 = EXECUTE & WRITE, 5 = SCRIPT, 6 = SCRIPT & WRITE " + vbCRLF +_
vbCRLF +_
"Nota bene: you should specify at least contain one entry, namely" + vbCRLF +_
"the authentication method for the base application URL (e.g. EE11). Also," + vbCRLF +_
"URLs must be listed hierarchically (top level URL should be the first line)." & vbCRLF & _
vbCRLF +_
"Example: cscript setup.vbs set_memauth /websiteid:1 /auth:""EE11,1,0"" /auth:""EE11/formslogin.asp,2"""
end if
End Sub
'========================================================================
' GetMemAuthFromFile
'
Sub GetMemAuthFromFile( ByRef MemAuthEntries, ByVal CfgFile )
' Read lines from the config file and put them into the dictionary "MemAuthEntries"
if g_ErrorHandler then on error resume next
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim File
Set File = Fso.OpenTextFile( CfgFile, 1 )
if not IsErrorClear() then
RaiseOnError Format1(Wizard("MemAuth_CfgOpen"),CfgFile)
exit sub
end if
Dim Line
' read the lines from the configuration file
do while not File.AtEndOfStream
Line = Trim(File.ReadLine())
if Line <> "" and Left(Line,1) <> ";" then
AddMemAuthEntry MemAuthEntries, Line
if not IsErrorClear() then
exit do
end if
end if
loop
File.Close
RaiseOnError Format1(Wizard("MemAuth_CfgFile"),CfgFile)
End Sub
'========================================================================
' GetMemAuthFromSwitch
'
Sub GetMemAuthFromSwitch( ByRef MemAuthEntries, ByVal AuthEntries )
if g_ErrorHandler then on error resume next
Dim List
Set List = GetValuesFromSwitch( AuthEntries )
Dim Value
for each Value in List
AddMemAuthEntry MemAuthEntries, Value
if not IsErrorClear() then
exit for
end if
next
End Sub
'========================================================================
' AddMemAuthEntry
'
Sub AddMemAuthEntry( ByRef MemAuthEntries, ByVal Line )
Dim Subparts, URL, AuthMethod, IISWrite
Dim Settings(1)
' line consists of up to 3 parts, separated by a ,
' put the parts into an array and check them
Subparts = Split(Line, ",")
if UBound(Subparts) < 1 or UBound(Subparts) > 2 then
RaiseError Format1(Wizard("MemAuth_WrongEntry"),Line)
exit sub
end if
URL = Subparts(0)
AuthMethod = 0
IISWrite = 0
' 2nd and 3rd part must be numbers 0 - 1, check this
if SubParts(1) <> "" then ' empty = default value (0)
on error resume next
AuthMethod = CInt(SubParts(1))
if Err.number <> 0 then AuthMethod = -1
if not g_ErrorHandler then on error goto 0
end if
' IIS WRITE permission specified?
if UBound(Subparts) >= 2 then
if SubParts(2) <> "" then ' empty = default value (0)
on error resume next
IISWrite = CInt(SubParts(2))
if Err.number <> 0 then IISWrite = -1
if not g_ErrorHandler then on error goto 0
end if
end if
if AuthMethod < 0 or AuthMethod > 2 or IISWrite < 0 or IISWrite > 6 then
RaiseError Format1(Wizard("MemAuth_WrongEntry2"),Line)
exit sub
end if
Settings(0) = AuthMethod
Settings(1) = IISWrite
MemAuthEntries(URL) = Settings
End Sub
'========================================================================
' DoAddMembershipAttributes
'
Sub DoAddMembershipAttributes
CheckMemAddAttribSwitches
if g_ErrorHandler then on error resume next
Dim MemAttribs
Set MemAttribs = CreateObj("Scripting.Dictionary")
if defined( Switches("cfg_file") ) then
GetMemAttrFromFile MemAttribs, Switches("cfg_file")
end if
if defined( Switches("attr") ) then
GetMemAttrFromSwitch MemAttribs, Switches("attr")
end if
if Not IsErrorClear() then
exit sub
end if
AddMembershipAttributes Switches("websiteid"), Switches("dsadminpassword"), MemAttribs
End Sub
'========================================================================
' CheckMemAddAttribSwitches
'
Sub CheckMemAddAttribSwitches
Dim MissingSwitches
if not defined(Switches("websiteid")) or not defined(Switches("dsadminpassword")) or _
( not defined(Switches("attr")) and not defined(Switches("cfg_file")) ) then
MissingSwitches = _
"You must specify /websiteid, /dsadminpassword and /attr or /cfg_file (or both)."
end if
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+"Web Site to which the command should apply" + vbCRLF +_
vbTab+"/dsadminpassword:string"+vbTab+"Membership Administrator password" + vbCRLF +_
vbTab+"/attr:string"+vbTab+vbTab+"Membership attribute specification" + vbCRLF + _
vbTab+"/cfg_file:string"+vbTab+"Path and file name of file listing attributes" + vbCRLF + _
vbCRLF +_
"You can specify attributes in two ways: using one or more /attr switches, " +_
"or using a config file. Each /attr switch or each line in the config" + vbCRLF +_
"file must have the following form:" + vbCRLF +_
vbCRLF +_
"[,][,][,][,]" + vbCRLF +_
vbCRLF +_
" is the unique attribute name (cn)" + vbCRLF +_
" is an attribute type, e.g. ""unicodeString"" or ""integer""" + vbCRLF +_
"(default is ""unicodeString"")" + vbCRLF +_
" is 0 (Single) or 1 (Multi) (default is 0)" + vbCRLF +_
vbCRLF +_
"Example 1: UserType,integer,,User Type" + vbCRLF +_
"Example 2: EMailAddresses,,1,E-mail addresses,List of e-mail addresses"
end if
End Sub
'========================================================================
' GetMemAttrFromFile
'
Sub GetMemAttrFromFile( ByRef MemAttribs, ByVal CfgFile )
' Read lines from the config file and put them into a dictionary
if g_ErrorHandler then on error resume next
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim File
Set File = Fso.OpenTextFile( CfgFile, 1 )
if not IsErrorClear() then
RaiseOnError Format1(Wizard("MemAttr_CfgOpen"),CfgFile)
exit sub
end if
Dim Line
' read the lines from the configuration file
do while not File.AtEndOfStream
Line = Trim(File.ReadLine())
if Line <> "" and Left(Line,1) <> ";" then
AddMemAttrib MemAttribs, Line
if not IsErrorClear() then
exit do
end if
end if
loop
File.Close
RaiseOnError Format1(Wizard("MemAttr_CfgFile"),CfgFile)
End Sub
'========================================================================
' GetMemAttrFromSwitch
'
Sub GetMemAttrFromSwitch( ByRef MemAttribs, ByVal Attribs )
if g_ErrorHandler then on error resume next
Dim List
Set List = GetValuesFromSwitch( Attribs )
Dim Value
for each Value in List
AddMemAttrib MemAttribs, Value
if not IsErrorClear() then
exit for
end if
next
End Sub
'========================================================================
' AddMemAttrib
'
Sub AddMemAttrib( ByRef MemAttribs, ByVal Line )
if g_ErrorHandler then on error resume next
Dim Subparts, AttrName, AttrType, AttrMulti, AttrDisplayName, AttrDesc
Dim Settings(3) ' 4 elements!
' line consists of up to 3 parts, separated by a ,
' put the parts into an array and check them
Subparts = Split(Line, ";")
if UBound(Subparts) < 0 or UBound(Subparts) > 5 then
RaiseError Format1(Wizard("MemAttr_WrongEntry"),Line)
exit sub
end if
AttrName = Subparts(0)
AttrType = "unicodeString"
AttrMulti = 0
AttrDisplayName = AttrName
AttrDesc = ""
' 2nd and 3rd part must be numbers 0 - 1, check this
if UBound(Subparts) >= 1 then
if SubParts(1) <> "" then AttrType = SubParts(1)
end if
if UBound(Subparts) >= 2 then
if SubParts(2) <> "" then ' empty = default value (0)
on error resume next
AttrMulti = CInt(SubParts(2))
if Err.number <> 0 then AttrMulti = -1
if not g_ErrorHandler then on error goto 0
end if
end if
if UBound(Subparts) >= 3 then
if SubParts(3) <> "" then AttrDisplayName = SubParts(3)
end if
if UBound(Subparts) >= 4 then
if SubParts(4) <> "" then AttrDesc = SubParts(4)
end if
if AttrMulti < 0 or AttrMulti > 1 then
RaiseError Format1(Wizard("MemAttr_WrongEntry2"),Line)
exit sub
end if
Settings(0) = AttrType
Settings(1) = AttrMulti
Settings(2) = AttrDisplayName
Settings(3) = AttrDesc
MemAttribs(AttrName) = Settings
End Sub
'========================================================================
' DoAddMembershipUser
'
Sub DoAddMembershipUser
CheckAddMembershipUserSwitches
if g_ErrorHandler then on error resume next
Dim UserAttribs
if Defined( Switches("attr") ) then
Set UserAttribs = CreateObj("Scripting.Dictionary")
GetUserAttrFromSwitch UserAttribs, Switches("attr")
if Not IsErrorClear() then
exit sub
end if
end if
AddMembershipUser Switches("websiteid"), Switches("dsadminpassword"), _
Switches("user"), Switches("password"), UserAttribs, Switches("memscriptuser")
End Sub
'========================================================================
' CheckAddMembershipUserSwitches
'
Sub CheckAddMembershipUserSwitches
Dim MissingSwitches
CheckSwitches Array("websiteid","dsadminpassword","user"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+"Web Site to which the command should apply" + vbCRLF +_
vbTab+"/dsadminpassword:string"+vbTab+"Membership Administrator password" + vbCRLF +_
vbTab+"/user:string"+vbTab+vbTab+"Membership user name (cn)" + vbCRLF + _
vbTab+"/password:string"+vbTab+vbTab+"Membership user password" + vbCRLF + _
vbTab+"/attr:string"+vbTab+vbTab+"Membership user attributes" + vbCRLF + _
vbTab+"/memscriptuser:y|n"+vbTab+vbTab+"Special handling for MemScriptUser" + vbCRLF + _
vbCRLF +_
"You can specify multiple /attr switches." +_
"Each /attr switch must have the following form:" + vbCRLF +_
vbCRLF +_
",[,,...]" + vbCRLF +_
vbCRLF +_
" is the unique attribute name (cn)" + vbCRLF +_
" is the value (may specify multiple values for multi-valued attribute)"
end if
End Sub
'========================================================================
' GetUserAttrFromSwitch
'
Sub GetUserAttrFromSwitch( ByRef UserAttribs, ByVal Attribs )
if g_ErrorHandler then on error resume next
Dim List
Set List = GetValuesFromSwitch( Attribs )
Dim Value
for each Value in List
AddUserAttrib UserAttribs, Value
if not IsErrorClear() then
exit for
end if
next
End Sub
'========================================================================
' AddUserAttrib
'
Sub AddUserAttrib( ByRef UserAttribs, ByVal Line )
if g_ErrorHandler then on error resume next
Dim Index, NumValues, AttrName, AttrValue, AttrValues
Index = InStr(1,Line,",")
NumValues = -1
if Index > 1 then
AttrName = Left(Line,Index-1)
AttrValue = Mid(Line,Index+1)
AttrValues = Split(AttrValue, ",")
NumValues = UBound(AttrValues)
end if
if Index <= 1 or NumValues < 0 then
RaiseError Format1(Wizard("UserAttr_WrongEntry"),Line)
exit sub
end if
UserAttribs(AttrName) = AttrValues
End Sub
'========================================================================
' DoAddSystemDsns
'
Sub DoAddSystemDsns
CheckDsnSwitches
Dim Validate
Validate = true
if Defined(Switches("validate")) then
if LCase(Switches("validate")) = "n" then
Validate = false
end if
end if
' get DSNs from switches. If there are incorrect entries, error out
' (error handler not yet activated!)
Dim Dsns
Set Dsns = GetDsns( "", True )
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "ADD SYSTEM DSNS"
Dim Dsn, ConnStr
for each Dsn in Dsns
ConnStr = Dsns(Dsn)
' delete existing DSN first
DestroySystemDsn Dsn
' add new DSN
Trace "Add DSN " & Dsn & " (conn. string: " & ConnStr & ")"
CreateSystemDsn ConnStr
' Validate DSN. If there is an error, we proceed with the next DSN, but the
' error info is saved and the script will return a critical error to the caller
if Validate then
ValidateConnection ConnStr, ""
end if
next
DisplayActionFinish "ADD SYSTEM DSNS"
End Sub
'========================================================================
' DoRemoveSystemDsns
'
Sub DoRemoveSystemDsns
CheckDsnSwitches
' get DSNs from switches. If there are incorrect entries, error out
' (error handler not yet activated)
Dim Dsns
Set Dsns = GetDsns( "", False )
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "REMOVE SYSTEM DSNS"
Dim Dsn
for each Dsn in Dsns
Trace "Remove DSN " & Dsn
DestroySystemDsn Dsn
next
DisplayActionFinish "REMOVE SYSTEM DSNS"
End Sub
'========================================================================
' CheckDsnSwitches
'
Sub CheckDsnSwitches
Dim MissingSwitches
CheckSwitches Array("dsn"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dsn:"+vbTab+"Connection to add/remove" + vbCRLF +_
vbTab+"/validate:y|n"+vbTab+vbTab+vbTab+"Validate connections Yes|No (default Yes)" + vbCRLF +_
vbCRLF +_
"Can specify multiple connection strings to add remove. Examples:" + vbCRLF +_
vbCRLF +_
"CSCRIPT setup.vbs add_dsns " + vbCRLF +_
"/dsn:""DSN=EECommon;Server=srv09999;Database=EECommon;UID=wwwapps;"" " + vbCRLF +_
"/dsn:""DSN=EECommon2;Server=srv09999;Database=EECommon2;UID=sa;""" + vbCRLF +_
vbCRLF +_
"CSCRIPT setup.vbs /dsn:""DSN=Test;"" /dsn:""DSN=Test2;""" + vbCRLF +_
vbCRLF +_
"Nota bene: the connection string is case sensitive. E.g. specify UID and not Uid or uid."
end if
End Sub
'=============================================================================
' DoLoginSql
'
Sub DoLogonSql
CheckSqlSwitches
If g_ErrorHandler Then On Error Resume Next
Dim Sqls
Set Sqls = CreateObj("SQLDMO.SQLServer")
Sqls.Connect Switches("dbserver"), Switches("dbuser"), Switches("dbpassword")
' catch error
RaiseOnError Wizard("Sql_LoginFailed")
End Sub
'========================================================================
' CheckSqlSwitches
'
Sub CheckSqlSwitches
Dim MissingSwitches
CheckSwitches Array("dbserver","dbuser"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dbserver:string"+vbTab+vbTab+"Name of the SQL Server machine" + vbCRLF +_
vbTab+"/dbuser:string"+vbTab+vbTab+"SQL Server user name" + vbCRLF +_
vbTab+"/dbpassword:string"+vbTab+vbTab+"SQL Server password (optional)"
end if
End Sub
'=============================================================================
' DoCheckSqlConnection
'
Sub DoCheckSqlConnection
CheckSqlConnectionSwitches
If g_ErrorHandler Then On Error Resume Next
' try to open the connection
Dim ConnString
ConnString = Switches("conn")
Dim Conn
Set Conn = CreateObj("ADODB.Connection")
Conn.Open ConnString
' Close again if successfully opened
if Err.number = 0 then
Conn.Close
else
RaiseOnError Format1(Wizard("Sql_ConnectFailed"),ConnString)
end if
End Sub
'========================================================================
' CheckSqlConnectionSwitches
'
Sub CheckSqlConnectionSwitches
Dim MissingSwitches
CheckSwitches Array("conn"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/conn:string"+vbTab+vbTab+"ODBC connection string to validate" + vbCRLF +_
"" + vbCRLF +_
"Example:" + vbCRLF +_
"/conn:""DSN=master;UID=sa;PWD=;"""
end if
End Sub
'=============================================================================
' DoExecSqlCommand
'
Sub DoExecSqlCommand
CheckSqlCommandSwitches
ExecSqlCommand Switches("dbserver"), Switches("database"), _
Switches("dbuser"), Switches("dbpassword"), Switches("sql_cmd")
End Sub
'========================================================================
' CheckSqlCommandSwitches
'
Sub CheckSqlCommandSwitches
Dim MissingSwitches
CheckSwitches Array("dbserver","database","dbuser","sql_cmd"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dbserver"+vbTab+"SQL Server on which to execute the SQL command" + vbCRLF +_
vbTab+"/database"+vbTab+"Database on which to execute the SQL command" + vbCRLF +_
vbTab+"/dbuser:string"+vbTab+vbTab+"User having privileges on the above database" + vbCRLF +_
vbTab+"/dbpassword:string"+vbTab+"Password of the above user (optional)" + vbCRLF +_
vbTab+"/sql_cmd:string"+vbTab+"SQL command (SELECT, INSERT, UPDATE ...) to execute"
end if
End Sub
'=============================================================================
' DoExecSqlCommand2
'
Sub DoExecSqlCommand2
CheckSqlCommandSwitches2
ExecSqlCommand2 Switches("conn"), Switches("sql_cmd")
End Sub
'========================================================================
' CheckSqlCommandSwitches2
'
Sub CheckSqlCommandSwitches2
Dim MissingSwitches
CheckSwitches Array("conn","sql_cmd"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/conn:string"+vbTab+vbTab+"ODBC connection string" + vbCRLF +_
vbTab+"/sql_cmd:string"+vbTab+"SQL command (SELECT, INSERT, UPDATE ...) to execute" + vbCRLF +_
"" + vbCRLF +_
"Example connection string:" + vbCRLF +_
"/conn:""DSN=EECommon;UID=sa;PWD=;"""
end if
End Sub
'=============================================================================
' DoCreateDatabases
'
Sub DoCreateDatabases
CheckCreateDatabaseSwitches
If g_ErrorHandler Then On Error Resume Next
' get databases to create from switches. If there are incorrect entries, error out
' (error handler not yet activated)
Dim Databases
Set Databases = GetDatabases(true)
if Not IsErrorClear() then
exit sub
end if
CreateDatabases Switches("dbserver"), "sa", Switches("sapassword"), Databases
End Sub
'========================================================================
' CheckCreateDatabaseSwitches
'
Sub CheckCreateDatabaseSwitches
Dim MissingSwitches
CheckSwitches Array("dbserver","db"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dbserver:string"+vbTab+vbTab+"Name of the SQL Server machine" + vbCRLF +_
vbTab+"/sapassword:string"+vbTab+"SQL Server password for the SA user (optional)" + vbCRLF +_
vbTab+"/db:string"+vbTab+vbTab+"Database and associated Public user to create" + vbCRLF +_
vbCRLF +_
"Can specify multiple databases to create. Examples:" + vbCRLF +_
vbCRLF +_
"CSCRIPT setup.vbs create_databases " + vbCRLF +_
"/db:""Database=EECommon;UID=wwwapps;PWD=;Role=public;Size=10;"" " + vbCRLF +_
"/db:""Database=ESales;UID=wwwapps;Role=db_owner;""" + vbCRLF +_
vbCRLF +_
"UID is the SQL Server user/logon to create and to assign Public rights on the database." + vbCRLF +_
"PWD is optional, if you omit this the user will be assigned an empty password." + vbCRLF +_
"Role can be: ""public"" or ""db_owner"" (default is ""public"")." + vbCRLF +_
"Size is the initial database size in Mb, if you omit this the size will be 1 Mb." + vbCRLF +_
vbCRLF +_
"Nota bene: the database string is case sensitive. E.g. specify UID and not Uid or uid."
end if
End Sub
'=============================================================================
' DoDeleteDatabases
'
Sub DoDeleteDatabases
CheckDeleteDatabaseSwitches
If g_ErrorHandler Then On Error Resume Next
' get databases to delete from switches. If there are incorrect entries, error out
' (error handler not yet activated)
Dim Databases
Set Databases = GetDatabases(false)
if Not IsErrorClear() then
exit sub
end if
DeleteDatabases Switches("dbserver"), "sa", Switches("sapassword"), Databases
End Sub
'========================================================================
' CheckDeleteDatabaseSwitches
'
Sub CheckDeleteDatabaseSwitches
Dim MissingSwitches
CheckSwitches Array("dbserver","db"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/dbserver:string"+vbTab+vbTab+"Name of the SQL Server machine" + vbCRLF +_
vbTab+"/sapassword:string"+vbTab+"SQL Server password for the SA user (optional)" + vbCRLF +_
vbTab+"/db:string"+vbTab+vbTab+"Database and associated Public user to delete" + vbCRLF +_
vbCRLF +_
"Can specify multiple databases to delete. Examples:" + vbCRLF +_
vbCRLF +_
"CSCRIPT setup.vbs delete_databases " + vbCRLF +_
"/db:""Database=EECommon;UID=wwwapps;"" " + vbCRLF +_
"/db:""Database=ESales;UID=wwwapps;""" + vbCRLF +_
vbCRLF +_
"UID is the SQL Server Public user/logon associated with the database." + vbCRLF +_
vbCRLF +_
"Nota bene: the database string is case sensitive. E.g. specify UID and not Uid or uid."
end if
End Sub
'========================================================================
' GetDatabases
'
Function GetDatabases( bForCreate )
Dim Databases
Set Databases = CreateObj("Scripting.Dictionary")
Dim List
Set List = GetValuesFromSwitch( Switches("db") )
Dim ConnStr, DBName, UID, Size
for each ConnStr in List
' parse ConnString
DBName = GetSubPart(ConnStr,"Database")
UID = GetSubPart(ConnStr,"UID")
Size = GetSubPart(ConnStr,"Size")
if DBName = "" or ( bForCreate and (UID = "" or not ValidNumber(Size,false)) ) then
RaiseError Format1(Wizard("Database_InvalidConnString"),ConnStr)
end if
' Add entry for this database (key = database name, value = rest of the
' conn. string: UID and PWD)
Databases(DBName) = ConnStr
next
Set GetDatabases = Databases
End Function
'========================================================================
' DoInstallComponents
'
Sub DoInstallComponents
CheckInstallComponentSwitches
If g_ErrorHandler Then On Error Resume Next
Dim COMComponents(), MTSComponents()
if defined(Switches("cfg_file")) then
GetComponentsFromFile Switches("cfg_file"), COMComponents, MTSComponents
end if
if defined(Switches("comp")) or defined(Switches("mtscomp")) then
GetComponentsFromSwitches Switches("comp"), Switches("mtscomp"), COMComponents, MTSComponents
end if
if Not IsErrorClear() then
exit sub
end if
Dim bDelPackage
bDelPackage = false
if Defined(Switches("del_package")) then
if LCase(Switches("del_package")) = "y" then
bDelPackage = true
end if
end if
InstallCOMComponents Switches("component_dir"), COMComponents, true
' Only install MTS package if switch "mts_package" is present
if Defined(Switches("mts_package")) then
InstallMTSComponents Switches("component_dir"), MTSComponents, Switches("mts_package"), _
Switches("mts_username"), Switches("mts_password"), bDelPackage, true
end if
End Sub
'========================================================================
' CheckInstallComponentSwitches
'
Sub CheckInstallComponentSwitches
Dim MissingSwitches
if not defined(Switches("component_dir")) or _
( not defined(Switches("cfg_file")) and not defined(Switches("comp")) and _
not defined(Switches("mtscomp")) ) then
MissingSwitches = _
"You must specify /component_dir and one or more of the following: " & _
"/comp, /mtscomp and/or /cfg_file"
end if
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/component_dir:string"+vbTab+"Directory containing the component files" + vbCRLF + _
vbTab+"/mts_package:string"+vbTab+"Name of the MTS package to install/uninstall" + vbCRLF + _
vbTab+"/mts_username:string"+vbTab+"User under which to run MTS package (optional)" + vbCRLF + _
vbTab+"/mts_password:string"+vbTab+"Password for the above user account (optional)" + vbCRLF + _
vbTab+"/cfg_file:string"+vbTab+"Path + file name of INI file listing components" + vbCRLF + _
vbTab+"/comp:string"+vbTab+vbTab+"Regular COM component to be registered" + vbCRLF + _
vbTab+"/mtscomp:string"+vbTab+vbTab+"MTS component to be added to the MTS package" + vbCRLF + _
vbTab+"/del_package:y|n"+vbTab+"Delete MTS package first? (Y(es) or N(o))" + vbCRLF +_
"" + vbCRLF + _
"You can list the components in a Config file, or you can specify them using one" + vbCRLF + _
"or more /comp and /mtscomp switches. In the /comp or /mtscomp switch, specify" + vbCRLF + _
"the relative path from the base directory as specified in /component_dir." + vbCRLF + _
"" + vbCRLF + _
"Examples:" + vbCRLF + _
"" + vbCRLF + _
"/comp:""EEBackendComponent\EEBcbeBackendComponent.dll"" " + vbCRLF + _
"/mtscomp:""ECatalog\ECatalog.dll"" " + vbCRLF + _
"/cfg_file:""C:\WWWapps\Ee11_Install\Scripts\Components\components.ini"" " + vbCRLF + _
"" + vbCRLF + _
"Nota bene: You need not specify a component in a /comp switch, if it is already" + vbCRLF + _
"included in an /mtscomp switch."
end if
End Sub
'========================================================================
' DoUninstallComponents
'
Sub DoUninstallComponents
CheckUninstallComponentSwitches
If g_ErrorHandler Then On Error Resume Next
Dim COMComponents(), MTSComponents()
if defined(Switches("cfg_file")) then
GetComponentsFromFile Switches("cfg_file"), COMComponents, MTSComponents
end if
if defined(Switches("comp")) or defined(Switches("mtscomp")) then
GetComponentsFromSwitches Switches("comp"), Switches("mtscomp"), COMComponents, MTSComponents
end if
if Not IsErrorClear() then
exit sub
end if
InstallCOMComponents Switches("component_dir"), COMComponents, false
' Only uninstall MTS package if switch "mts_package" is present
if Defined(Switches("mts_package")) then
InstallMTSComponents Switches("component_dir"), MTSComponents, Switches("mts_package"), _
"", "", false, false
end if
End Sub
'========================================================================
' CheckUninstallComponentSwitches
'
Sub CheckUninstallComponentSwitches
Dim MissingSwitches
if not defined(Switches("component_dir")) or _
( not defined(Switches("cfg_file")) and not defined(Switches("comp")) and _
not defined(Switches("mtscomp")) ) then
MissingSwitches = _
"You must specify one or more of the following: " & _
"/comp, /mtscomp and/or /cfg_file"
end if
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/mts_package:string"+vbTab+"Name of the MTS package to install/uninstall" + vbCRLF + _
vbTab+"/cfg_file:string"+vbTab+"Path + file name of INI file listing components" + vbCRLF + _
vbTab+"/comp:string"+vbTab+vbTab+"Regular COM component to be registered" + vbCRLF + _
vbTab+"/mtscomp:string"+vbTab+vbTab+"MTS component to be added to the MTS package" + vbCRLF + _
"" + vbCRLF + _
"You can list the components in a Config file, or you can specify them using one" + vbCRLF + _
"or more /comp and /mtscomp switches. In the /comp or /mtscomp switch, specify" + vbCRLF + _
"the relative path from the base directory as specified in /component_dir." + vbCRLF + _
"" + vbCRLF + _
"Examples:" + vbCRLF + _
"" + vbCRLF + _
"/comp:""EEBackendComponent\EEBcbeBackendComponent.dll"" " + vbCRLF + _
"/mtscomp:""ECatalog\ECatalog.dll"" " + vbCRLF + _
"/cfg_file:""C:\WWWapps\Ee11_Install\Scripts\Components\components.ini"" " + vbCRLF + _
"" + vbCRLF + _
"Nota bene: You need not specify a component in a /comp switch, if it is already" + vbCRLF + _
"included in an /mtscomp switch."
end if
End Sub
'========================================================================
' GetComponentsFromFile
'
Sub GetComponentsFromFile( ByVal CfgFile, ByRef COMComponents, ByRef MTSComponents )
if g_ErrorHandler then on error resume next
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim File
Set File = Fso.OpenTextFile( CfgFile, 1 )
if not IsErrorClear() then
RaiseOnError Format1(Wizard("InstComp_CfgOpen"),CfgFile)
exit sub
end if
Dim Line
' Read lines form the config file and put them into arrays
do while not File.AtEndOfStream
Line = File.ReadLine()
if InStr(1, Line, "[COM]", vbTextCompare) then
ReadComponents File, COMComponents, MTSComponents, false
elseif InStr(1, Line, "[MTS]", vbTextCompare) then
ReadComponents File, COMComponents, MTSComponents, true
end if
loop
File.Close
RaiseOnError Format1(Wizard("InstComp_CfgFile"),CfgFile)
End Sub
'========================================================================
' ReadComponents
'
Sub ReadComponents( ByVal File, ByRef COMComponents, ByRef MTSComponents, ByVal bMTSComponents )
Dim Line, Count
Line = File.ReadLine()
Count = 0
do while Line <> "" and not File.AtEndOfStream
If InStr(1, Line, "'", vbTextCompare) = 0 Then
If bMTSComponents Then
ReDim Preserve MTSComponents(Count)
MTSComponents(Count) = Line
Else
ReDim Preserve COMComponents(Count)
COMComponents(Count) = Line
End If
Count = Count + 1
End If
Line = File.ReadLine()
loop
End Sub
'========================================================================
' GetComponentsFromSwitches
'
Sub GetComponentsFromSwitches( ByVal ComponentSwitch, ByVal MTSComponentSwitch, _
ByRef COMComponents, ByRef MTSComponents )
if g_ErrorHandler then on error resume next
Dim CompList
Set CompList = GetValuesFromSwitch( ComponentSwitch )
Dim MtsCompList
Set MtsCompList = GetValuesFromSwitch( MTSComponentSwitch )
' Get the number of components already in the arrays "COMComponents" and "MTSComponents"
Dim CompCount, MtsCompCount
CompCount = 0 : MtsCompCount = 0
on error resume next
CompCount = UBound(COMComponents)
MtsCompCount = UBound(MTSComponents)
if not g_ErrorHandler then on error goto 0
err.clear
Dim Component
' add the components from the /comp switch to the COMComponents array
for each Component in CompList
ReDim Preserve COMComponents(CompCount)
COMComponents(CompCount) = Component
CompCount = CompCount + 1
next
' add the components from the /comp switch to the MTSComponents array AND to the
' COMComponents array (because an MTS component is also a COM component)
for each Component in MtsCompList
ReDim Preserve MTSComponents(MtsCompCount)
MTSComponents(MtsCompCount) = Component
MtsCompCount = MtsCompCount + 1
ReDim Preserve COMComponents(CompCount)
COMComponents(CompCount) = Component
CompCount = CompCount + 1
next
End Sub
'========================================================================
' DoCheckMTSPackage
'
Sub DoCheckMTSPackage
CheckMTSPackageSwitches
CheckMTSPackage Switches("mts_package")
End Sub
'========================================================================
' CheckMTSPackageSwitches
'
Sub CheckMTSPackageSwitches()
Dim MissingSwitches
CheckSwitches Array("mts_package"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/mts_package:string"+vbTab+"Name of MTS package to check"
end if
End Sub
'========================================================================
' DoRemoveMTSPackage
'
Sub DoRemoveMTSPackage
CheckRemoveMTSPackageSwitches
RemoveMTSPackage Switches("mts_package")
End Sub
'========================================================================
' CheckRemoveMTSPackageSwitches
'
Sub CheckRemoveMTSPackageSwitches()
Dim MissingSwitches
CheckSwitches Array("mts_package"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/mts_package:string"+vbTab+"Name of MTS package to remove"
end if
End Sub
'========================================================================
' DoStopServices
'
Sub DoStopServices
CheckStopServiceSwitches
Dim bStandardServices
if UCase(Switches("standard")) = "N" then
bStandardServices = false
else
bStandardServices = true
end if
Dim Services
Services = GetServices( bStandardServices, Switches("svc") )
StopServices Services, bStandardServices
End Sub
'========================================================================
' CheckStopServiceSwitches
'
Sub CheckStopServiceSwitches
Dim MissingSwitches
CheckSwitches Array("standard"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/standard:y|n"+vbTab+vbTab+"Stop standard services and MTS (Yes/No)" + vbCRLF +_
vbTab+"/svc:string"+vbTab+vbTab+"Name of an additional service to stop" + vbCRLF +_
vbCRLF +_
"/standard:y means Site Server and IIS services are stopped." + vbCRLF +_
"/svc: specifies an additional service to stop, e.g. an E-Enterprise service" +_
" (you can specify more than one /srv switch)."
end if
End Sub
'========================================================================
' GetServices
'
Function GetServices( ByVal bStandardServices, ByRef AdditionalServices )
Dim Services()
if bStandardServices then
AddService Services, "IISADMIN"
AddService Services, "SMTPSVC"
AddService Services, "MSFTPSVC"
AddService Services, "BROKSVC"
AddService Services, "LDAPSVC"
AddService Services, "MSGBLDSVC"
AddService Services, "TMLBSVC"
if not IsRunningInASP() then
AddService Services, "W3SVC"
end if
end if
if not IsVoid(AdditionalServices) then
Dim List
Set List = GetValuesFromSwitch( AdditionalServices )
Dim Service
for each Service in List
AddService Services, Service
next
end if
GetServices = Services
End Function
'========================================================================
' AddService
'
Sub AddService( ByRef Services, ByVal Service )
Dim Count
on error resume next
Count = UBound(Services)
if err.number = 0 then
Count = Count + 1
else
Count = 0
end if
on error goto 0
Redim Preserve Services(Count)
Services(Count) = Service
End Sub
'========================================================================
' DoStartServices
'
Sub DoStartServices
CheckStartServiceSwitches
Dim bStandardServices
if UCase(Switches("standard")) = "N" then
bStandardServices = false
else
bStandardServices = true
end if
Dim Services
Services = GetServices( bStandardServices, Switches("svc") )
StartServices Services
End Sub
'========================================================================
' CheckStartServiceSwitches
'
Sub CheckStartServiceSwitches
Dim MissingSwitches
CheckSwitches Array("standard"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/standard:y|n"+vbTab+vbTab+"Start standard services (Yes/No)" + vbCRLF +_
vbTab+"/svc:string"+vbTab+vbTab+"Name of an additional service to start" + vbCRLF +_
vbCRLF +_
"/standard:y means Site Server and IIS services are started." + vbCRLF +_
"/svc: specifies an additional service to start, e.g. an E-Enterprise service" +_
" (you can specify more than one /srv switch)."
end if
End Sub
'========================================================================
' DoConfigBuildServer
'
Sub DoConfigBuildServer
CheckConfigBuildSwitches
Dim DestServers
Set DestServers = GetValuesFromSwitch( Switches("destserver") )
ConfigBuildServer Switches("websitename"),Switches("webserver"),Switches("homedir"), _
Switches("sbpfile"),Switches("catalogname"),DestServers
End Sub
'========================================================================
' CheckConfigBuildSwitches
'
Sub CheckConfigBuildSwitches
Dim MissingSwitches
CheckSwitches Array("websitename","webserver","homedir","sbpfile","catalogname","destserver"), _
MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websitename:string"+vbTab+"Name of cat. build web site (create if needed)" + vbCRLF +_
vbTab+"/webserver:string"+vbTab+"Name of the web server to house the site" + vbCRLF +_
vbTab+"/homedir:string"+vbTab+vbTab+"Home directory of the web site" + vbCRLF +_
vbTab+"/sbpfile:string"+vbTab+vbTab+"Path/file name of the .SBP file" + vbCRLF +_
vbTab+"/catalogname:string"+vbTab+"Name of the Build server catalog" + vbCRLF +_
vbTab+"/destserver:string"+vbTab+"Destination server to which to propagate" + vbCRLF +_
vbCRLF +_
"You can specify more than one /destserver switch."
end if
End Sub
'========================================================================
' DoUnconfigBuildServer
'
Sub DoUnconfigBuildServer
CheckUnconfigBuildSwitches
UnconfigBuildServer Switches("websitename"),Switches("webserver"),Switches("catalogname")
End Sub
'========================================================================
' CheckUnconfigBuildSwitches
'
Sub CheckUnconfigBuildSwitches
Dim MissingSwitches
CheckSwitches Array("websitename","webserver","catalogname"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websitename:string"+vbTab+"Name of the cat. build web site to delete" + vbCRLF +_
vbTab+"/webserver:string"+vbTab+"Name of the web server housing the site" + vbCRLF +_
vbTab+"/catalogname:string"+vbTab+"Name of the Build server catalog"
end if
End Sub
'========================================================================
' DoRemoveSearchCatalog
'
Sub DoRemoveSearchCatalog
CheckRemoveSearchCatalogSwitches
RemoveSearchCatalog Switches("catalogname")
End Sub
'========================================================================
' CheckRemoveSearchCatalogSwitches
'
Sub CheckRemoveSearchCatalogSwitches
Dim MissingSwitches
CheckSwitches Array("catalogname"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/catalogname:string"+vbTab+"Name of the Search catalog to remove"
end if
End Sub
'========================================================================
' DoCheckNTUser
'
Sub DoCheckNTUser
CheckNTUserSwitches
CheckNTUser Switches("domain"), Switches("username")
End Sub
'========================================================================
' CheckNTUserSwitches
'
Sub CheckNTUserSwitches
Dim MissingSwitches
CheckSwitches Array("domain","username"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/domain:string"+vbTab+"NT domain (may also be computer name)" + vbCRLF +_
vbTab+"/username:string"+vbTab+"Name of an NT user account"
end if
End Sub
'========================================================================
' DoCheckMemUser
'
Sub DoCheckMemUser
CheckMemUserSwitches
CheckMemUser Switches("websiteid"), Switches("username"), Switches("password")
End Sub
'========================================================================
' CheckMemUserSwitches
'
Sub CheckMemUserSwitches
Dim MissingSwitches
CheckSwitches Array("websiteid","username"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/websiteid:number"+vbTab+"Web Site to which the command should apply" + vbCRLF +_
vbTab+"/username:string"+vbTab+"Name of a Membership Directory user account" + vbCRLF +_
vbTab+"/password:string"+vbTab+"Password of the Membership Directory user"
end if
End Sub
'========================================================================
' DoCheckQueryFieldHasString
'
Sub DoCheckQueryFieldHasString
CheckQueryFieldSwitches
CheckQueryFieldHasString Switches("conn"), Switches("query"), Switches("fieldname")
End Sub
'========================================================================
' CheckQueryFieldSwitches
'
Sub CheckQueryFieldSwitches
Dim MissingSwitches
CheckSwitches Array("conn","query","fieldname"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/conn:string"+vbTab+vbTab+"ODBC connection string" + vbCRLF +_
vbTab+"/query:string"+vbTab+"SQL command (SELECT ... FROM) to execute" + vbCRLF +_
vbTab+"/fieldname:string"+vbTab+"Field whose value is to be checked" + vbCRLF +_
"" + vbCRLF +_
"Example connection string:" + vbCRLF +_
"/conn:""DSN=EECommon;UID=sa;PWD=;"""
end if
End Sub
'========================================================================
' DoUpdateMetabase
'
Sub DoUpdateMetabase
CheckUpdateMetabaseSwitches
MetaUpdate Switches("machine"), Switches("servertype"), Switches("action"), Switches("filelist"),_
Switches("version"), Switches("servicepack"), Switches("patch"), Switches("hist_only")
End Sub
'========================================================================
' CheckUpdateMetabaseSwitches
'
Sub CheckUpdateMetabaseSwitches
Dim MissingSwitches
CheckSwitches Array("machine","servertype"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/machine:string"+vbTab+vbTab+"Windows NT machine name" + vbCRLF +_
vbTab+"/servertype:string"+vbTab+"Server type (WebServer, DbServer, BldServer)" + vbCRLF +_
vbTab+"/action:string"+vbTab+vbTab+"Installation action (Install, Reinstall etc.)" + vbCRLF +_
vbTab+"/filelist:string"+vbTab+"List of installed files (optional)" + vbCRLF +_
vbTab+"/version:string"+vbTab+vbTab+"Version number being installed (optional)" + vbCRLF +_
vbTab+"/servicepack:string"+vbTab+"Service pack version number (optional)" + vbCRLF +_
vbTab+"/patch:string"+vbTab+vbTab+"Patch version number (optional)" + vbCRLF +_
vbTab+"/hist_only:y|n"+vbTab+vbTab+"Just update the History table, nothing else"
end if
End Sub
'========================================================================
' DoCheckMetaFileVersions
'
Sub DoCheckMetaFileVersions
CheckMetaFileVersionsSwitches
MetaCheckFileVersions Switches("machine"), Switches("servertype"), Switches("srcdir"), _
Switches("infile"), Switches("outfile"), Switches("check_versions")
End Sub
'========================================================================
' CheckMetaFileVersionsSwitches
'
Sub CheckMetaFileVersionsSwitches
Dim MissingSwitches
CheckSwitches Array("machine","servertype","srcdir","infile","outfile","check_versions"), _
MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/machine:string"+vbTab+vbTab+"Windows NT machine name" + vbCRLF +_
vbTab+"/servertype:string"+vbTab+"Server type (WebServer, DbServer, BldServer)" + vbCRLF +_
vbTab+"/srcdir:string"+vbTab+vbTab+"Source directory" + vbCRLF +_
vbTab+"/infile:string"+vbTab+vbTab+"Input: file version list" + vbCRLF +_
vbTab+"/outfile:string"+vbTab+vbTab+"Output: list of files to be copied" + vbCRLF +_
vbTab+"/check_versions:y|n"+vbTab+"Check file version numbers (yes or no)"
end if
End Sub
'========================================================================
' DoFixMeta2_0
'
Sub DoFixMeta2_0
CheckFixMeta2_0Switches
MetaFix2_0 Switches("machine"), Switches("servertype"), Switches("version"), Switches("filelist")
End Sub
'========================================================================
' CheckFixMeta2_0Switches
'
Sub CheckFixMeta2_0Switches
Dim MissingSwitches
CheckSwitches Array("machine","servertype","version","filelist"), MissingSwitches
if MissingSwitches <> "" then
DisplayHelp MissingSwitches, _
vbTab+"/machine:string"+vbTab+vbTab+"Windows NT machine name" + vbCRLF +_
vbTab+"/servertype:string"+vbTab+"Server type (WebServer, DbServer, BldServer)" + vbCRLF +_
vbTab+"/version:string"+vbTab+vbTab+"Version number being installed" + vbCRLF +_
vbTab+"/filelist:string"+vbTab+"List of installed files for 2.0"
end if
End Sub
'========================================================================
' DoTestWSH
'
Sub DoTestWSH
WScript.Echo "Test WSH: OK"
WScript.Quit 9 ' return exit code 9; the calling process then knows that
' we arrived here and that Windows Scripting Host is therefore
' installed correctly
End Sub
'########################################################################
'# Routines which hide differences between scripting engines (ASP/WSH)
'########################################################################
' Base Registry key for E-Enterprise (changed from 1.1 to 2.0 during E-Procurement development)
Const REGKEY_BASE = "HKLM\SOFTWARE\Baan\Baan E-Enterprise 1.1"
Const REGKEY_BASE2 = "HKLM\SOFTWARE\Baan\Baan E-Enterprise"
' Predefined Registry keys for inter-program communication between InstallShield (Setup.exe)
' and Setup.vbs (CScript.exe)
Const REGKEY_PROGRESS = "HKLM\SOFTWARE\Baan\Baan E-Enterprise\MonitorProgress"
Const REGKEY_RESULTS = "HKLM\SOFTWARE\Baan\Baan E-Enterprise\ProcessResultMsg"
Public g_ASPScriptingEngine, g_WSHScriptingEngine
Public g_WshShell
'========================================================================
' RetrieveArguments
'
Sub RetrieveArguments()
on error resume next
g_ArgCount = WScript.Arguments.Count
if Err = 0 then
g_WSHScriptingEngine = True
else
g_WSHScriptingEngine = False
end if
on error goto 0
g_ASPScriptingEngine = not g_WSHScriptingEngine
' Get parameters from WScript or ASP page
if g_WSHScriptingEngine then
Set g_Arguments = WScript.Arguments
else
g_Arguments = g_ArgsFromASP
g_ArgCount = UBound(g_Arguments)
end if
End Sub
'========================================================================
' IsRunningInASP
'
Function IsRunningInASP()
IsRunningInASP = g_ASPScriptingEngine
End Function
'========================================================================
' IsRunningInWSH
'
Function IsRunningInWSH()
IsRunningInWSH = g_WSHScriptingEngine
End Function
'========================================================================
' CreateObj
'
Function CreateObj(ByVal strProgID)
If g_ErrorHandler Then On Error Resume Next
if IsRunningInWSH() then
Set CreateObj = WScript.CreateObject(strProgID)
else ' ASP
Set CreateObj = Server.CreateObject(strProgID)
end if
' Non-localizable string if dictionaries cannot be created
RaiseOnError "Check installation." + vbCrlf +_
"Unable to create object :" + strProgID
End Function
'========================================================================
' Yell
'
Sub Yell(ByVal str, ByVal Volume)
YellExt str, str, Volume
End Sub
'========================================================================
' YellExt
'
Sub YellExt(ByVal errmsg, ByVal str, ByVal Volume)
If g_ErrorHandler Then On Error Resume Next
If Len(str) > 0 Then
if UCase(Switches("interactive")) = "N" then
'OutputDebugString "Error caught: " & str
OutputDebugString str
else
MsgBox str, Volume, "Microsoft Site Server"
end if
if IsRunningInWSH() then
WriteResultMessage errmsg
WScript.Quit 1 ' return exit code: error (1)
else ' ASP
Response.End
end if
End If
End Sub
'========================================================================
' OutputDebugString
'
Sub OutputDebugString(ByVal str)
If Defined(str) Then
if IsRunningInWSH() then
WScript.Echo str
else
str = Replace(str, vbCRLF, "
")
Response.Write str & "
" & vbCRLF
end if
End If
End Sub
'========================================================================
' Echo
'
Sub Echo(ByVal str)
If Defined(str) Then
if IsRunningInWSH() then
if UCase(Switches("interactive")) = "N" then
WScript.Echo str
else
MsgBox str
end if
else
str = Replace(str, vbCRLF, "
") & vbCRLF
Response.Write str & "
"
end if
End If
End Sub
'========================================================================
' WriteResultMessage
'
sub WriteResultMessage( ByVal Message )
if IsRunningInWSH() then
If g_ErrorHandler Then On Error Resume Next
' return up to MAXLEN_RESULT characters of the result message
Message = Left(Message,MAXLEN_RESULT)
call GetWshShell().RegWrite(REGKEY_RESULTS, Message)
end if
end sub
'========================================================================
' WriteProgressMsg
'
sub WriteProgressMsg( ByVal Message )
if IsRunningInWSH() then
call GetWshShell().RegWrite(REGKEY_PROGRESS, Message)
end if
Trace ">>> " & Message
end sub
'========================================================================
' Get GetWshShell object
'
function GetWshShell()
if IsEmpty(g_WshShell) then
Set g_WshShell = CreateObject("Wscript.Shell")
end if
Set GetWshShell = g_WshShell
end function
'#############################################################################
'# Commerce Site Configuration
'#############################################################################
'=============================================================================
' CreateSite
'
Sub CreateSite(ByVal Instance, ByVal SiteName, ByVal DisplayName, _
ByVal DstDir, ByVal TemplDir, _
ByVal Conn, ByVal Accts, ByVal AspSessions, ByVal Server, _
ByVal HostName, ByVal AclFile1, ByVal AclFile2, ByVal fReinstall)
If g_ErrorHandler Then On Error Resume Next
'-------------------------------------------------------------------------
' Compute defaults (or error out)
'
If Not Defined(Instance) Then
RaiseError Wizard("CreateSiteNoID")
End If
If Not Defined(SiteName) Then
RaiseError Wizard("CreateSiteNoSiteName")
End If
If Not Defined(Conn) Then
RaiseError Wizard("CreateSiteNoConnectionString")
End If
if IsMembership(Instance, Server) then
call DSAuthenticate(Server)
end if
DisplayActionStart "CREATING COMMERCE SITE"
Dim ParamNames, ParamValues
ParamNames = Array("Instance", "SiteName", "DisplayName", "DstDir", "TemplDir", "Conn",_
"Accts", "Server", "HostName", "AclFile1", "AclFile2", "fReinstall")
ParamValues = Array(Instance, SiteName, DisplayName, DstDir, TemplDir, Conn,_
Accts, Server, HostName, AclFile1, AclFile2, fReinstall)
TraceParameters ParamNames, ParamValues
Dim WebSiteProps
Set WebSiteProps = GetWebSiteProperties(Instance, Server)
If Not Defined(DisplayName) Then
DisplayName = Wizard("CreateSiteDisplayName")
End If
If Not Defined(DstDir) Then
DstDir = WebSiteProps.VrPath + "\" + SiteName
End If
If Not Defined(Accts) Then
Accts = Split(CreateObj("Commerce.AdminLanManager").GetCurrentUser,",")
End If
If Not Defined(HostName) Then
HostName = ""
End If
WriteProgressMsg "Creating Commerce Site ..."
Dim AdminSite
Set AdminSite = CreateRemoteObj("Commerce.AdminSite", Server)
if Not fReinstall then
Dim AdminFiles
Set AdminFiles = CreateRemoteObj("Commerce.AdminFiles", Server)
'If AdminFiles.Exists(DstDir) Then
' RaiseError Wizard("CreateSiteExistingDict")
'Else
AdminFiles.CreateDirectory DstDir
RaiseOnError Wizard("CreateSiteCantCreatePath")
AdminFiles.DeleteDirectory DstDir
'End If
If Not AdminSite.IsValidName(SiteName, Instance) Then
RaiseError Wizard("CreateSiteNameNotValid")
End If
End If
If Not IsErrorClear Then
Exit Sub
End If
'-------------------------------------------------------------------------
' Create entry in site object namespace
'
AdminSite.Create Instance, SiteName, DstDir, 5, True, True
RaiseOnError Wizard("CreateWeb")
If IsMembership(Instance, Server) Then
InitForMembership Instance, SiteName, DstDir, Server
RaiseOnError Wizard("CreateSiteMembershipInitFailed")
End If
WriteProgressMsg "Configuring Commerce Site ..."
'-------------------------------------------------------------------------
' Run Templatizer to generate base site
'
If Len(TemplDir) > 0 Then
Dim Dict
Set Dict = CreateObj("Commerce.Dictionary")
Dict.FullName = DisplayName
Dict.DisplayName = DisplayName
Dict.[_SiteName] = SiteName
RecursePageGen DstDir, TemplDir, Dict, Server
RaiseOnError Wizard("CreateTmpl")
End If
'-------------------------------------------------------------------------
' Create Groups (NT or DS)
'
Trace "Create site groups ..."
' Before executing the next lines, save the global error string and restore it afterwards.
' This is because we want to discard errors which occur in the next section
' (that is, display them, but ignore them otherwise)
Dim OrgError
OrgError = GlobalError
CreateNTManagerGroup Instance, SiteName, Server
If IsMembership(Instance, Server) Then
CreateDSManagerGroup Instance, SiteName, Server
' Display errors but do not fail on them
TraceOnError Wizard("CreateSiteCreateDSManagerGroupFailed")
Else
Dim nAcct
For nAcct = LBound(Accts) To UBound(Accts)
AddManager Accts(nAcct), Instance, SiteName, Server
Next
' Display errors but do not fail on them
TraceOnError Wizard("AddAccts")
End If
' Restore global error string
GlobalError = OrgError
Trace "Create site.csc ..."
'-------------------------------------------------------------------------
' Generate Site SCF files
'
Dim SiteProp, URLBase, URLBaseS
Set SiteProp = CreateRemoteObj("Commerce.Dictionary", Server)
URLBase = GetURLBase(Instance, False, Server, HostName)
URLBaseS = GetURLBase(Instance, True, Server, HostName)
' Fill DSN
Set SiteProp.ConnectionStringMap = CreateRemoteObj("Commerce.Dictionary", Server)
'SiteProp.ConnectionStringMap(GetSubPart(Conn, "DSN")) = Conn
SiteProp.DefaultConnectionString = Conn
SetSiteProperties Instance, SiteName, SiteProp, True, Server
RaiseOnError Wizard("SaveSettings")
' Fill Statics
SiteProp.SecureHostName = Split(URLBaseS, "/")(2)
SiteProp.NonsecureHostName = Split(URLBase , "/")(2)
SiteProp.DisableHTTPs = 1
SiteProp.DisplayName = DisplayName
SiteProp.CloseRedirectURL = URLBase+SiteName+"/Closed/Closed.asp"
SiteProp.WebInstance = Instance
SiteProp.Status = "Open"
SetSiteProperties Instance, SiteName, SiteProp, FALSE, Server
RaiseOnError Wizard("SaveSettings")
'-------------------------------------------------------------------------
' Execute DB Scripts
'
ExecuteDBScripts Conn, DstDir, True, Server
WriteProgressMsg "Configure site security ..."
'''-------------------------------------------------------------------------
''' Secure Site
'''
''SecureTheSite Instance, SiteName, DstDir, Server, AclFile1, AclFile2
''RaiseOnError Wizard("CreateSiteSecureSiteFailed")
'-------------------------------------------------------------------------
' Set FrontPage Security
'
SetFPSecurity Instance, SiteName, DstDir, Server
RaiseOnError Wizard("SetFPSecurityFailed")
'-------------------------------------------------------------------------
' Switch on or off ASP Sessions
'
If Defined(AspSessions) Then
If LCase(AspSessions) = "y" Then
EnableAspSessions Instance, SiteName, True
SetAspScriptTimeout Instance, SiteName, True
ElseIf LCase(AspSessions) = "n" Then
EnableAspSessions Instance, SiteName, False
End If
End If
DisplayActionFinish "CREATING COMMERCE SITE"
End Sub
'=============================================================================
' SecureSite
'
Sub SecureSite(ByVal Instance, ByVal SiteName, ByVal DstDir, ByVal AclFile1, ByVal AclFile2)
If g_ErrorHandler Then On Error Resume Next
'-------------------------------------------------------------------------
' Compute defaults (or error out)
'
DisplayActionStart "SECURING COMMERCE SITE"
Dim ParamNames, ParamValues
ParamNames = Array("Instance", "SiteName", "DstDir", "AclFile1", "AclFile2")
ParamValues = Array(Instance, SiteName, DstDir, AclFile1, AclFile2)
TraceParameters ParamNames, ParamValues
SecureTheSite Instance, SiteName, DstDir, "", AclFile1, AclFile2
RaiseOnError Wizard("CreateSiteSecureSiteFailed")
DisplayActionFinish "SECURING COMMERCE SITE"
End Sub
'=============================================================================
' Delete the Site
'
Sub DeleteSite(ByVal Instance, ByVal SiteName, _
ByVal DelDatabase, ByVal DelFiles, ByVal Server)
if g_ErrorHandler then on error resume next
Dim Site, SiteDir, Version
Set Site = GetSiteObject(Instance, SiteName, Server)
Version = Site.Version
SiteDir = Site.Directory
If Version < 3 Then
RaiseError Wizard("DeleteSiteCannotDelete20Site")
Exit Sub
End If
DisplayActionStart "DELETING COMMERCE SITE"
TraceParameters Array("Instance", "SiteName", "DelDatabase", "DelFiles", "Server"), _
Array(Instance, SiteName, DelDatabase, DelFiles, Server)
WriteProgressMsg "Deleting Commerce Site ..."
Dim SiteProp, DSN
Set SiteProp = Site.ReadDefaultProperties
Site.Status = FALSE
DSN = SiteProp.DefaultConnectionString
ClearError
Site.Delete
DeleteManagerGroup Instance, SiteName, Server
If DelDatabase = True AND Len(DSN) <> 0 Then
ExecuteDBScripts DSN, SiteDir, False, Server
End If
If DelFiles = True AND Len(SiteDir) <> 0 Then
Dim AdminFiles
Set AdminFiles = CreateRemoteObj("Commerce.AdminFiles", Server)
Dim Attempts, Success
Success = False
For Attempts = 1 To 5
If Success = False Then
ClearError
AdminFiles.DeleteDirectory GetDelDir(Version, SiteDir)
Success = CBool(Err.Number = 0)
End If
Next
RaiseOnError Wizard("DeleteSiteCannotDeleteFiles")
End If
' Recreate the vroots for retry only in version 3
' Recovery from partial deletes not possible in 2.0 sites.
If Not IsErrorClear AND Version = 3 Then
Site.Create Instance, SiteName, SiteDir, 5, True, True
End If
RaiseOnError Format1(Wizard("DeleteSiteCannotDeleteSite"), SiteName)
DisplayActionFinish "DELETING COMMERCE SITE"
End Sub
'=============================================================================
' GetStatus
'
Function GetStatus(ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
Dim SiteObj
Set SiteObj = GetSiteObject(Instance, SiteName, Server)
GetStatus = Wizard("StatusInvalid")
If SiteObj.Status = True Then
GetStatus = Wizard("StatusOpen")
Else
GetStatus = Wizard("StatusClosed")
End If
RaiseOnError Format1(Wizard("GetStatusFailed"), SiteName)
End Function
'=============================================================================
' SetStatus
'
Sub SetStatus(ByVal Status, ByVal Instance, ByVal SiteName, ByVal Server)
Dim SiteObj
Set SiteObj = GetSiteObject(Instance, SiteName, Server)
SiteObj.Status = Status
RaiseOnError Format1(Wizard("SetStatusFailed"), SiteName)
End Sub
'=============================================================================
' ReloadSite
'
Sub ReloadSite(ByVal Instance, ByVal SiteName, ByVal Server)
Dim SiteObj
Set SiteObj = GetSiteObject(Instance, SiteName, Server)
SiteObj.Reload
RaiseOnError Format1(Wizard("ReloadSiteFailed"), SiteName)
End Sub
'=============================================================================
' GetSiteObject
'
Function GetSiteObject(ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
Dim Site
Set Site = CreateRemoteObj("Commerce.AdminSite", Server)
Set GetSiteObject = Site
Site.Initialize Instance, SiteName
RaiseOnError Wizard("SiteInit")
End Function
'=============================================================================
' GetSiteProperties
'
Function GetSiteProperties(ByVal Instance, ByVal SiteName, _
ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
Dim Site
Set Site = GetSiteObject(Instance, SiteName, Server)
If bMgr Then
Set GetSiteProperties = Site.ReadManagerProperties
Else
Set GetSiteProperties = Site.ReadDefaultProperties
End If
RaiseOnError Wizard("SiteLoad")
GetSiteProperties.[_Directory] = Site.Directory
End Function
'=============================================================================
' SetSiteProperties
'
Sub SetSiteProperties(ByVal Instance, ByVal SiteName, ByVal PropDict, _
ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
PropDict.DisplayName = Trim(PropDict.DisplayName)
if Len(PropDict.DisplayName) = 0 then
RaiseError Wizard("SetSitePropertiesDisplayNameNotValid")
exit sub
end if
Dim Site
Set Site = GetSiteObject(Instance, SiteName, Server)
If bMgr Then
Site.WriteManagerProperties PropDict
Else
Site.WriteDefaultProperties PropDict
End If
RaiseOnError Wizard("SiteSave")
End Sub
'=============================================================================
' EnableAspSessions
'
Sub EnableAspSessions( ByVal WebsiteID, ByVal SiteName, ByVal bEnable )
if g_ErrorHandler then on error resume next
if bEnable then
Trace "Enabling ASP Sessions on site " & SiteName
else
Trace "Disabling ASP Sessions on site " & SiteName
end if
Dim IISPath
IISPath = "IIS://LocalHost/w3svc/" & WebsiteID & "/ROOT"
Dim IISRoot
Set IISRoot = GetObject(IISPath)
TraceOnError "Error getting root object for """ & IISPath & """"
Dim IISAdminObj
Set IISAdminObj = IISRoot.GetObject("IIsWebVirtualDir",SiteName)
RaiseOnError Format1(Wizard("ASPSessions_GetIISObj"),SiteName)
IISAdminObj.AspAllowSessionState = bEnable
' Save changes to IIS Metabase
IISAdminObj.SetInfo
RaiseOnError Format1(Wizard("ASPSessions_SetIISObj"),SiteName)
End Sub
'=============================================================================
' SetAspScriptTimeout
'
Sub SetAspScriptTimeout( ByVal WebsiteID, ByVal SiteName, ByVal bEnable )
if g_ErrorHandler then on error resume next
if bEnable then
Trace "Set ASP ScriptTimeout on site " & SiteName
else
Trace "Disabling ASP Script Timeout on site " & SiteName
end if
Dim IISPath
IISPath = "IIS://LocalHost/w3svc/" & WebsiteID & "/ROOT"
Dim IISRoot
Set IISRoot = GetObject(IISPath)
TraceOnError "Error getting root object for """ & IISPath & """"
Dim IISAdminObj
Set IISAdminObj = IISRoot.GetObject("IIsWebVirtualDir",SiteName)
RaiseOnError Format1(Wizard("ASPScriptTimeout_GetIISObj"),SiteName)
IISAdminObj.AspScriptTimeout = 300
' Save changes to IIS Metabase
IISAdminObj.SetInfo
RaiseOnError Format1(Wizard("ASPScriptTimeout_SetIISObj"),SiteName)
End Sub
'#############################################################################
'# Connection string / connection map configuration
'#############################################################################
'=============================================================================
' GetDefaultConnection
'
Function GetDefaultConnection(ByVal Instance, ByVal SiteName, ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
Dim SiteProp
Set SiteProp = GetSiteProperties(Instance, SiteName, bMgr, Server)
GetDefaultConnection = SiteProp.DefaultConnectionString
RaiseOnError Format1(Wizard("GetDefaultConnectionFailed"), SiteName)
End Function
'=============================================================================
' SetDefaultConnection
'
Sub SetDefaultConnection(ByVal conn, ByVal SiteProp, ByVal Instance, ByVal SiteName, ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
call ValidateConnection(Conn, Server)
If IsErrorClear Then
SiteProp.DefaultConnectionString = conn
call SetSiteProperties(Instance, SiteName, SiteProp, bMgr, Server)
end if
RaiseOnError Format1(Wizard("SetDefaultConnectionFailed"), SiteName)
End Sub
'========================================================================
' GetConnectionStrings
'
Function GetConnectionStrings
Dim Connections
Set Connections = CreateObj("Scripting.Dictionary")
if defined(Switches("conn")) then
Dim List
Set List = GetValuesFromSwitch( Switches("conn") )
Dim Value, Index, ConnName, ConnStr
for each Value in List
' Extract connection name and string.
' Value of a Connection switch is a name=value pair.
' Look for the '=' sign in the name=value pair
Index = InStr(Value,"=")
if Index = 0 then ' only name, no value
ConnName = Value
ConnStr = ""
else
ConnName = Left(Value,Index-1)
ConnStr = Mid(Value,Index+1)
end if
Connections(ConnName) = ConnStr
next
end if
Set GetConnectionStrings = Connections
End Function
'========================================================================
' ModifyConnectionMap
'
Sub ModifyConnectionMap(ByVal Instance, ByVal SiteName, ByVal Server, ByVal ConnectionStrings,_
ByVal bAddConnections, ByVal bMgr)
' get site props. If failure, error out (error handler not yet activated)
Dim SiteProp
Set SiteProp = GetSiteProperties(Instance, SiteName, bMgr, Server)
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "MODIFY CONNECTION MAP"
TraceParameters Array("Instance", "SiteName", "Server", "ConnectionStrings",_
"bAddConnections", "bMgr"), _
Array(Instance, SiteName, Server, ConnectionStrings, bAddConnections, bMgr)
Dim Key, Conn
for each Key in ConnectionStrings
if bAddConnections then
Conn = ConnectionStrings(Key)
if Conn <> "" then
Trace "Add connection " & Key & " (conn. string: " & Conn & ")"
AddConnectionToMap Key, Conn, SiteProp, Instance, SiteName, bMgr, Server
end if
else
Trace "Remove connection " & Key
RemoveConnectionFromMap Key, SiteProp, Instance, SiteName, bMgr, Server
end if
' ignore errors (connection map entries already present or not yet present,
' or invalid connection string); just display them, and proceed with next entry
TraceOnError "Error adding connection string for " & Key & ":"
next
DisplayActionFinish "MODIFY CONNECTION MAP"
End Sub
'=============================================================================
' AddConnectionToMap
'
sub AddConnectionToMap(ByVal key, ByVal Conn, ByVal SiteProp, ByVal Instance, ByVal SiteName, _
ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
call ValidateConnection(Conn, Server)
If IsErrorClear Then
SiteProp.ConnectionStringMap(key) = Conn
call SetSiteProperties(Instance, SiteName, SiteProp, bMgr, Server)
End If
RaiseOnError Format1(Wizard("AddConnectionToMapFailed"), SiteName)
End sub
'=============================================================================
' RemoveConnectionFromMap
'
sub RemoveConnectionFromMap(ByVal key, ByVal SiteProp, ByVal Instance, ByVal SiteName, _
ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
SiteProp.ConnectionStringMap(key) = Null
If IsErrorClear Then
call SetSiteProperties(Instance, SiteName, SiteProp, bMgr, Server)
End If
RaiseOnError Format1(Wizard("RemoveConnectionFromMapFailed"), SiteName)
End sub
'=============================================================================
' GetConnectionInMap
'
function GetConnectionInMap(ByVal key, ByVal SiteProp, ByVal Instance, ByVal SiteName, _
ByVal bMgr, ByVal Server)
if g_ErrorHandler then on error resume next
GetConnectionInMap = SiteProp.ConnectionStringMap(key)
End function
'#############################################################################
'# Web Server Configuration
'#############################################################################
'=============================================================================
' GetTemplateDirectory -- Wizard template directory
'
Function GetTemplateDirectory
if g_ErrorHandler then on error resume next
Dim Reg
Set Reg = CreateObj("Commerce.AdminRegistry")
Dim TemplDir
TemplDir = Reg.GetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Site Server\3.0\InstallDirectory")
TemplDir = TemplDir + "\SiteServer\Admin\Commerce\Foundation\Template"
GetTemplateDirectory = TemplDir
RaiseOnError Wizard("GetTemplateDirectoryFailed")
End Function
'=============================================================================
' GetWebSites
'
Function GetWebSites(ByVal Server)
if g_ErrorHandler then on error resume next
Dim AdminWebServer
Set AdminWebServer = CreateRemoteObj("Commerce.AdminWebServer", Server)
Set GetWebSites = ConvertArrayToSimpleList(AdminWebServer.GetWebSites)
RaiseOnError Wizard("GetWebSitesFailed")
End Function
'=============================================================================
' GetSites
'
Function GetSites(ByVal Instance, ByVal Server)
if g_ErrorHandler then on error resume next
Dim AdminWebServer
Set AdminWebServer = CreateRemoteObj("Commerce.AdminWebServer", Server)
Set GetSites = ConvertArrayToSimpleList(AdminWebServer.GetCommerceSites(Instance))
RaiseOnError Wizard("GetWebSitesFailed")
End Function
'=============================================================================
' PrivateGetURLBase
'
Function PrivateGetURLBase(ByVal MetaPath, ByVal Http, ByVal Server, ByVal HostName)
Dim Metabase
Set Metabase = CreateRemoteObj("Commerce.AdminMetabase", Server)
Dim Bindings
Bindings = Metabase.GetValue(MetaPath)
' Pick the first binding (consists of IP, Port, Host Header)
Dim Names
Names = Split(Bindings(0), ":")
' Get the host name
Dim URL
If HostName <> "" then
URL = HostName
ElseIf Names(0) <> "" Then
URL = Names(0)
ElseIf Names(2) <> "" Then
URL = Names(2)
Else
Dim AdminIIS
Set AdminIIS = CreateRemoteObj("Commerce.AdminIIS", Server)
URL = AdminIIS.HostName
End If
' Get the port
If Names(1) <> "" Then
URL = URL + ":" + Names(1)
End If
If URL <> "" Then
URL = Http + URL + "/"
End If
PrivateGetURLBase = URL
End Function
'=============================================================================
' GetURLBase
'
Function GetURLBase(ByVal Instance, ByVal IsSecure, ByVal Server, ByVal HostName)
if g_ErrorHandler then on error resume next
Dim Try
For Try = 0 To 1
If IsSecure Then
GetURLBase = PrivateGetURLBase(_
Format1("w3svc/%1/SecureBindings", Instance), _
"HTTPS://", _
Server, HostName)
Else
GetURLBase = PrivateGetURLBase(_
Format1("w3svc/%1/ServerBindings", Instance), _
"HTTP://", _
Server, HostName)
End If
If GetURLBase = "" Then
IsSecure = NOT IsSecure
Else
Try = 1
End If
Next
RaiseOnError Format1(Wizard("GetURLBaseFailed"), Instance)
End Function
'=============================================================================
' GetWebSiteProperties
'
Function GetWebSiteProperties(ByVal Instance, ByVal Server)
if g_ErrorHandler then on error resume next
Dim WebServer
Set WebServer = CreateRemoteObj("Commerce.AdminWebServer", Server)
Set GetWebSiteProperties = WebServer.GetWebSiteProperties(Instance)
RaiseOnError Format1(Wizard("GetWebSitePropertiesFailed"), Instance)
End Function
'=============================================================================
' IsMembership
'
Function IsMembership(ByVal Instance, ByVal Server)
if g_ErrorHandler then on error resume next
Dim AdminWebProp
Set AdminWebProp = GetWebSiteProperties(Instance, Server)
IsMembership = CBool(AdminWebProp.Membership)
End Function
'=============================================================================
' GetSecurity
'
Function GetSecurity(ByVal WebSiteProp)
if g_ErrorHandler then on error resume next
If WebSiteProp.Membership Then
GetSecurity = Wizard("SecurityMembership")
Else
GetSecurity = Wizard("SecurityNT")
End If
End Function
'#############################################################################
'# Account Information & Security
'#############################################################################
'=============================================================================
' CheckNTUser
'
Sub CheckNTUser( ByVal Domain, ByVal UserName )
if g_ErrorHandler then on error resume next
DisplayActionStart "CHECKING NT USER ACCOUNT"
TraceParameters Array("Domain", "UserName"), Array(Domain, UserName)
Dim AdminLanMan
Set AdminLanMan = CreateObject("Commerce.AdminLanManager")
AdminLanMan.Server = Domain
AdminLanMan.User = UserName
if Err.number = 0 then
if AdminLanMan.UserExists = false then
RaiseError Format2(Wizard("CheckNTUser_NotFound"),UserName,Domain)
end if
else
RaiseOnError Wizard("CheckNTUser_Failed")
end if
DisplayActionFinish "CHECKING NT USER ACCOUNT"
End Sub
'=============================================================================
' CheckMemUser
'
Sub CheckMemUser( ByVal WebSiteID, ByVal UserName, ByVal Password )
if g_ErrorHandler then on error resume next
DisplayActionStart "CHECKING MEMBERSHIP USER ACCOUNT"
TraceParameters Array("WebSiteID", "UserName", "Password"), Array(WebSiteID, UserName, Password)
if not IsMembership(WebSiteID, "") then
RaiseError Format1(Wizard("CheckMemUser_NoMemServer"),WebSiteID)
else
SetDSAccountInfo WebSiteID, UserName, Password
DSAuthenticate ""
end if
DisplayActionFinish "CHECKING MEMBERSHIP USER ACCOUNT"
End Sub
'=============================================================================
' GetSiteGroup
'
Function GetSiteGroup(ByVal Instance, ByVal SiteName, ByVal Server)
Dim Prefix
If IsMembership(Instance, Server) Then
Prefix = GetDSPrefix(Instance, Server)
Else
Prefix = "Commerce_"
End If
GetSiteGroup = Format3("%1%2_%3", Prefix, SiteName, Instance)
End Function
'=============================================================================
' GetManagerGroup
'
Function GetManagerGroup(ByVal Server)
if g_ErrorHandler then on error resume next
Dim Reg
Set Reg = CreateRemoteObj("Commerce.AdminRegistry", Server)
GetManagerGroup = Reg.GetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Site Server\3.0\Accounts\CommerceOperatorGroup")
RaiseOnError Wizard("GetManagerGroupFailed")
End Function
'=============================================================================
' GetAdministratorsGroup
'
Function GetAdministratorsGroup(ByVal Server)
if g_ErrorHandler then on error resume next
Dim Reg
Set Reg = CreateRemoteObj("Commerce.AdminRegistry", Server)
GetAdministratorsGroup = Reg.GetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Site Server\3.0\Accounts\NTAdminGroup")
if Err.Number <> 0 then
ClearError
GetAdministratorsGroup = Wizard("GetAdministratorsGroupDefault")
end if
End Function
'=============================================================================
' GetSiteServerAdministratorsGroup
'
Function GetSiteServerAdministratorsGroup(ByVal Server)
if g_ErrorHandler then on error resume next
Dim Reg
Set Reg = CreateRemoteObj("Commerce.AdminRegistry", Server)
GetSiteServerAdministratorsGroup = Reg.GetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\Site Server\3.0\Accounts\SiteServerAdminGroup")
if Err.Number <> 0 then
ClearError
GetSiteServerAdministratorsGroup = Wizard("GetSiteServerAdministratorsGroupDefault")
end if
End Function
'=============================================================================
' CreateNTManagerGroup
'
Sub CreateNTManagerGroup(ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
Dim LanManager, Group
Set LanManager = CreateRemoteObj("Commerce.AdminLanManager", Server)
if Not IsABDC(Server) then
Group = GetSiteGroup(Instance, SiteName, Server)
LanManager.CreateGroup Group, True, _
Wizard("CommerceSiteGroup")
RaiseOnError Format1(Wizard("CreateGroup"), Group)
end if
Group = GetManagerGroup(Server)
LanManager.CreateGroup Group, True, _
Wizard("CommerceSiteManagersGroup")
RaiseOnError Format1(Wizard("CreateGroup"), Group)
End Sub
'=============================================================================
' DeleteManagerGroup
'
Sub DeleteManagerGroup(ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
If Not IsMembership(Instance, Server) Then
Dim Users, nUser
Users = GetManagers(Instance, SiteName, Server)
For nUser = LBound(Users) To UBound(Users)
DelManager Users(nUser), Instance, SiteName, Server
Next
End If
ClearError
if Not IsABDC(Server) then
Dim LanManager, Group
Set LanManager = CreateRemoteObj("Commerce.AdminLanManager", Server)
Group = GetSiteGroup(Instance, SiteName, Server)
LanManager.DeleteGroup Group, True
RaiseOnError Format1(Wizard("DeleteGroup"), Group)
end if
End Sub
'=============================================================================
' AddManager
'
Sub AddManager(ByVal User, ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
If IsMembership(Instance, Server) Then
RaiseError Wizard("AddManagerFailedOnMembership")
Exit Sub
End If
Dim LanManager, Group
Set LanManager = CreateRemoteObj("Commerce.AdminLanManager", Server)
LanManager.User = User
Group = GetSiteGroup(Instance, SiteName, Server)
LanManager.AddUserToGroup Group, True
if Err.Number <> 0 then
if IsABDC(Server) then
if Err.Number = &h806708AC then
Err.Clear
g_BDCErrorFlag = True
end if
end if
end if
RaiseOnError Format1(Wizard("AddAcct"), Group)
Group = GetManagerGroup(Server)
LanManager.AddUserToGroup Group, True
RaiseOnError Format1(Wizard("AddAcct"), Group)
End Sub
'=============================================================================
' DelManager
'
Sub DelManager(ByVal User, ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
If IsMembership(Instance, Server) Then
RaiseError Wizard("DelManagerFailedOnMembership")
Exit Sub
End If
Dim LanManager, Groups, Group
Set LanManager = CreateRemoteObj("Commerce.AdminLanManager", Server)
LanManager.User = User
Group = GetSiteGroup(Instance, SiteName, Server)
LanManager.DeleteUserFromGroup Group, True
if Err.Number <> 0 then
if IsABDC(Server) then
if Err.Number = &h806708AC then
Err.Clear
g_BDCErrorFlag = True
end if
end if
end if
RaiseOnError Format1(Wizard("DelAcct"), Group)
Groups = "|" & Join(LanManager.GetGroupsForUser(True), "|")
If InStr(1, Groups, "|Commerce_", vbTextCompare) = 0 Then
Group = GetManagerGroup(Server)
LanManager.DeleteUserFromGroup Group, True
RaiseOnError Format1(Wizard("DelAcct"), Group)
End If
End Sub
'=============================================================================
' GetManagers
'
Function GetManagers(ByVal Instance, ByVal SiteName, ByVal Server)
if g_ErrorHandler then on error resume next
Dim LanManager, Group
Set LanManager = CreateRemoteObj("Commerce.AdminLanManager", Server)
Group = GetSiteGroup(Instance, SiteName, Server)
GetManagers = LanManager.GetUsersInGroup(Group, True)
if Err.Number <> 0 then
if IsABDC(Server) then
if Err.Number = &h806708AC then
Err.Clear
g_BDCErrorFlag = True
GetManagers = ""
end if
end if
end if
RaiseOnError Format1(Wizard("GetManagersFailed"), Group)
End Function
'=============================================================================
' CreateAccount
'
Sub CreateAccount(ByVal Server, ByVal Account, ByVal Password, _
ByVal FullName, ByVal Description)
if g_ErrorHandler then on error resume next
Dim LanManager
Set LanManager = CreateRemoteObj("Commerce.AdminLanManager", Server)
LanManager.Server = Server
LanManager.User = Account
LanManager.CreateUser Password, FullName, Description
RaiseOnError Wizard("CreateAcct")
End Sub
'=============================================================================
' SecureTheSite
'
Sub SecureTheSite(ByVal Instance, ByVal SiteName, ByVal Dir, ByVal Server, ByVal AclFile1, ByVal AclFile2)
if g_ErrorHandler then on error resume next
Dim Security
Set Security = CreateRemoteObj("Commerce.AdminSecurity", Server)
Dim AdminGroup
AdminGroup = GetAdministratorsGroup(Server)
Dim SiteServerAdminGroup
SiteServerAdminGroup = GetSiteServerAdministratorsGroup(Server)
Security.AddPermission AdminGroup, &h001F01FF ' Full control
Security.AddPermission SiteServerAdminGroup, &h001F01FF ' Full control
' Temporary change:
'Security.AddPermission Wizard("SecureSiteEveryone"), &h00120089 ' Read
Security.AddPermission Wizard("SecureSiteEveryone"), &h001F01FF ' Full control
if Not IsABDC(Server) then
Security.AddPermission GetSiteGroup(Instance, SiteName, Server), &h001F01FF
end if
Security.WriteSecurityDirectory Dir, True
'' First process the wildcards in AclFile1, while the Security object still has permissions
'' for group Everyone. The purpose of this is to remove restrictive permissions on the wildcard
'' folders, which may have been applied by a previous installation (this is, in fact, a bug fix)
'Dim bOK
'bOK = false
'ProcessAclFile Dir, Security, AclFile1, bOK, true
' Now take away permissions for groups Everyone and EE11, for the folders in AclFile1 (see below)
if Not IsABDC(Server) then
Security.DelPermission GetSiteGroup(Instance, SiteName, Server)
end if
Security.DelPermission Wizard("SecureSiteEveryone")
' Try to process directory permissions in the ACL file nr. 1 (Admin permissions)
' The directories specified in this file will get the restricted permissions
' (only SiteServer Administrators has access)
Dim bOK
bOK = false
ProcessAclFile Dir, Security, AclFile1, bOK
' If unable to proces ACL file, we set permissions only on the Manager folder
' (mimick standard SiteServer behaviour)
if not bOK then
Security.WriteSecurityDirectory Dir + "\Manager", True
end if
' Add permissions for the groups Everyone and EE11 again, for the folders in AclFile2 (see below)
if Not IsABDC(Server) then
Security.AddPermission GetSiteGroup(Instance, SiteName, Server), &h001F01FF
end if
Security.AddPermission Wizard("SecureSiteEveryone"), &h001F01FF
' Try to process directory permissions in the ACL file nr. 1 (Public permissions)
' The directories specified in this file will get the public permissions
' (Everyone and EE11 have access)
bOK = false
ProcessAclFile Dir, Security, AclFile2, bOK
Security.Owner = AdminGroup
Security.Group = AdminGroup
Security.AddPermission Wizard("SecureSiteEveryone"), &h09
Security.WriteSecurityMetabase Format2("W3SVC/%1/ROOT/%2", Instance, SiteName), True
End Sub
'=============================================================================
' ProcessAclFile
'
Sub ProcessAclFile( ByVal Root, ByVal Security, ByVal AclFile, ByRef bOK )
if g_ErrorHandler then on error resume next
bOK = false
if not Defined(AclFile) then
Trace "No ACL file supplied"
exit sub
end if
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
if not Fso.FileExists(AclFile) then
RaiseError Format1(Wizard("ProcAcl_FileNotFound"),AclFile)
exit sub
end if
Dim File
Set File = Fso.OpenTextFile( AclFile, 1 )
if not IsErrorClear() then
RaiseOnError Format1(Wizard("ProcAcl_CannotOpen"),AclFile)
exit sub
end if
WriteProgressMsg "Setting permissions ..."
Dim Line
' read the lines from the ACL file
do while not File.AtEndOfStream
Line = File.ReadLine()
if Trim(Line) <> "" then
ProcessAclLine Fso, Security, Root & "\" & Line
end if
loop
File.Close
bOK = true
''RaiseOnError Format1(Wizard("MemAuth_CfgFile"),CfgFile)
End Sub
'=============================================================================
' ProcessAclLine
'
Sub ProcessAclLine( ByVal Fso, ByVal Security, ByVal Path )
if g_ErrorHandler then on error resume next
' Handle special case: wildcard "*.*" supplied
Dim bIsWildCard
if Right(Path,4) = "\*.*" then
bIsWildCard = true
else
bIsWildCard = false
end if
' special Wildcard processing
if bIsWildCard then
Trace "ACL path " & Path & ": wildcard supplied"
Path = Left(Path,Len(Path)-4)
if not Fso.FolderExists(Path) then
Trace "WARNING: ACL path " & Path & " does not exist as a folder"
else
Dim Folder
Set Folder = Fso.GetFolder(Path)
' Set security on the files in the folder
Dim File
for each File in Folder.Files
Security.WriteSecurityFile File.Path
TraceOnError Format1(Wizard("ProcAcl_SetPermission"),File.Path)
next
' Set security on the subfolders in the folder
Dim Subfolder
for each Subfolder in Folder.Subfolders
Security.WriteSecurityDirectory Subfolder.Path, True
TraceOnError Format1(Wizard("ProcAcl_SetPermission"),Subfolder.Path)
next
end if
' regular file or folder processing
elseif Fso.FolderExists(Path) then
Trace "ACL path " & Path & ": appears to be a folder"
Security.WriteSecurityDirectory Path, True
TraceOnError Format1(Wizard("ProcAcl_SetPermission"),Path)
elseif Fso.FileExists(Path) then
Trace "ACL path " & Path & ": appears to be a file"
Security.WriteSecurityFile Path
TraceOnError Format1(Wizard("ProcAcl_SetPermission"),Path)
else
Trace "WARNING: ACL path " & Path & ": not a file or folder"
end if
End Sub
const UAS_ROLE_BACKUP = 2
'=============================================================================
' IsABDC
'
Function IsABDC(ByVal Server)
if g_ErrorHandler then on error resume next
Dim LM
Set LM = CreateObj("Commerce.AdminLANManager")
LM.Server = LM.GetCurrentComputer
If LM.GetServerType = UAS_ROLE_BACKUP then
IsABDC = True
else
IsABDC = False
end if
End Function
'=============================================================================
' SetFPSecurity
'
Sub SetFPSecurity(ByVal Instance, ByVal SiteName, ByVal Dir, ByVal Server)
if g_ErrorHandler then on error resume next
if IsABDC(Server) then Exit Sub ' we can't get managers from a BDC so exit
Dim Prop
set Prop = GetWebsiteProperties(Instance, Server)
if Not Prop.FrontPage then Exit Sub
if Not (LCase(Prop.VrPath + "\" + SiteName) = LCase(Dir)) then Exit Sub
Dim Reg
set Reg = CreateRemoteObj("Commerce.AdminRegistry", Server)
Dim strFPRoot
strFPRoot = Reg.GetValue("HKEY_LOCAL_MACHINE\Software\Microsoft\FrontPage\3.0\FrontPageRoot")
Dim AdminFile
set AdminFile = CreateRemoteObj("Commerce.AdminFiles", Server)
Dim strCmdLine
strCmdLine = """" & strFPRoot & "\Version3.0\bin\fpsrvadm.exe"" -unattended TRUE " & _
"-o install -t msiis -m /lm/w3svc/" & Instance & " -web ""/" & SiteName & _
""" -u """ & CreateObj("Commerce.AdminLanManager").GetCurrentUser & """"
AdminFile.ExecuteProgramNoUI strCmdLine, -1, False
strCmdLine = """" & strFPRoot & "\Version3.0\bin\fpsrvadm.exe"" -unattended TRUE " & _
"-o security -a authors -m /lm/w3svc/" & Instance & " -web ""/" & SiteName & _
""" -u """ & GetSiteGroup(Instance, SiteName, Server) & """"
AdminFile.ExecuteProgramNoUI strCmdLine, -1, False
strCmdLine = """" & strFPRoot & "\Version3.0\bin\fpsrvadm.exe"" -unattended TRUE " & _
"-o security -a authors -m /lm/w3svc/" & Instance & " -web ""/" & SiteName & _
""" -u """ & GetSiteServerAdministratorsGroup(Server) & """"
AdminFile.ExecuteProgramNoUI strCmdLine, -1, False
End Sub
'#############################################################################
'# Template Generation
'#############################################################################
'=============================================================================
' ReplacePiece
'
Function ReplacePiece(ByVal FileName, ByVal Ext, ByVal NewExt)
If LCase(Right(FileName, Len(Ext))) = LCase(Ext) Then
ReplacePiece = Left(FileName, Len(FileName)-Len(Ext)) + NewExt
Else
ReplacePiece = FileName
End If
End Function
'=============================================================================
' RecursePageGen
'
Sub RecursePageGen(ByVal DstDir, ByVal SrcDir, ByRef Dict, ByVal Server)
Dim AdminFiles, AdminFilesDst
Set AdminFiles = CreateObj("Commerce.AdminFiles")
Set AdminFilesDst = CreateRemoteObj("Commerce.AdminFiles", Server)
'-------------------------------------------------------------------------
' Scan for Subdirectories first
Dim SubDirs, nDir
SubDirs = AdminFiles.GetDirectories(SrcDir + "\*")
For nDir = LBound(SubDirs) To UBound(SubDirs)
RecursePageGen DstDir + "\" + SubDirs(nDir), _
SrcDir + "\" + SubDirs(nDir), _
Dict, Server
Next
'-------------------------------------------------------------------------
' Scan for Files
AdminFilesDst.CreateDirectory DstDir
Dim Files, nFile, SrcFile, DstFile
Files = AdminFiles.GetFiles(SrcDir + "\*")
For nFile = LBound(Files) To UBound(Files)
SrcFile = Files(nFile)
DstFile = SrcFile
DstFile = ReplacePiece(DstFile, ".htmT" , ".html" )
DstFile = ReplacePiece(DstFile, ".htT" , ".htm" )
DstFile = ReplacePiece(DstFile, ".sqT" , ".sql" )
DstFile = ReplacePiece(DstFile, "global.asT" , "global.asa" )
DstFile = ReplacePiece(DstFile, "global_opened.asT", "global_opened.asa")
DstFile = ReplacePiece(DstFile, "global_closed.asT", "global_closed.asa")
DstFile = ReplacePiece(DstFile, ".asT" , ".asp" )
DstFile = ReplacePiece(DstFile, ".vbT" , ".vbs" )
DstFile = ReplacePiece(DstFile, ".txT" , ".txt" )
Dim Output, SrcDirFile, DstDirFile
SrcDirFile = SrcDir + "\" + SrcFile
DstDirFile = DstDir + "\" + DstFile
If DstFile = SrcFile Then ' Just copy the file
If Len(Server) > 0 Then
Output = AdminFiles.ReadFromBinaryFile(SrcDirFile)
AdminFilesDst.WriteToBinaryFile DstDirFile, Output
Else
AdminFiles.CopyFile SrcDirFile, DstDirFile, False
End If
Else
Dim PageGen
Set PageGen = CreateObj("Commerce.PageGen")
Output = PageGen.GenPageText(SrcDirFile, True, "Item", _
Dict, "VBScript")
AdminFilesDst.WriteToFile DstDirFile, Output
End If
Next
End Sub
'#############################################################################
'# Database Routines
'#############################################################################
'========================================================================
' CreateSystemDsn
'
Sub CreateSystemDsn( ByVal ConnStr )
Const DRIVERNAME = "SQL Server"
' parse the connection string
Dim Dsn, Driver, Description, Server, Database, User, Password
' Known parts of DSN connection string: DSN,UID,PWD,Driver,Database,Description
Dsn = GetSubPart(ConnStr,"DSN")
Description = GetSubPart(ConnStr,"Description")
Server = GetSubPart(ConnStr,"Server")
if Server = "" then
Server = "(local)"
end if
Database = GetSubPart(ConnStr,"Database")
User = GetSubPart(ConnStr,"UID")
Password = GetSubPart(ConnStr,"PWD")
Dim Reg
''Set Reg = CreateObj("Commerce.AdminRegistry")
Set Reg = GetWshShell()
' Get the DLL for the driver
' [HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBCINST.INI\SQL Server]
' "Driver"="C:\\WINNT40\\System32\\SQLSRV32.dll"
''Driver = _
'' Reg.GetValue( "HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBCINST.INI\" & DRIVERNAME & "\Driver" )
Driver = Reg.RegRead( "HKLM\SOFTWARE\ODBC\ODBCINST.INI\" & DRIVERNAME & "\Driver" )
' Add the datasource
' [HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources]
' "UAA"="SQL Server"
''Reg.SetValue "HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources\" & Dsn, _
'' DRIVERNAME
Reg.RegWrite "HKLM\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources\" & Dsn, _
DRIVERNAME
' Set DSN properties
' [HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\UAA]
' "Driver"="C:\\WINNT40\\System32\\SQLSRV32.dll"
' "Description"="UAA"
' "Server"="SRV-NLD-W3APPS1"
' "Database"="UAA"
Dim Key
Key = "HKLM\SOFTWARE\ODBC\ODBC.INI\" & Dsn '"HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\" & Dsn
Reg.RegWrite Key & "\Driver", Driver
Reg.RegWrite Key & "\Description", Description
Reg.RegWrite Key & "\Server", Server
Reg.RegWrite Key & "\Database", Database
Reg.RegWrite Key & "\UID", User
Reg.RegWrite Key & "\PWD", Password
End Sub
'========================================================================
' DestroySystemDsn
'
Sub DestroySystemDsn( ByVal Dsn )
Dim Reg
''Set Reg = CreateObj("Commerce.AdminRegistry")
Set Reg = GetWshShell()
' Delete the datasource
' [HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources]
' "UAA"="SQL Server"
''Reg.DeleteValue "HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources\" & Dsn
Reg.RegDelete "HKLM\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources\" & Dsn
' [HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\UAA]
' "Driver"="C:\\WINNT40\\System32\\SQLSRV32.dll"
' "Description"="UAA"
' "Server"="SRV-NLD-W3APPS1"
' "Database"="UAA"
Dim Key
Key = "HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\" & Dsn & "\"
''Reg.DeleteKey Key
Reg.RegDelete Key
End Sub
'========================================================================
' GetDsns
'
Function GetDsns( ByVal Server, ByVal bCheckConnectionString )
Dim Dsns
Set Dsns = CreateObj("Scripting.Dictionary")
Dim List
Set List = GetValuesFromSwitch( Switches("dsn") )
Dim ConnName, ConnStr
for each ConnStr in List
ConnName = GetSubPart(ConnStr,"DSN")
if ConnName = "" then
RaiseError Format1(Wizard("DSN_NoDsn"),ConnStr)
end if
if bCheckConnectionString then
if GetSubPart(ConnStr,"Server") = "" then
RaiseError Format1(Wizard("DSN_NoServer"),ConnStr)
end if
if GetSubPart(ConnStr,"Database") = "" then
RaiseError Format1(Wizard("DSN_NoDatabase"),ConnStr)
end if
if GetSubPart(ConnStr,"UID") = "" then
RaiseError Format1(Wizard("DSN_NoUser"),ConnStr)
end if
end if
' DSN is OK
Dsns(ConnName) = ConnStr
next
Set GetDsns = Dsns
End Function
'=============================================================================
' GetConnectionAttributes
'
Function GetConnectionAttributes(ByVal Connection)
if g_ErrorHandler then on error resume next
Dim Attr
Dim KnownAttr
''KnownAttr = "DSN,UID,PWD,Driver,Database"
KnownAttr = "DSN,UID,PWD,Driver,Database,Description"
GetConnectionAttributes = ""
For Each Attr In PrivateSplit(Connection, ";")
If Len(Attr) <> 0 Then
If Not IsMember(Split(Attr,"=")(0), KnownAttr) Then
GetConnectionAttributes = GetConnectionAttributes+";"+Attr
End If
End If
Next
GetConnectionAttributes = Mid(GetConnectionAttributes, 2)
End Function
'=============================================================================
' GetSubPart(ODBC Connection string, and part of connection needed)
'
Function GetSubPart(ByVal Connection, ByVal Part)
If Right(Part,1) <> "=" Then
Part = Part + "="
End If
Dim I
I = InStr(1, LCase(Connection), Part, vbTextCompare)
If I <> 0 Then
Connection = Mid(Connection, I+Len(Part))
Connection = Split(Connection, ";")(0)
GetSubPart = Connection
Else
GetSubPart = ""
End If
End Function
'=============================================================================
' GetDBFiles
'
Function GetDBFiles(ByVal Connection, ByVal SiteDir, ByVal Install, _
ByVal Server)
if g_ErrorHandler then on error resume next
Dim AdminDB, DBDir
Set AdminDB = CreateRemoteObj("Commerce.AdminDB", Server)
DBDir = Format2("%1\Config\SQL\%2\", SiteDir, AdminDB.DBType(Connection))
Dim AdminFiles, Files, nFile, Sorted
Set AdminFiles = CreateRemoteObj("Commerce.AdminFiles", Server)
Files = AdminFiles.GetFiles(DBDir + "*.SQL")
'--- For install, put schema files ahead in the list.
'--- For uninstall, filter out anything other than uninstall.
For nFile = LBound(Files) To UBound(Files)
If Install Then
If Instr(LCase(Files(nFile)), "schema") > 0 Then
Sorted = "|" + DBDir+Files(nFile) + Sorted
ElseIf Instr(LCase(Files(nFile)), "uninstall") = 0 Then
Sorted = Sorted + "|" + DBDir+Files(nFile)
End If
Else
If Instr(LCase(Files(nFile)), "uninstall") > 0 Then
Sorted = Sorted + "|" + DBDir+Files(nFile)
End If
End If
Next
GetDBFiles = Split(Mid(Sorted,2), "|")
'Err.Clear
End Function
'=============================================================================
' ValidateConnection
'
Function ValidateConnection(ByVal Connection, ByVal Server)
if g_ErrorHandler then on error resume next
Dim AdminDB
Set AdminDB = CreateRemoteObj("Commerce.AdminDB", Server)
ValidateConnection = AdminDB.SelectConnect(Connection)
RaiseOnError Wizard("ValidateConnectionFailed")
End Function
'=============================================================================
' Execute DB Scripts
'
Sub ExecuteDBScripts(ByVal Conn, ByVal DstDir, ByVal Install, ByVal Server)
if g_ErrorHandler then on error resume next
Dim AdminDB, Scripts, nScript
Set AdminDB = CreateRemoteObj("Commerce.AdminDB", Server)
Scripts = GetDBFiles(Conn, DstDir, Install, Server)
For nScript = LBound(Scripts) To UBound(Scripts)
AdminDB.ExecuteScript Conn, Scripts(nScript)
if Err.Number <> 0 then exit for
Next
RaiseOnError Wizard("ExecuteScript")
End Sub
'=============================================================================
' Old directory functions
'
Function GetSQLDir(ByVal Version)
If Version = 3 Then
GetSQLDir = "\config\SQL\"
Else
GetSQLDir = "\..\SQL\"
End If
End Function
Function GetDelDir(ByVal Version, ByVal Dir)
GetDelDir = Dir
If Version <> 3 AND LCase(Right(Dir, 5)) = "\shop" Then
GetDelDir = Left(Dir, Len(Dir)-5)
End If
End Function
'=============================================================================
' CreateDatabases
'
Sub CreateDatabases( ByVal DBServer, ByVal DBUser, ByVal DBPassword, ByVal DatabaseStrings )
If g_ErrorHandler Then On Error Resume Next
if IsVoid(DBPassword) then DBPassword = ""
DisplayActionStart "CREATE DATABASES"
TraceParameters Array("DBServer", "DBUser", "DBPassword", "DatabaseStrings"), _
Array(DBServer, DBUser, DBPassword, DatabaseStrings)
Dim Sqls
Set Sqls = CreateObj("SQLDMO.SQLServer")
Sqls.Connect DBServer, DBUser, DBPassword
' catch error
RaiseOnError Wizard("CreateDB_LoginFailed")
if not IsErrorClear() then
exit sub
end if
Dim DBName, DBString, Database, Databases, User, Users, Login, UID, PWD, Role, Size
Set Databases = Sqls.Databases
for each DBName in DatabaseStrings
DBString = DatabaseStrings(DBName)
' parse DBString
UID = GetSubPart(DBString,"UID")
PWD = GetSubPart(DBString,"PWD")
Size = StrToNumber(GetSubPart(DBString,"Size"))
Role = GetSubPart(DBString,"Role")
if Role = "" then
Role = "public"
else
Role = LCase(Role)
end if
WriteProgressMsg "Configuring Database " & DBName
Trace "Conn. string: " & DBString
' === create database
Set Database = CreateObj("SQLDMO.Database")
Database.Name = DBName
' create the database in SQL Server
Databases.Add Database
if Err.number = &H0709 then
TraceOnError "Database " & DBName & " already exists"
else
if not RaiseOnError(Format1(Wizard("CreateDB_CreateDBFailed"), DBName)) then
if Size > 0 then
' Specify Size-1, because setting the size property actually means increasing
' the size form its initial size (which is 1 Mb)
Database.FileGroups("PRIMARY").DBFiles(1).Size = Size-1
RaiseOnError Format2(Wizard("CreateDB_SetSizeFailed"), _
DBName, CStr(Size))
end if
end if
end if
' === create login, if necessary
Trace "Creating login " & UID
Set Login = CreateObj("SQLDMO.Login")
Login.Name = UID
Sqls.Logins.Add Login
if Err.number = &H05210 then
TraceOnError "Login " & UID & " already exists"
else
RaiseOnError Format1(Wizard("CreateDB_CreateLoginFailed"), UID)
end if
Trace "Setting default database for login"
' Get the new or existing login and set the default database on it
Set Login = Sqls.Logins(UID)
TraceOnError "Cannot get login " & UID
' set default database
Login.Database = DBName
TraceOnError "Cannot set default database on login " & UID
' === create user, which links the login to the database, and assign "dbo or ""public" permit
Trace "Creating user " & UID
Set User = CreateObj("SQLDMO.User")
User.Login = UID
if Role <> "public" then
User.Role = Role ' "public" or "db_owner"
end if
Set Database = Databases(DBName)
Set Users = Database.Users
' Remove old user in case it exists
Users.Remove UID
TraceOnError "Error while removing old user " & UID
' Add new user
Users.Add User
if Err.number = &H0520A then
TraceOnError "User " & UID & " already exists"
else
RaiseOnError Format1(Wizard("CreateDB_CreateUserFailed"), UID)
end if
' If a database fails, preceed with next database. The command as a whole will fail,
' but part of it will be executed.
''if not IsErrorClear() then
'' exit sub
''end if
next
DisplayActionFinish "CREATE DATABASES"
End Sub
'=============================================================================
' DeleteDatabases
'
Sub DeleteDatabases( ByVal DBServer, ByVal DBUser, ByVal DBPassword, ByVal DatabaseStrings )
If g_ErrorHandler Then On Error Resume Next
if IsVoid(DBPassword) then DBPassword = ""
DisplayActionStart "DELETE DATABASES"
TraceParameters Array("DBServer", "DBUser", "DBPassword", "DatabaseStrings"), _
Array(DBServer, DBUser, DBPassword, DatabaseStrings)
Dim Sqls
Set Sqls = CreateObj("SQLDMO.SQLServer")
Sqls.Connect DBServer, DBUser, DBPassword
' catch error
RaiseOnError Wizard("CreateDB_LoginFailed")
if not IsErrorClear() then
exit sub
end if
Dim DBName, DBString, Database, Databases, Login, UID
Set Databases = Sqls.Databases
for each DBName in DatabaseStrings
DBString = DatabaseStrings(DBName)
' parse DBString
UID = GetSubPart(DBString,"UID")
WriteProgressMsg "Deleting Database " & DBName
Trace "Conn. string: " & DBString
' === delete database
Set Database = Sqls.Databases(DBName)
if Database is nothing then
Trace "Warning: database " & DBName & " does not exist"
Err.Clear
else
Database.Remove
RaiseOnError Format1(Wizard("DeleteDB_DeleteDBFailed"), DBName)
end if
' === delete login, if necessary
if UID <> "" then
Trace "Deleting login " & UID
Sqls.Logins.Remove UID
if Err.number = &H05510 then
TraceOnError "Login " & UID & " does not exist"
else
TraceOnError "Warning: could not remove login " & UID
end if
end if
if not IsErrorClear() then
exit sub
end if
next
DisplayActionFinish "DELETE DATABASES"
End Sub
'=============================================================================
' ExecSqlCommand - execute SQL command via SQL DMO objects
'
Sub ExecSqlCommand( ByVal DBServer, ByVal DBName, ByVal DBUser, ByVal DBPassword, ByVal SqlCommand )
If g_ErrorHandler Then On Error Resume Next
if IsVoid(DBPassword) then DBPassword = ""
DisplayActionStart "EXEC SQL COMMAND"
TraceParameters Array("DBServer", "DBName", "DBUser", "DBPassword", "SqlCommand"), _
Array(DBServer, DBName, DBUser, DBPassword, SqlCommand)
Dim Sqls
Set Sqls = CreateObj("SQLDMO.SQLServer")
Sqls.Connect DBServer, DBUser, DBPassword
' catch error
RaiseOnError Wizard("ExecSQLCommand_LoginFailed")
if not IsErrorClear() then
exit sub
end if
Dim Databases, Database
Set Databases = Sqls.Databases
Set Database = Databases(DBName)
RaiseOnError Format1(Wizard("ExecSQLCommand_GetDBFailed"),DBName)
if not IsErrorClear() then
exit sub
end if
Dim Messages
Database.ExecuteWithResultsAndMessages SqlCommand, Messages, 0
''Trace "Results: " & Messages
RaiseOnError Format2(Wizard("ExecSQLCommand_ExecFailed"),SqlCommand,DBName)
DisplayActionFinish "EXEC SQL COMMAND"
End Sub
'=============================================================================
' ExecSqlCommand2 - execute SQL command via ADO
'
Sub ExecSqlCommand2( ByVal ConnString, ByVal SqlCommand )
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "EXEC SQL COMMAND (2)"
TraceParameters Array("ConnString", "SqlCommand"), _
Array(ConnString, SqlCommand)
Dim Conn
Set Conn = CreateObj("ADODB.Connection")
Conn.Open ConnString
' Check error
RaiseOnError Wizard("ExecSQLCommand_LoginFailed")
if not IsErrorClear() then
exit sub
end if
Dim Count
Conn.Execute SqlCommand, Count
RaiseOnError Format2(Wizard("ExecSQLCommand_ExecFailed"),SqlCommand,ConnString)
Trace "Result count is: " & CStr(Count)
Conn.Close
Err.Clear
DisplayActionFinish "EXEC SQL COMMAND (2)"
End Sub
'========================================================================
' CheckQueryFieldHasString
'
Sub CheckQueryFieldHasString( ByVal ConnString, ByVal Query, ByVal FieldName )
if g_ErrorHandler then on error resume next
Dim bOK
bOK = false
DisplayActionStart "CHECKING FIELD IN QUERY RESULTSET"
TraceParameters Array("ConnString", "Query", "FieldName"), Array(ConnString, Query, FieldName)
Dim Conn
Set Conn = CreateObj("ADODB.Connection")
Conn.Open ConnString
' Check error
RaiseOnError Wizard("ExecQuery_LoginFailed")
if IsErrorClear() then
Dim Count, RecordSet
Set RecordSet = Conn.Execute( Query, Count )
RaiseOnError Format2(Wizard("ExecQuery_ExecFailed"),Query,ConnString)
if IsErrorClear() then
' Fetch first row out of recordset
if RecordSet.EOF then
Trace "Resultset is empty"
else
Dim Value
Value = RecordSet(FieldName)
RaiseOnError Format1(Wizard("ExecQuery_FieldGetFailed"),FieldName)
if IsErrorClear() then
' Check data type
if VarType(Value) = 8 then ' string
if Trim(Value) = "" then
Trace "Value is empty string"
else
' OK: non-empty string
Trace "Value is *" & Value & "*"
' Return field value to the caller using "WriteResultMessage"
' (which is normally only used for error messages)
WriteResultMessage Value
bOK = true
end if
else
Trace "Value is not a string (type is " & CStr(VarType(Value)) & ")"
end if
end if
end if
end if
Conn.Close
end if
Err.Clear
DisplayActionFinish "CHECKING FIELD IN QUERY RESULTSET"
' return process exist code: 0 = OK, 1 = not OK
if bOK then
Trace "Field has non-empty string value"
if IsRunningInWSH() then
WScript.Quit 0
end if
else
Trace "Field empty or error occurred"
if IsRunningInWSH() then
WScript.Quit 1
end if
end if
End Sub
'#############################################################################
'# Error Handling Routines
'#############################################################################
Public GlobalError
Public GlobalErrNum
Public GlobalWarning
Public g_ErrorHandler
Public g_BDCErroFlag
'=============================================================================
' SetErrorHandler
'
Sub SetErrorHandler(ByVal bErrorHandler)
g_ErrorHandler = bErrorHandler
End Sub
'=============================================================================
' RaiseError
'
Sub RaiseError(ByVal strDesc)
if g_ErrorHandler then on error resume next
If GlobalError = "" Then
GlobalError = strDesc
Err.Raise &H80040005, Wizard("RaiseErrorCommerce"), ""
RaiseOnError strDesc
End If
End Sub
'=============================================================================
' RaiseOnError
'
Function RaiseOnError(ByVal strDesc)
RaiseOnError = RaiseOnError2(strDesc,true)
End Function
'=============================================================================
' RaiseOnError2
'
Function RaiseOnError2(ByVal strDesc, ByVal bTrace)
Dim bError
bError = false
If Err.Number <> 0 Then
If Len(GlobalError) = 0 Then
bError = true
GlobalErrNum = Err.Number
if strDesc = "" then
GlobalError = _
Wizard("RaiseOnErrorError") + Hex(Err.Number) + vbCrLf + _
Err.Description
else
GlobalError = _
strDesc + vbCrLf + vbCrLf +_
Wizard("RaiseOnErrorDetails") + vbCrLf + _
Wizard("RaiseOnErrorError") + Hex(Err.Number) + vbCrLf + _
Err.Description
end if
End If
' Print error immediately
if bTrace then
OutputDebugString strDesc
OutputDebugString "ErrNo = " & CStr(Err.Number) & _
" (Hex " & Hex(Err.Number) & ") Desc = " & Err.Description
end if
End If
RaiseOnError2 = bError
End Function
'=============================================================================
' ReportError
'
Sub ReportError( ByVal strDesc, ByVal bRaiseOnError )
if bRaiseOnError then
RaiseOnError strDesc
else
TraceOnError strDesc
end if
End Sub
'=============================================================================
' IsErrorClear
'
Function IsErrorClear
IsErrorClear = GlobalError = "" And Err.Description = ""
End Function
'=============================================================================
' ClearError
'
Sub ClearError
GlobalError = ""
GlobalErrNum = 0
Err.Clear
End Sub
Function GetGlobalErrNum()
GetGlobalErrNum = GlobalErrNum
End Function
'#############################################################################
'# General Routines
'#############################################################################
Public g_LocalProxy
'=============================================================================
' CreateRemoteObj
'
Function CreateRemoteObj(ByVal strProgID, ByVal Machine)
if g_ErrorHandler then on error resume next
If VarType(g_LocalProxy) <> vbObject Then
Set g_LocalProxy = CreateObj("Commerce.RemoteServer.1")
End If
Set CreateRemoteObj = g_LocalProxy.CreateInprocObject(strProgID, Machine)
RaiseOnError Format2(Wizard("CreateRemoteObjFailed"), strProgID, Machine)
End Function
'=============================================================================
' Defined
'
Function Defined(ByVal T)
''Defined = VarType(T) <> vbNull
Defined = (VarType(T) <> vbNull) and (VarType(T) <> vbEmpty)
End Function
'=============================================================================
' FormatX
'
Function Format1(ByVal fmtString, ByVal Arg1)
If VarType(Arg1) = vbNull Then Arg1 = ""
Format1 = Replace(fmtString, "%1", Arg1)
End Function
Function Format2(ByVal fmtString, ByVal Arg1, ByVal Arg2)
If VarType(Arg2) = vbNull Then Arg2 = ""
Format2 = Replace(Format1(fmtString, Arg1), "%2", Arg2)
End Function
Function Format3(ByVal fmtString, ByVal Arg1, ByVal Arg2, ByVal Arg3)
If VarType(Arg3) = vbNull Then Arg3 = ""
Format3 = Replace(Format2(fmtString, Arg1, Arg2), "%3", Arg3)
End Function
'=============================================================================
' PrivateString
'
Function PrivateString(ByVal Number, ByVal Str)
PrivateString = ""
If Str <> "" Then PrivateString = String(Number, Str)
End Function
'=============================================================================
' ConvertArrayToSimpleList
'
Function ConvertArrayToSimpleList(ByVal Arr)
Set ConvertArrayToSimpleList = CreateObj("Scripting.Dictionary") '"Commerce.SimpleList")
Dim nIndex
For nIndex = LBound(Arr) To UBound(Arr)
ConvertArrayToSimpleList.Add Arr(nIndex), ""
Next
End Function
'=============================================================================
' PrivateSplit -- Splits to a SimpleList
'
Function PrivateSplit(ByVal Str, ByVal Delim)
Dim nIndex, rgSplit
If VarType(Str) = vbNull Then ' Force it into a string
Str = ""
End If
Set PrivateSplit = ConvertArrayToSimpleList(Split(Str, Delim))
End Function
'=============================================================================
' IsMember
' Looks for Member in a comma separated list of values
'
Function IsMember(ByVal Member, ByVal Str)
If Not Defined(Member) Then Member = ""
If Not Defined(Str) Then Str = ""
IsMember = 0<>InStr(1, ","+CStr(Str)+",", "," + CStr(Member) + ",", _
vbTextCompare)
End Function
'=============================================================================
' IsVoid
'
Function IsVoid(ByRef Value)
IsVoid = IsNull(Value) or IsEmpty(Value)
End Function
'=============================================================================
' StrToNumber
'
Function StrToNumber(ByVal Str)
Dim Number
Number = 0
if Str <> "" then
on error resume next
Number = CInt(Str)
on error goto 0
end if
StrToNumber = Number
End Function
'=============================================================================
' ValidNumber
'
Function ValidNumber(ByVal strValue, ByVal bRequired)
Dim bOK, Number
bOK = false
if strValue = "" then
if not bRequired then
bOK = true
end if
else
on error resume next
Number = CInt(strValue)
if Err.number = 0 then bOK = true
on error goto 0
end if
ValidNumber = bOK
End Function
'#############################################################################
'# Debugging Routines
'#############################################################################
'=============================================================================
' DumpObject
'
Sub DumpObject(ByVal Var, ByVal Col)
Dim vt, AddCol, I, C, N
vt = TypeName(Var)
AddCol = " |"
Select Case LCase(vt)
Case LCase("Dictionary")
I = Var.Count
For Each N In Var
OutputDebugString Col & " +-[" & N & "]"
I = I - 1
If I = 0 then
AddCol = " "
End If
DumpObject Var.Value(N), Col + AddCol
Next
Case LCase("ISimpleList")
I = Var.Count
C = 0
For Each N In Var
OutputDebugString Col & " +-[" & C & "]"
C = C + 1
I = I - 1
If I = 0 then
AddCol = " "
End If
Call DumpObject(N, Col + AddCol)
Next
Case LCase("String")
OutputDebugString Col & " +-> """ & Var & """"
Case Else
If vt = "Byte" Or vt = "Integer" Or _
vt = "Long" Or vt = "Single" Or _
vt = "Double" Or vt = "Currency" Or _
vt = "Date" Or vt = "Boolean" Or _
vt = "Error" Or vt = "Null" Or _
vt = "Empty" Then
OutputDebugString Col & " +-> " & Var
ElseIf InStr(vt, "()") > 0 Then
OutputDebugString Col & " +-> ** Array:" & vt & "**"
Else
OutputDebugString Col & " +-> **" & vt & "**"
End If
End Select
End Sub
'#############################################################################
'# Tracing
'#############################################################################
Public g_TracingFlag
Public g_nIndent
g_TracingFlag = false
g_nIndent = 0
sub SetTracingFlag( TracingFlag )
g_TracingFlag = TracingFlag
end sub
function TrcIndent(ByVal nIndent)
dim bstrIndent, i
bstrIndent = ""
for i = 0 to nIndent
if IsRunningInWSH() then
bstrIndent = bstrIndent & " "
else
bstrIndent = bstrIndent & " "
end if
next
TrcIndent = bstrIndent
end function
sub TrcEnter(bstrFunc)
if g_TracingFlag then
OutputDebugString ""
OutputDebugString TrcIndent(g_nIndent) & bstrFunc & " {"
g_nIndent = g_nIndent + 1
end if
end sub
sub TrcLeave(bstrFunc)
if g_TracingFlag then
g_nIndent = g_nIndent - 1
OutputDebugString ""
OutputDebugString TrcIndent(g_nIndent) & "} " & bstrFunc & "[err=" & Err.Number & "]"
end if
end sub
sub TrcValue(bstrLabel, vtValue)
if g_TracingFlag then
OutputDebugString ""
OutputDebugString TrcIndent(g_nIndent) & bstrLabel & " = " & vtValue
end if
end sub
sub TrcObjValue(bstrLabel, oValue)
if g_TracingFlag then
OutputDebugString ""
OutputDebugString TrcIndent(g_nIndent) & bstrLabel & " = " & TypeName(oValue)
end if
end sub
sub TraceOnError( ByVal Description )
if Err.number <> 0 then
OutputDebugString "Warning: " & Description
OutputDebugString "ErrNo = " & CStr(Err.Number) & _
" (Hex " & Hex(Err.Number) & ") Desc = " & Err.Description
end if
Err.Clear
end sub
sub Trace( ByVal Message )
OutputDebugString ""
OutputDebugString TrcIndent(g_nIndent) & Message
end sub
sub TraceParameters( ByRef ParamNames, ByRef ParamValues )
if g_ErrorHandler then on error resume next
Trace "[[[ START PARAMETER VALUES ]]]"
Dim i, j, ParamName, Key, Value, Values, ArrValues, DataValues
for i=LBound(ParamNames) to UBound(ParamValues)
ParamName = ParamNames(i) + ": "
' Check data type of the param value
select case VarType(ParamValues(i))
' Object, must be Dictionary or SimpleList
case vbObject
' Display param name
Trace "** " & ParamName
' Get list of values
Set Values = ParamValues(i)
'if TypeName(Values) = "ISimpleList" then ' list of simple values
' for each Key in Values
' Trace "-- " & CStr(Key)
' next
if TypeName(Values) = "Dictionary" then ' list of key-value pairs
Set DataValues = ParamValues(i)
for each Key in Values
Value = Values(Key)
' key value can again be a simple value or an array
if VarType(Value) = vbArray + vbVariant then
Trace "-- " & Key & ":"
for j=LBound(Value) to UBound(Value)
Trace "---- " & CStr(Value(j))
next
else
Trace "-- " & Key & " = " & CStr(Value)
end if
next
else
Trace "-- " & Key & ": Unknown object type """ & TypeName(Values) & """"
end if
' Variant array
case vbArray + vbVariant
Trace "** " & ParamName
ArrValues = ParamValues(i)
for j=LBound(ArrValues) to UBound(ArrValues)
Trace "-- " & CStr(ArrValues(j))
next
' Assume simple type
case else
if IsVoid(ParamValues(i)) then
ParamName = ParamName & "Null"
else
ParamName = ParamName & CStr(ParamValues(i))
end if
Trace "** " & ParamName
end select
next
Trace "[[[ END PARAMETER VALUES ]]]"
Err.Clear
end sub
sub DisplayActionStart( Action )
Trace "*** " & Action & " - START ***"
end sub
sub DisplayActionFinish( Action )
Trace "*** " & Action & " - FINISH ***"
end sub
'#############################################################################
'# NT Services, COM components, MTS packages
'#############################################################################
'=============================================================================
' StopServices
'
Sub StopServices( ByRef Services, ByVal bStandardServices )
Dim Count
on error resume next
Count = UBound(Services)
if err.number <> 0 then Count = -1
on error goto 0
if Count = -1 then
RaiseError Wizard("StopService_NoServices")
end if
DisplayActionStart "STOPPING SERVICES"
TraceParameters Array("Services", "bStandardServices"), Array(Services, bStandardServices)
Dim WshShell
Set WshShell = CreateObj("Wscript.Shell")
if g_ErrorHandler then on error resume next
Dim i, Service
for i=0 to Count
Service = Services(i)
WriteProgressMsg "Stopping service " & Service
' invoke net stop. Add /Y switch because some services otherwise ask for confirmation
Err.Number = WshShell.Run("net stop """ & Service & """ /y", 0, True)
TraceOnError "Error while stopping service """ & Service & """ " & _
"(service may not exist or may already be stopped)"
next
if bStandardServices then
' Stop MTX (MTXSTOP)
Trace "Stopping MTS"
WshShell.Run "mtxstop", 0, True
end if
DisplayActionFinish "STOPPING SERVICES"
End Sub
'=============================================================================
' StartServices
'
Sub StartServices( ByRef Services )
Dim Count
on error resume next
Count = UBound(Services)
if err.number <> 0 then Count = -1
on error goto 0
if Count = -1 then
RaiseError Wizard("StartService_NoServices")
end if
DisplayActionStart "STARTING SERVICES"
TraceParameters Array("Services"), Array(Services)
Dim WshShell
Set WshShell = CreateObj("Wscript.Shell")
if g_ErrorHandler then on error resume next
Dim i, Service
for i=0 to Count
Service = Services(i)
WriteProgressMsg "Starting service " & Service
Err.Number = WshShell.Run("net start """ & Service & """", 0, True)
TraceOnError "Error while starting service """ & Service & """ " & _
"(service may not exist or may already be started)"
next
DisplayActionFinish "STARTING SERVICES"
End Sub
'========================================================================
' InstallCOMComponents
'
Sub InstallCOMComponents( ByVal ComponentDir, ByRef Components, ByVal bRegister )
Dim Count
on error resume next
Count = UBound(Components)
if err.number <> 0 then Count = -1
on error goto 0
Dim Action
if bRegister then
Action = "Register"
else
Action = "Unregister"
end if
if Count = -1 then
Trace "No COM components to " & LCase(Action)
exit sub
end if
' append "\" to path, if necessary
if Mid(ComponentDir, Len(ComponentDir), 1) <> "\" then
ComponentDir = ComponentDir & "\"
end if
Dim AdminFiles
Set AdminFiles = CreateObj("Commerce.AdminFiles")
if g_ErrorHandler then on error resume next
DisplayActionStart UCase(Action) & " COM COMPONENTS"
TraceParameters Array("ComponentDir", "Components", "bRegister"), _
Array(ComponentDir, Components, bRegister)
WriteProgressMsg Action & " COM Components ..."
Dim i, Component
for i=0 to Count
Component = ComponentDir & Components(i)
Trace Action & " COM component " & Component
if bRegister then
AdminFiles.RegisterServer Component
else
AdminFiles.UnregisterServer Component
end if
TraceOnError "Error while " & Action & "ing component " & Component
next
DisplayActionFinish UCase(Action) & " COM COMPONENTS"
End Sub
'========================================================================
' InstallMTSComponents
'
Sub InstallMTSComponents( ByVal ComponentDir, ByRef MTSComponents, ByVal PackageName, _
ByVal MtsUserName, ByVal MtsPassword, ByVal bDelPackage, ByVal bInstall )
Dim ComponentCount
on error resume next
ComponentCount = UBound(MTSComponents)
if err.number <> 0 then ComponentCount = -1
on error goto 0
Dim Action
if bInstall then
Action = "Install"
else
Action = "Uninstall"
end if
if ComponentCount = -1 then
Trace "No MTS components to " & LCase(Action)
exit sub
end if
' append "\" to path, if necessary
if ComponentDir <> "" then
if Mid(ComponentDir, Len(ComponentDir), 1) <> "\" then
ComponentDir = ComponentDir & "\"
end if
end if
if IsVoid(MtsUserName) then MtsUserName = ""
if IsVoid(MtsPassword) then MtsPassword = ""
if g_ErrorHandler then on error resume next
DisplayActionStart UCase(Action) & " MTS PACKAGE"
TraceParameters Array("ComponentDir", "MTSComponents", "PackageName", "bInstall", _
"MtsUserName", "MtsPassword"), _
Array(ComponentDir, MTSComponents, PackageName, bInstall, _
MtsUserName, MtsPassword)
Trace "Create Catalog Object ..."
' First, we create the catalog object
Dim Catalog
Set Catalog = CreateObj("MTSAdmin.Catalog.1")
RaiseOnError Wizard("InstMts_GetCatalog")
if not IsErrorClear() then
exit sub
end if
Trace "Get packages collection..."
Dim Packages
Set Packages = Catalog.GetCollection("Packages")
Packages.Populate
RaiseOnError Wizard("InstMts_GetPackages")
if not IsErrorClear() then
exit sub
end if
' Remove all packages that go by the same name as the package we wish to install
Trace "Searching for the existing package..."
Dim NumPackages, i
NumPackages = Packages.Count
Dim Package
Set Package = nothing
for i = numPackages - 1 To 0 Step -1
if Packages.Item(i).Value("Name") = PackageName then ' package found
' must remove existing package
if bDelPackage then
WriteProgressMsg "Removing old MTS Package ..."
Packages.Remove(i)
' Commit our deletions
Packages.SaveChanges
' Show any errors
TraceOnError "Error(s) occurred while removing old package"
else
' must not remove old package but modify existing package; store it in the variable
Set Package = Packages.Item(i)
Trace "Package found"
end if
' package found, exit loop
exit for
end If
next
WriteProgressMsg "Configuring MTS package E-Enterprise"
Dim Components, ComponentPath
if bInstall then
if Package is nothing then ' no existing package, create new
Trace "Creating new package ..."
Dim NewPackage
Set NewPackage = Packages.Add
NewPackage.Value("Name") = PackageName
NewPackage.Value("SecurityEnabled") = "N"
if MtsUserName <> "" then
NewPackage.Value("Identity") = MtsUserName
NewPackage.Value("Password") = MtsPassword
end if
' Commit new package & refresh packages
Packages.SaveChanges
Packages.Populate
Set Package = NewPackage
RaiseOnError Wizard("InstMts_AddPackage")
if not IsErrorClear() then
exit sub
end if
elseif MtsUserName <> "" and MtsPassword <> "" then
Trace "Set MTS user account on existing package ..."
Package.Value("Identity") = MtsUserName
Package.Value("Password") = MtsPassword
' Commit changes & refresh packages
Packages.SaveChanges
Packages.Populate
end if
' Install (add) components
Trace "Install MTS components..."
' Get components collection for package
Set Components = Packages.GetCollection("ComponentsInPackage", Package.Value("ID"))
Dim Util
Set Util = Components.GetUtilInterface
RaiseOnError Wizard("InstMts_GetComponents")
if not IsErrorClear() then
exit sub
end if
' loop through the list of components to install
for i=0 to ComponentCount
ComponentPath = ComponentDir & MTSComponents(i)
Trace "Adding MTS component " & ComponentPath
Util.InstallComponent ComponentPath, "", ""
next
' Commit the changes to the components
Components.SaveChanges
HandleMTSErrors Components, Package
else
if Package is nothing then ' no existing package found
Trace "Package not found"
else
' Uninstall (remove) components
Trace "Uninstall MTS components..."
' Get components collection for package
Set Components = Packages.GetCollection("ComponentsInPackage", Package.Value("ID"))
RaiseOnError Wizard("InstMts_GetComponents")
if not IsErrorClear() then
exit sub
end if
Components.Populate
Dim ComponentName
' loop through the list of components to uninstall
for i=0 to ComponentCount
ComponentPath = LCase(ComponentDir & MTSComponents(i))
Trace "Searching MTS components in " & ComponentDir & MTSComponents(i)
Dim j, Component
j = 0
do while j < Components.Count
Set Component = Components.Item(j)
if LCase(Component.Value("DLL")) = ComponentPath then
Trace "Removing component " & Component.Name
Components.Remove j
' Do not increase counter (i) !!
else
j = j+1
end if
loop
next
' Commit the changes to the components
Components.SaveChanges
HandleMTSErrors Components, Package
end if
end if
DisplayActionFinish UCase(Action) & " MTS PACKAGE"
End Sub
'========================================================================
' HandleMTSErrors
'
Sub HandleMTSErrors( ByVal Components, ByVal Package )
Const mtsErrAlreadyInstalled = &H080110404
Const mtsErrCompFileDoesNotExist = &H080110424
if Err.Number <> 0 Then
Dim Errs
Set Errs = Components.GetCollection("ErrorInfo", Package.Value("ID"))
Errs.Populate
Dim i, NumCount, ErrMsg, Errors, Warnings, bWarning
Errors = ""
Warnings = ""
NumCount = Errs.Count
for i = NumCount - 1 to 0 step -1
bWarning = false
Select Case Errs.Item(i).Value("ErrorCode")
Case mtsErrAlreadyInstalled
bWarning = true
ErrMsg = "The Component is already registred"
Case mtsErrCompFileDoesNotExist
ErrMsg = "The Component dll file does not exist"
Case Else
ErrMsg = "Unhandled error with code: " & Errs.Item(i).Value("ErrorCode")
End Select
ErrMsg = Errs.Item(i).Value("Name") & ": " & ErrMsg
if bWarning then
Warnings = Warnings & ErrMsg & vbCRLF
else
Errors = Errors & ErrMsg & vbCRLF
end if
next
if g_ErrorHandler then on error resume next
if Errors <> "" then
Errors = "Some components could not be installed due to the following errors: " & _
vbCRLF & Errors
RaiseError Errors
end if
if Warnings <> "" then
Warnings = "Warning: some components could not be installed due to the following errors: " & _
vbCRLF & Warnings
Trace Warnings
end if
end if
End Sub
'========================================================================
' CheckMTSPackage
'
Sub CheckMTSPackage( ByVal PackageName )
if g_ErrorHandler then on error resume next
Dim bFound
bFound = false
DisplayActionStart "CHECKING MTS PACKAGE"
TraceParameters Array("PackageName"), Array(PackageName)
Trace "Create Catalog Object ..."
' First, we create the catalog object
Dim Catalog
Set Catalog = CreateObj("MTSAdmin.Catalog.1")
RaiseOnError Wizard("InstMts_GetCatalog")
if IsErrorClear() then
Trace "Get packages collection..."
Dim Packages
Set Packages = Catalog.GetCollection("Packages")
Packages.Populate
RaiseOnError Wizard("InstMts_GetPackages")
if IsErrorClear() then
Trace "Searching for the package..."
Dim NumPackages, i
NumPackages = Packages.Count
for i = numPackages - 1 To 0 Step -1
if Packages.Item(i).Value("Name") = PackageName then ' package found
' package found, exit loop
bFound = true
exit for
end If
next
end if
end if
DisplayActionFinish "CHECKING MTS PACKAGE"
' return process exist code: 0 = found, 1 = not found
if bFound then
Trace "Package found"
WScript.Quit 0
else
Trace "Package not found"
WScript.Quit 1
end if
End Sub
'========================================================================
' RemoveMTSPackage
'
Sub RemoveMTSPackage( ByVal PackageName )
Dim ComponentCount
on error resume next
ComponentCount = UBound(MTSComponents)
if err.number <> 0 then ComponentCount = -1
on error goto 0
if g_ErrorHandler then on error resume next
DisplayActionStart "REMOVE MTS PACKAGE"
TraceParameters Array("PackageName"), Array(PackageName)
Trace "Create Catalog Object ..."
' First, we create the catalog object
Dim Catalog
Set Catalog = CreateObj("MTSAdmin.Catalog.1")
RaiseOnError Wizard("InstMts_GetCatalog")
if not IsErrorClear() then
exit sub
end if
Trace "Get packages collection..."
Dim Packages
Set Packages = Catalog.GetCollection("Packages")
Packages.Populate
RaiseOnError Wizard("InstMts_GetPackages")
if not IsErrorClear() then
exit sub
end if
' Remove all packages that go by the same name as the package we wish to install
Trace "Searching for the existing package..."
Dim NumPackages, i
NumPackages = Packages.Count
Dim bFound
bFound = false
for i = numPackages - 1 To 0 Step -1
if Packages.Item(i).Value("Name") = PackageName then ' package found
' remove existing package
WriteProgressMsg "Removing MTS Package ..."
Packages.Remove(i)
' Commit our deletions
Packages.SaveChanges
' Show any errors
TraceOnError "Error(s) occurred while removing package"
' package found, exit loop
bFound = true
exit for
end If
next
if not bFound then
Trace "Warning: package " & PackageName & " was not found"
end if
DisplayActionFinish "REMOVE MTS PACKAGE"
End Sub
'#############################################################################
'# Site Server Catalog Build Server configuration
'#############################################################################
'========================================================================
' ConfigBuildServer
'
Sub ConfigBuildServer( ByVal WebsiteName, ByVal WebServerName, ByVal HomeDir, ByVal SbpFile, _
ByVal CatalogName, ByVal DestServers )
if g_ErrorHandler then on error resume next
DisplayActionStart "CONFIG BUILD SERVER"
TraceParameters Array("WebsiteName", "WebServerName", "HomeDir", "SbpFile", "CatalogName", _
"DestServers"), _
Array(WebsiteName, WebServerName, HomeDir, SbpFile, CatalogName, DestServers)
' check if .SBP file exists
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
if not Fso.FileExists(SbpFile) then
RaiseError Format1(Wizard("CfgBuild_SbpFileNotFound"),SbpFile)
exit sub
end if
' Check if web site exists. If so, check if not running under Membership,
' otherwise, create it
Dim WebsiteID, PortNr, bExistingSite
ConfigBuildServerSite WebsiteName, HomeDir, WebsiteID, PortNr, bExistingSite
if not IsErrorClear() then
exit sub
end if
WriteProgressMsg "Create Build server catalog, please wait"
Dim SearchAdmin
Set SearchAdmin = CreateObj("Search.SearchAdmin.1")
Dim BuildServer
Set BuildServer = SearchAdmin.BuildServer
' try to delete the old catalog first
Trace "Removing old catalog ..."
Dim Catalogs
Set Catalogs = BuildServer.BuildCatalogs
Catalogs.Remove CatalogName
TraceOnError "Remove old catalog failed"
' import the .sbp file
Trace "Importing catalog definition file ..."
BuildServer.ImportCatalog CatalogName, SbpFile
if Err.number = &h8007052E then
RaiseOnError Wizard("CfgBuild_SbpLogonFailure")
else
RaiseOnError Format1(Wizard("CfgBuild_SbpFileImport"),SbpFile)
end if
if not IsErrorClear() then
exit sub
end if
ConfigBuildServerSettings WebServerName, PortNr, CatalogName, DestServers
DisplayActionFinish "CONFIG BUILD SERVER"
End Sub
'========================================================================
' ConfigBuildServerSettings
'
Sub ConfigBuildServerSettings( ByVal WebServerName, ByVal PortNr, ByVal CatalogName, ByVal DestServers )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Configure Build server catalog"
Dim SearchAdmin
Set SearchAdmin = CreateObj("Search.SearchAdmin.1")
Dim BuildServer
Set BuildServer = SearchAdmin.BuildServer
Dim Catalogs
Set Catalogs = BuildServer.BuildCatalogs
Dim Catalog
Set Catalog = Nothing
Dim Item
for each Item in Catalogs
if Item.Name = CatalogName then
Set Catalog = Item
exit for
end if
next
if Catalog Is Nothing then
RaiseError Wizard("CfgBuild_GetCatalogFailed")
exit sub
end if
Trace "Deleting list of search servers ..."
Dim SearchServers
Set SearchServers = Catalog.SearchServers
Dim SearchServer
for each SearchServer in SearchServers
SearchServers.Remove SearchServer.Name
next
TraceOnError "Error(s) while deleting search servers"
Trace "Deleting list of start sites ..."
Dim StartPages
Set StartPages = Catalog.StartPages
Dim StartPage
for each StartPage in StartPages
StartPages.Remove StartPage.URL
next
TraceOnError "Error(s) while deleting start pages"
Dim URL
URL = "http://" & WebServerName & ":" & CStr(PortNr) & "/dir.asp"
Trace "Adding start page """ & URL & """ ..."
StartPages.Add URL
RaiseOnError Format1(Wizard("CfgBuild_AddStartPage"),URL)
Dim Mappings
Set Mappings = Catalog.Mappings
Dim Mapping
for each Mapping in Mappings
Mappings.Remove Mapping.From
next
TraceOnError "Error(s) while deleting mappings"
Dim URLFrom, URLTo
URLFrom = "http://" & WebServerName & ":" & CStr(PortNr) & "/row.asp"
URLTo = "http://" & WebServerName & ":" & CStr(PortNr) & "/view.asp"
Trace "Adding mapping from """ & URLFrom & """ ..."
Mappings.Add URLFrom, URLTo
RaiseOnError Format1(Wizard("CfgBuild_AddMapping"),URL)
Dim DestServer
for each DestServer in DestServers
Trace "Adding search server " & DestServer & " ..."
SearchServers.Add DestServer
next
RaiseOnError Wizard("CfgBuild_AddSearchServers")
End Sub
'========================================================================
' ConfigBuildServerSite
'
Sub ConfigBuildServerSite( ByVal WebsiteName, ByVal HomeDir, ByRef WebsiteNr, ByRef PortNr, _
ByRef bExists )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Checking web site: " & WebsiteName
' See if the given web site already exists
Dim WebsiteID, MaxWebsiteID, Port, MaxPort
WebsiteNr = ""
MaxWebsiteID = ""
PortNr = 0
MaxPort = 0
bExists = false
Dim Websvc, Site, Webinfo, Bindings, i
Set Websvc = GetObject("IIS://LocalHost/W3svc")
' Enumerate existing web sites; get web site ID and highest TCP/IP port number
for each Site in Websvc
if Site.Class = "IIsWebServer" then
WebsiteID = Site.Name
if WebsiteID > MaxWebsiteID then
MaxWebsiteID = WebsiteID
end if
' Get "server bindings" (TCP/IP port nr. etc.)
Bindings = IISGetBindings(Site)
Port = StrToNumber( Bindings(1) )
if Port > MaxPort then
MaxPort = Port
end if
if Site.ServerComment = WebsiteName then
WebsiteNr = WebsiteID
PortNr = Port
bExists = true
end if
end if
next
' If web site already exists, it must not run under Membership.
' If it does not exist, create it.
if bExists then
if IsMembership(WebsiteNr,"") then
RaiseError Format1(Wizard("CfgBuild_NoMembAllowed"),WebsiteNr)
end if
else
' Create new web site
WebsiteNr = StrToNumber(MaxWebsiteID) + 1
WebsiteNr = CStr(WebsiteNr)
if MaxPort = 0 then
PortNr = 4004 ' arbitrary port number which should be free
else
PortNr = MaxPort + 2 ' skip 1 extra, because the intermediate port nr is
' used for the secure port
end if
WriteProgressMsg Format2("Creating web site %1 on port %2",WebsiteNr,CStr(PortNr))
Dim AdminWebServer
Set AdminWebServer = CreateObj("Commerce.AdminWebServer")
' Create web site; specify port nr and secure port nr (if you don't specify the
' secure port nr, an error will appear in the Windows NT event log each time the
' web site is started)
AdminWebServer.CreateVirtualServer WebsiteNr, PortNr, PortNr+1, HomeDir, _
WebsiteName, 0 'nRootAuthorization
RaiseOnError Format2(Wizard("CfgBuild_CreateSite"),WebsiteID,CStr(PortNr))
end if
if not IsErrorClear() then
exit sub
end if
' set anonymous access
WriteProgressMsg "Setting anonymous access"
Dim IISRootPath
IISRootPath = "IIS://LocalHost/w3svc/" & WebsiteNr & "/ROOT"
Dim IISRoot
Set IISRoot = GetObject(IISRootPath)
TraceOnError "Error getting root object for """ & IISRootPath & """"
Trace "Allow Anon. (before): " & CStr(IISRoot.AuthAnonymous)
IISRoot.AuthAnonymous = true
Trace "Allow Anon. (after): " & CStr(IISRoot.AuthAnonymous)
IISRoot.SetInfo
TraceOnError "Could not set Allow Anonymous on web site #" & WebsiteNr
' try to start web site
WriteProgressMsg "Starting web site"
Dim IISPath
IISPath = "IIS://LocalHost/W3svc/" & WebsiteNr
Dim WebSite
Set Website = GetObject(IISPath)
Website.Start
TraceOnError "Could not start web site #" & WebsiteNr
End Sub
'========================================================================
' IISGetBindings
'
Function IISGetBindings( ByVal Site )
Dim Bindings, Bindstr
BindStr = ""
if g_ErrorHandler then on error resume next
Err.Clear
Bindings = Site.ServerBindings
if Err.number = 0 then
if IsArray(Bindings) then
Bindstr = Bindings(0)
else
Bindstr = Bindings
end if
end if
Dim one, two, ia, ip, hn
ia = ""
ip = ""
hn = ""
if BindStr <> "" then
one = Instr(Bindstr,":")
two = Instr((one+1),Bindstr,":")
ia = Mid(Bindstr,1,(one-1))
ip = Mid(Bindstr,(one+1),((two-one)-1))
hn = Mid(Bindstr,(two+1))
end if
IISGetBindings = Array(ia,ip,hn)
End Function
'========================================================================
' UnconfigBuildServer
'
Sub UnconfigBuildServer( ByVal WebsiteName, ByVal WebServerName, ByVal CatalogName )
if g_ErrorHandler then on error resume next
DisplayActionStart "UNCONFIG BUILD SERVER"
TraceParameters Array("WebsiteName", "WebServerName", "CatalogName"), _
Array(WebsiteName, WebServerName, CatalogName)
RemoveBuildServerSite WebsiteName
WriteProgressMsg "Deleting Build server catalog"
Dim SearchAdmin
Set SearchAdmin = CreateObj("Search.SearchAdmin.1")
Dim BuildServer
Set BuildServer = SearchAdmin.BuildServer
' try to delete the catalog
Trace "Removing catalog ..."
Dim Catalogs
Set Catalogs = BuildServer.BuildCatalogs
Catalogs.Remove CatalogName
RaiseOnError Format1(Wizard("UnCfgBuild_Failed"),CatalogName)
DisplayActionFinish "UNCONFIG BUILD SERVER"
End Sub
'========================================================================
' RemoveBuildServerSite
'
Sub RemoveBuildServerSite( ByVal WebsiteName )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Removing web site: " & WebsiteName
' See if the given web site exists
Dim Websvc, Site, WebsiteID, bFound
Set Websvc = GetObject("IIS://LocalHost/W3svc")
' Enumerate existing web sites
bFound = false
for each Site in Websvc
if Site.Class = "IIsWebServer" then
if Site.ServerComment = WebsiteName then
bFound = true
WebsiteID = Site.Name
Websvc.Delete "IIsWebServer", WebsiteID
TraceOnError "Error while deleting web site #" & WebsiteID & " (" & _
WebsiteName & ")"
exit for
end if
end if
next
if not bFound then
Trace "Warning: web site " & WebsiteName & " not found"
end if
End Sub
'========================================================================
' RemoveSearchCatalog
'
Sub RemoveSearchCatalog( ByVal CatalogName )
if g_ErrorHandler then on error resume next
DisplayActionStart "REMOVE SEARCH CATALOG"
TraceParameters Array("CatalogName"), Array(CatalogName)
Dim SearchAdmin, SearchObj, Catalogs
Set SearchAdmin = CreateObj("Search.SearchAdmin.1")
Set SearchObj = SearchAdmin.SearchServer
Set Catalogs = SearchObj.SearchCatalogs
Catalogs.Remove(CatalogName)
RaiseOnError Format1(Wizard("RemoveCatalog_Failed"),CatalogName)
DisplayActionFinish "REMOVE SEARCH CATALOG"
End Sub
'#############################################################################
'# Membership
'#############################################################################
' Object IDs
Public g_instance
Public g_bstrDSAcctName
Public g_bstrDSAcctPwd
Public g_bstrAcctDN
Public g_bstrAdsRootPath
g_instance = 0
g_bstrDSAcctName = ""
g_bstrDSAcctPwd = ""
g_bstrAcctDN = ""
g_bstrAdsRootPath = ""
'========================================================================
' MembershipRequired
'
Sub MembershipRequired
Dim AdminFile
Set AdminFile = CreateObj("Commerce.AdminFiles")
If Not IsMembership(switches("websiteid"), "") Then
Yell "Membership is required for this site to install.", vbCritical
elseif Not AdminFile.IsNTFS(switches("path")) Then
Yell "This site can only be installed on an NTFS partition.", vbCritical
End If
End Sub
'=============================================================================
' CreateMembershipServer
'
sub CreateMembershipServer( ByVal WebInstance, ByVal LDAPHost, ByVal LDAPPort, _
ByVal DSName, ByVal DSRootName, _
ByVal DBServer, ByVal Database, ByVal DBUser, ByVal DBPassword, _
ByVal DSAdminPassword, ByVal bReinstall )
' Check parameters & set defaults
if IsVoid(LDAPHost) then
LDAPHost = ""
end if
on error resume next
LDAPPort = CInt(LDAPPort)
if Err.Number <> 0 then LDAPPort = 0
on error goto 0
on error resume next
WebInstance = CInt(WebInstance)
if Err.Number <> 0 then WebInstance = 0
on error goto 0
if IsVoid(DBPassword) then DBPassword = ""
if g_ErrorHandler then on error resume next
' === Step 1: Initialization
DisplayActionStart "CREATING MEMBERSHIP SERVER"
TraceParameters Array("WebInstance", "LDAPHost", "LDAPPort", "DSName", "DSRootName", "DBServer", _
"Database", "DBUser", "DBPassword", "DSAdminPassword", "bReinstall"), _
Array(WebInstance, LDAPHost, LDAPPort, DSName, DSRootName, DBServer, _
Database, DBUser, DBPassword, DSAdminPassword, bReinstall)
WriteProgressMsg "Initializing for Membership"
Dim BrokServers
Set BrokServers = MemCreateObj(MBS_OBJ_BROKSERVERS)
BrokServers.Init
' check for write privilege
BrokServers.HasWritePrivilege
RaiseOnError Wizard("Mem_Init")
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
' === Step 2: Search for membership server.
' If it exists: delete membership server, or display error,
' Next, create new membership server instance.
Dim MemServerID
FindMembershipServer DSRootName, MemServerID
if MemServerID <> 0 then
if bReinstall then
Trace "Warning: Membership server " & DSRootName & " already exists"
DeleteMembershipServer MemServerID, false 'MemServerID, false
MemServerID = 0
else
RaiseError Wizard("Mem_ServerExists")
end if
end if
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
' Create new membership server instance
WriteProgressMsg "Creating Membership instance"
BrokServers.CreateServer MemServerID
RaiseOnError Wizard("Mem_CreateMem")
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
Trace "Created Membership Server Instance: " & CStr(MemServerID)
' === Step 3: Create LDAP and Direct Mail servers
WriteProgressMsg "Creating LDAP instance"
' Try to create LDAP server. This must succeed
Dim LDAPCfg
CreateLDAPServer MemServerID, LDAPHost, LDAPPort, LDAPCfg
If Not IsErrorClear Then
' if anything goes wrong, delete the newly created membership server (and its
' associated LDAP, DMail and AUO servers)
DeleteNewMembershipServer MemServerID
Exit Sub
End If
' Try to create DMail server. This is allowed to fail
CreateDMailServer MemServerID
' display errors, but continue processing
TraceOnError "Error creating DMail server:"
' === Step 4: Membership server preconfiguration (partial)
Dim BrokConfig
Set BrokConfig = MemCreateObj(MBS_OBJ_BROKCFG)
BrokConfig.GetConfig MemServerID
BrokConfig.bLocal = false
BrokConfig.bszServerName= LDAPHost
BrokConfig.lPort = LDAPPort
BrokConfig.bszBaseDN = "ou=members"
BrokConfig.bszGroupPrefix = "Site_" & DSRootName & "_"
BrokConfig.lPwdCookieTimeout = 20 ' timeout 20 minutes
BrokConfig.bszComment = DSName
BrokConfig.bEnabled = true ' enable broker for authentication
' commit changes
BrokConfig.SetConfig
RaiseOnError Wizard("Mem_PreconfigMem")
If Not IsErrorClear Then ' check status & leave on error after each step
DeleteNewMembershipServer MemServerID
Exit Sub
End If
' === Step 5: Config LDAP server with membership directory
ConfigLDAPServer MemServerID, LDAPHost, LDAPPort, DSRootName, DBServer, Database, DBUser, _
DBPassword, DSAdminPassword
If Not IsErrorClear Then
DeleteNewMembershipServer MemServerID
Exit Sub
End If
' === Step 6: Membership server preconfiguration (full)
UtilConfigMembershipServer MemServerID, LDAPHost, LDAPPort, DSRootName, "Administrator", _
DSAdminPassword
If Not IsErrorClear Then
DeleteNewMembershipServer MemServerID
Exit Sub
End If
' === Step 7: Map the membership server to the web site, if it has been specified
if WebInstance <> 0 then
Trace "Mapping membership server to web site"
BrokServers.MapToBroker "W3SVC", WebInstance, MemServerID
RaiseOnError Format1(Wizard("Mem_MapToSiteFailed"),CStr(WebInstance))
end if
DisplayActionFinish "CREATING MEMBERSHIP SERVER"
end sub
'=============================================================================
' DeleteNewMembershipServer
'
sub DeleteNewMembershipServer( ByVal MemServerID )
if g_ErrorHandler then on error resume next
Trace "Error occurred, deleting newly created membership server ..."
DeleteMembershipServer MemServerID, false
TraceOnError "Error deleting new membership server:"
end sub
'=============================================================================
' DeleteMembershipServer
'
sub DeleteMembershipServer( ByVal MemServerID, ByVal bReport )
if g_ErrorHandler then on error resume next
' Delete membership server, together with its AUO (-> AuoConfig.DeleteInstance) and LDAP server
DisplayActionStart "DELETING MEMBERSHIP SERVER"
if bReport then
TraceParameters Array("MemServerID"), Array(MemServerID)
WriteProgressMsg "Initializing for Membership"
end if
Dim BrokServers, BrokCfg, LdapCfg, DmCfg, AuoCfg
Set BrokServers = MemCreateObj(MBS_OBJ_BROKSERVERS)
Set BrokCfg = MemCreateObj(MBS_OBJ_BROKCFG)
Set LdapCfg = MemCreateObj(MBS_OBJ_LDAPCFG)
Set DmCfg = MemCreateObj(MBS_OBJ_DMAILCFG)
Set AuoCfg = MemCreateObj(MBS_OBJ_AUOCFG)
BrokServers.Init
ReportError Wizard("MemDel_Init"), bReport
if bReport then
WriteProgressMsg "Deleting AUO and LDAP instance"
end if
DmCfg.DeleteInstance MemServerID
ReportError Wizard("MemDel_Dmail"), bReport
LdapCfg.DeleteConfig MemServerID
ReportError Wizard("MemDel_Ldap"), bReport
AuoCfg.GetInfo MemServerID
if Err.number <> 0 then
AuoCfg.DeleteInstance
end if
ReportError Wizard("MemDel_Auo"), bReport
WriteProgressMsg "Deleting Membership instance"
BrokServers.DeleteServer MemServerID
ReportError Wizard("MemDel_Mem"), bReport
DisplayActionFinish "DELETING MEMBERSHIP SERVER"
end sub
'=============================================================================
' CreateSecAuoProvider
'
sub CreateSecAuoProvider( ByVal DSRootName, _
ByVal Name, ByVal Path, ByVal Schema, ByVal Klass, ByVal Suffix, _
ByVal DepObj, ByVal DepProp, ByVal BindAsName, ByVal BindAsPassword )
if g_ErrorHandler then on error resume next
' Check parameters & set defaults
if IsVoid(DepObj) then
DepObj = ""
end if
if IsVoid(DepProp) then
DepProp = ""
end if
if IsVoid(BindAsName) then
BindAsName = ""
end if
if IsVoid(BindAsPassword) then
BindAsPassword = ""
end if
DisplayActionStart "CREATING SEC AUO PROVIDER"
TraceParameters Array("DSRootName", "Name", "Path", "Schema", "Klass", "Suffix", _
"DepObj", "DepProp", "BindAsName", "BindAsPassword"), _
Array(DSRootName, Name, Path, Schema, Klass, Suffix, _
DepObj, DepProp, BindAsName, BindAsPassword)
' Search for membership server
Trace "Searching for membership server with DS root = " & DSRootName
Dim MemServerID
FindMembershipServer DSRootName, MemServerID
if MemServerID = 0 then
RaiseError Wizard("Mem_ServerNotFound")
Exit Sub
End If
' If LDAP port is given as a symbolic value, subsititute the "real" value
Dim Index
Index = InStr(UCase(Schema),"")
if Index > 0 then
Trace "Determine LDAP port for ADS schema string"
Dim BrokConfig
Set BrokConfig = MemCreateObj(MBS_OBJ_BROKCFG)
BrokConfig.GetConfig MemServerID
RaiseOnError Wizard("Mem_GetBrokCfgFailed")
If Not IsErrorClear Then
exit sub
End If
Dim LDAPPort
LDAPPort = BrokConfig.lPort
Schema = Left(Schema,Index-1) & CStr(LDAPPort) & Mid(Schema,Index+Len(""))
Trace "Changed ADS schema string to " & Schema
end if
' Create AUO provider
WriteProgressMsg "Creating secondary AUO provider"
Dim AuoConfig
Set AuoConfig = MemCreateObj(MBS_OBJ_AUOCFG)
AuoConfig.GetInfo MemServerID
RaiseOnError Wizard("Mem_GetInfoFailed")
' Create or update the provider
AuoConfig.SetEntry Name,Path,Schema,Klass,Suffix,DepObj,DepProp,BindAsName,BindAsPassword
RaiseOnError Wizard("Mem_GetEntryFailed")
' Save changes
AuoConfig.SetInfo
RaiseOnError Wizard("Mem_SetInfoFailed")
DisplayActionFinish "CREATING SEC AUO PROVIDER"
end sub
'=============================================================================
' DeleteSecAuoProvider
'
sub DeleteSecAuoProvider( ByVal DSRootName, ByVal Name )
if g_ErrorHandler then on error resume next
DisplayActionStart "DELETING SEC AUO PROVIDER"
TraceParameters Array("DSRootName", "Name"), Array(DSRootName, Name)
' Search for membership server
Trace "Searching for membership server with DS root = " & DSRootName
Dim MemServerID
FindMembershipServer DSRootName, MemServerID
if MemServerID = 0 then
RaiseError Wizard("Mem_ServerNotFound")
Exit Sub
End If
' Delete AUO provider
WriteProgressMsg "Deleting secondary AUO provider"
Dim AuoConfig
Set AuoConfig = MemCreateObj(MBS_OBJ_AUOCFG)
AuoConfig.GetInfo MemServerID
RaiseOnError Wizard("Mem_GetInfoFailed")
' Create or update the provider
AuoConfig.RemoveEntry Name
RaiseOnError Wizard("Mem_RemoveEntryFailed")
' Save changes
AuoConfig.SetInfo
RaiseOnError Wizard("Mem_SetInfoFailed")
DisplayActionFinish "DELETING SEC AUO PROVIDER"
end sub
'=============================================================================
' FindMembershipServer
'
sub FindMembershipServer( ByVal DSRootName, ByRef MemServerID )
if g_ErrorHandler then on error resume next
Dim BrokServers
Set BrokServers = MemCreateObj(MBS_OBJ_BROKSERVERS)
BrokServers.Init
Dim BrokConfig
Set BrokConfig = MemCreateObj(MBS_OBJ_BROKCFG)
Dim IDs, Names, i, Name
' enumerate servers
BrokServers.GetServers IDs, Names
MemServerID = 0
Trace "Enumerating Membership servers ..."
for i = LBound(IDs) to UBound(IDs)
BrokConfig.GetConfig IDs(i)
Trace "Memb. server " & CStr(i) & ": " & BrokConfig.bszGroupPrefix
if UCase(BrokConfig.bszGroupPrefix) = UCase("Site_" & DSRootName & "_") then
MemServerID = IDs(i)
Trace "Found Memb. server for " & DSRootName
exit for
end if
next
if MemServerID = 0 then
Trace "Memb. server for " & DSRootName & " not found"
end if
RaiseOnError Wizard("Mem_FindServer")
end sub
'=============================================================================
' CreateLDAPServer
'
sub CreateLDAPServer( ByVal MemServerID, ByVal LDAPHost, ByRef LDAPPort, ByRef LdapCfg )
const LDAP_PORT_OFFSET = 1001
if LDAPPort = 0 then
LDAPPort = LDAP_PORT_OFFSET + MemServerID
end if
if g_ErrorHandler then on error resume next
Set LdapCfg = MemCreateObj(MBS_OBJ_LDAPCFG)
LdapCfg.AttachToLocalMachine
RaiseOnError Wizard("LDAP_AttachFailed")
If Not IsErrorClear Then ' check status & leave on error
Exit Sub
End If
LdapCfg.CreateConfig MemServerID
RaiseOnError Wizard("LDAP_CreateFailed")
If Not IsErrorClear Then ' check status & leave on error
Exit Sub
End If
LdapCfg.LoadConfig MemServerID
LdapCfg.Port = LDAPPort
LdapCfg.DNSName = LDAPHost
LdapCfg.SaveConfig
RaiseOnError Wizard("LDAP_ConfigFailed")
end sub
'=============================================================================
' ConfigLDAPServer
'
sub ConfigLDAPServer( ByVal MemServerID, ByVal LDAPHost, ByVal LDAPPort, ByVal DSRootName, _
ByVal DBServer, ByVal Database, ByVal DBUser, ByVal DBPassword, _
ByVal DSAdminPassword )
if g_ErrorHandler then on error resume next
' === Check membership database and create it if necessary
WriteProgressMsg "Configuring membership database"
Dim bDBExists
bDBExists = false
Dim DSConfig
Set DSConfig = MemCreateObj(MBS_OBJ_SETUPSTORE)
DSConfig.CreateSQLDB DBServer, Database, DSRootName, DBUser, DBPassword, DSAdminPassword, True
if Err.number = &H800B10B9 then
Trace "Warning: Membership directory " & DSRootName & _
" already exists on server " & DBServer, True
Err.Clear
bDBExists = true
else
RaiseOnError Wizard("Mem_OpenDB")
end if
If Not IsErrorClear Then ' check status & leave on error
Exit Sub
End If
' === Config LDAP
WriteProgressMsg "Configuring LDAP instance"
Dim LdapCfg
Set LdapCfg = MemCreateObj(MBS_OBJ_LDAPCFG)
LdapCfg.AttachToLocalMachine
RaiseOnError Wizard("LDAPCfg_AttachFailed")
If Not IsErrorClear Then ' check status & leave on error
Exit Sub
End If
LdapCfg.LoadConfig MemServerID
LdapCfg.DBSource = DBServer
LdapCfg.DBName = Database
LdapCfg.DBUserName = DBUser
LdapCfg.DBPassword = DBPassword
LdapCfg.DBType = 1 ' SQL Server
LdapCfg.SetDirectoryProperties MemServerID, DSRootName, ""
LdapCfg.SaveConfig
RaiseOnError Wizard("LDAPCfg_ConfigFailed")
end sub
'=============================================================================
' CreateDMailServer
'
sub CreateDMailServer( ByVal MemServerID )
Dim DMailCfg
Set DMailCfg = MemCreateObj(MBS_OBJ_DMAILCFG)
DMailCfg.CreateInstance MemServerID
RaiseOnError Wizard("DMail_CreateFailed")
end sub
'=============================================================================
' UtilConfigMembershipServer
'
sub UtilConfigMembershipServer( ByVal MemServerID, ByVal LDAPHost, ByVal LDAPPort, ByVal DSRootName,_
ByVal DSAdminUser, ByVal DSAdminPassword )
' This subroutine (UtilConfigMembershipServer) is a hack that was necessary because
' the code in 'ConfigMembershipServer()' would not run correctly under ASP.
' For some reason (security?), the calls to 'CreatePMAccount()' failed when the script
' was run under ASP (IIS), while they worked correctly under WSH (CSCRIPT).
' This was solved by launching a separate CSCRIPT process from the ASP page,
' which then runs 'ConfigMembershipServer()' under ASP.
if g_ErrorHandler then on error resume next
if IsRunningInWSH() then
' call it the easy way, directly
ConfigMembershipServer MemServerID, LDAPHost, LDAPPort, DSRootName, "Administrator", _
DSAdminPassword
else ' running under ASP
' call it the hard way, indirectly using CSCRIPT.
' CSCRIPT will parse the command line and invoke 'DoConfigMembershipServer()' (see below)
Dim WscriptShell
set WscriptShell = Server.CreateObject("WScript.Shell")
Dim Command
Command = "C:\Winnt\System32\cscript.exe C:\WWWapps\Ee11_Install\Scripts\setup.vbs" & _
" config_memserver /mem_id:" & CStr(MemServerID) & _
" /ldaphost:" & LdapHost & " /ldapport:" & CStr(LdapPort) & _
" /dsrootname:""" & DSRootName & """ /dsadminpassword:" & DSAdminPassword & _
" /break_dbg:" & Switches("break_dbg")
Dim Status
Status = WscriptShell.Run(Command, 1, 1)
if Status <> 0 then
RaiseError Wizard("Mem_ConfigMem")
end if
end if
end sub
'=============================================================================
' DoConfigMembershipServer
'
sub DoConfigMembershipServer
' This subroutine (DoConfigMembershipServer) gets called as a result of the
' CSCRIPT command that is run from UtilConfigMembershipServer().
' Just get the command line parameters and call ConfigMembershipServer()
' to perform the work.
Trace "Configuring Membership server (separate CSCRIPT session) ..."
ConfigMembershipServer CInt(Switches("mem_id")), Switches("ldaphost"), _
CInt(Switches("ldapport")), Switches("dsrootname"), "Administrator", _
Switches("dsadminpassword")
end sub
'=============================================================================
' ConfigMembershipServer
'
sub ConfigMembershipServer( ByVal MemServerID, ByVal LDAPHost, ByVal LDAPPort, ByVal DSRootName,_
ByVal DSAdminUser, ByVal DSAdminPassword )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Configuring Active User Object"
' === STEP 1: Create default Membership groups
Dim DSPrep
set DSPrep = MemCreateObj(MBS_OBJ_DSPREP)
DSPrep.CreateDefaultGroups (LDAPHost), (LDAPPort), (DSAdminUser), (DSAdminPassword)
RaiseOnError Wizard("MemCfg_CreateGroups")
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
' === STEP 2: Create & configure primary AUO provider
Dim DSConfig
set DSConfig = MemCreateObj(MBS_OBJ_DSCFG)
' Separate AUO account is normally not necessary
''Dim AuoAcctName, AuoAcctPassword
''call DSConfig.CreatePMAccount( LDAPHost, LDAPPort, DSConfig.AUO_ACCOUNT, AuoAcctName, _
'' AuoAcctPassword, DSAdminUser, DSAdminPassword, MemServerID )
''RaiseOnError Wizard("MemCfg_CreateAuoAcct")
' Create & configure primary AUO provider
Dim AuoConfig
Set AuoConfig = MemCreateObj(MBS_OBJ_AUOCFG)
Dim Name, Path, Schema, Klass, Suffix, DepObject, DepProp, BindAsName, BindAsPassword
AuoConfig.GetInfo MemServerID
RaiseOnError Wizard("MemCfg_AuoGetInfo")
AuoConfig.GetEntry Name, Path, Schema, Klass, Suffix, DepObject, DepProp, _
BindAsName, BindAsPassword
' ignore errors because primary provider may not yet exist
Err.Clear
Path = "LDAP://" & LDAPHost & ":" & CStr(LDAPPort) & "/o=" & DSRootName & "/ou=members"
Schema = _
"LDAP://" & LDAPHost & ":" & CStr(LDAPPort) & "/o=" & DSRootName & "/cn=schema/cn=member"
Klass = "member"
Suffix = "1"
AuoConfig.SetEntry Name, Path, Schema, Klass, Suffix, DepObject, DepProp, "", "" 'AuoAcctName, AuoAcctPassword
AuoConfig.SetInfo
RaiseOnError Wizard("MemCfg_AuoSetEntry")
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
' === STEP 3: Create Broker acct. & configure broker (authentication) service
WriteProgressMsg "Configuring Broker service"
' make sure LDAP is started, otherwise the system won't be able to create the broker account
Dim LdapCfg
Set LdapCfg = MemCreateObj(MBS_OBJ_LDAPCFG)
LdapCfg.AttachToLocalMachine
LdapCfg.StopServer MemServerID
LdapCfg.StartServer MemServerID
RaiseOnError Wizard("MemCfg_StartLdap")
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
' create broker account
Dim BrkAcctName, BrkAcctPassword
DSConfig.CreatePMAccount LDAPHost, LDAPPort, DSConfig.BROKER_ACCOUNT, BrkAcctName, _
BrkAcctPassword, DSAdminUser, DSAdminPassword, MemServerID
RaiseOnError Wizard("MemCfg_CreateBrkAcct")
' configure broker (authentication) service
Dim BrokConfig
Set BrokConfig = MemCreateObj(MBS_OBJ_BROKCFG)
BrokConfig.GetConfig MemServerID
BrokConfig.bszDsName = "cn=" & BrkAcctName & ",ou=members,o=" & DSRootName
BrokConfig.bszDsPwd = BrkAcctPassword
' commit changes
BrokConfig.SetConfig
RaiseOnError Wizard("MemCfg_BrkSetConfig")
' stop/start broker svc
Dim BrokServers
Set BrokServers = MemCreateObj(MBS_OBJ_BROKSERVERS)
BrokServers.Init
BrokServers.StopServer MemServerID
BrokServers.StartServer MemServerID
' display & ignore errors
TraceOnError "Error starting membership server:"
If Not IsErrorClear Then ' check status & leave on error after each step
Exit Sub
End If
' === STEP 4: Create DMail acct. & configure DMail service
Dim DMAcctName, DMAcctPassword
DSConfig.CreatePMAccount LDAPHost, LDAPPort, DSConfig.DM_ACCOUNT, DMAcctName, _
DMAcctPassword, DSAdminUser, DSAdminPassword, MemServerID
' display & ignore errors
TraceOnError "Error creating direct mail account:"
Dim DmCfg
Set DmCfg = MemCreateObj(MBS_OBJ_DMAILCFG)
DmCfg.CurrentInstance = MemServerID
DmCfg.DSName = LDAPHost
DmCfg.LDAPPort = LDAPPort
DmCfg.DSAccount = "cn=" & DMAcctName & ",ou=members,o=" & DSRootName
DmCfg.DSPassword = DMAcctPassword
DmCfg.SaveConfig
' display & ignore errors
TraceOnError "Error configuring DMail server:"
' === STEP 5: set default ACLs
DSPrep.SetDefaultACLs (LDAPHost), (LDAPPort), (DSAdminUser), (DSAdminPassword)
' display & ignore errors
TraceOnError "Error setting default ACLs:"
end sub
'=============================================================================
' CreateSSAdminGroup
'
Sub CreateSSAdminGroup( ByVal WebInstance, ByVal DSAdminPassword )
' Create Membership group "SiteServer Administrators" and assign the Administrator user to it
if g_ErrorHandler then on error resume next
DisplayActionStart "CREATING SITESERVER ADMINISTRATORS GROUP"
TraceParameters Array("WebInstance", "DSAdminPassword"), _
Array(WebInstance, DSAdminPassword)
WriteProgressMsg "Creating SiteServer Administrators group"
SetDSAccountInfo WebInstance, "Administrator", DSAdminPassword
Dim AdminGroup
AdminGroup = GetSiteServerAdministratorsGroup("")
CreateDSGroupExt AdminGroup, "", "/ou=Groups/ou=NTGroups"
PrivateAddUserToGroupExt "Administrator", AdminGroup, "", "/ou=Groups/ou=NTGroups"
CreateDSGroupExt AdminGroup, "", "/ou=Groups/ou=NTGroups"
PrivateAddUserToGroupExt "baan", AdminGroup, "", "/ou=Groups/ou=NTGroups"
DisplayActionStart "CREATING SITESERVER ADMINISTRATORS GROUP"
End Sub
'=============================================================================
' CreateEEAdminGroup
'
Sub CreateEEAdminGroup( ByVal WebInstance, ByVal DSAdminPassword )
' Create Membership group "EE Local Administrators" and assign the Administrator user to it
if g_ErrorHandler then on error resume next
DisplayActionStart "CREATING EE LOCAL ADMINISTRATORS GROUP"
TraceParameters Array("WebInstance", "DSAdminPassword"), _
Array(WebInstance, DSAdminPassword)
WriteProgressMsg "Creating EE_Local_Administrators group"
SetDSAccountInfo WebInstance, "Administrator", DSAdminPassword
Dim AdminGroup
AdminGroup = "EE Local Administrators"
CreateDSGroupExt AdminGroup, "", "/ou=Groups/ou=NTGroups"
PrivateAddUserToGroupExt "Administrator", AdminGroup, "", "/ou=Groups/ou=NTGroups"
CreateDSGroupExt AdminGroup, "", "/ou=Groups/ou=NTGroups"
PrivateAddUserToGroupExt "baan", AdminGroup, "", "/ou=Groups/ou=NTGroups"
DisplayActionStart "CREATING EE LOCAL ADMINISTRATORS GROUP"
End Sub
'=============================================================================
' CreateSSContainer
'
Sub CreateSSContainer( ByVal WebInstance, ByVal DSAdminPassword )
' Create container
if g_ErrorHandler then on error resume next
DisplayActionStart "CREATING CONTAINER"
TraceParameters Array("WebInstance", "DSAdminPassword"), _
Array(WebInstance, DSAdminPassword)
WriteProgressMsg "Creating Container"
SetDSAccountInfo WebInstance, "Administrator", DSAdminPassword
CreateContainer "", "", ""
DisplayActionStart "CREATING CONTAINER IN MEMBERSHIP"
End Sub
'=============================================================================
' CreateSSClass
'
Sub CreateSSClass( ByVal WebInstance, ByVal DSAdminPassword )
' Create class
if g_ErrorHandler then on error resume next
DisplayActionStart "CREATING CLASS-SCHEMA"
TraceParameters Array("WebInstance", "DSAdminPassword"), _
Array(WebInstance, DSAdminPassword)
WriteProgressMsg "Creating ClassSchema"
SetDSAccountInfo WebInstance, "Administrator", DSAdminPassword
CreateClass "cn=Profile", "Profile", _
"Profile of an E-Enterprise user", Array("cn", "GUID"),_
Array ("EECatalogIDs","EEDashboardIDs","EERole","EFAQVisibility","locale",_
"languageID","ProfileGroupDNs"), "cn",_
"organizationalUnit", False, 0, False
DisplayActionStart "CREATING CLASS_SCHEMA IN MEMBERSHIP"
End Sub
'=============================================================================
' MemCreateObj
'
function MemCreateObj( ObjectId )
if g_ErrorHandler then on error resume next
set MemCreateObj = nothing
if (ObjectId = MBS_OBJ_LDAPCFG) or (ObjectId = MBS_OBJ_DSCFG) or _
(ObjectId = MBS_OBJ_DSPREP) then
' Nota Bene: use CreateObj(), NOT CreateObject().
' CreateObj() will invoke WScript.CreateObject() or Server.CreateObject(),
' depending on the environment that the script is running under.
' E.g. under ASP, Server.CreateObject() will be used. This will ensure that
' the object is created under the security crendentials of the ASP page. Otherwise,
' the object might not be created with sufficient permissions and might fail.
set MemCreateObj = CreateObj(ObjectId)
RaiseOnError Wizard("Mem_CreateObj")
else
Dim ObjCreator
set ObjCreator = CreateObject(MBS_OBJ_CREATOR)
if not IsObject(ObjCreator) then
RaiseError Wizard("Mem_CreateCreator")
else
RaiseOnError Wizard("Mem_CreateCreator")
set MemCreateObj = ObjCreator.CreateObjAuth(ObjectId)
if Err.Number <> 0 then
Trace "ObjCreator.CreateObjAuth fails, using CreateObject..."
Err.Clear
set MemCreateObj = CreateObject(ObjectId)
end if
RaiseOnError Wizard("Mem_CreateObjAuth")
end if
end if
end function
'=============================================================================
' SetDSAccountInfo
'
sub SetDSAccountInfo(ByVal instance, ByVal bstrDSAcctName, ByVal bstrDSAcctPwd)
call TrcEnter("SetDSAccountInfo")
call TrcValue("instance", instance)
call TrcValue("bstrDSAcctName", bstrDSAcctName)
call TrcValue("bstrDSAcctPwd", bstrDSAcctPwd)
if g_ErrorHandler then on error resume next
g_instance = instance
g_bstrDSAcctName = bstrDSAcctName
g_bstrDSAcctPwd = bstrDSAcctPwd
call TrcValue("g_instance", g_instance)
call TrcValue("g_bstrDSAcctName", g_bstrDSAcctName)
call TrcValue("g_bstrDSAcctPwd", g_bstrDSAcctPwd)
call TrcLeave("SetDSAccountInfo")
end sub
'=============================================================================
' DSAuthenticate
'
sub DSAuthenticate(ByVal bstrServer)
call TrcEnter("DSAuthenticate")
if g_ErrorHandler then on error resume next
dim bstrAdsRootPath
bstrAdsRootPath = GetAdsRootPath(g_instance, bstrServer)
if Err.number <> 0 then
' If GetAdsRoot/GetAdsRootPath fail (e.g. because of incorrect membership user name or
' password), it is often with the error "Object Required".
' Because this is a bit meaningless to the end user, we throw a more meaningful
' error message ourselves.
if InStr(LCase(Err.description),"object required") > 0 then
ClearError
RaiseError Wizard("CheckMemUser_LoginFailed")
end if
end if
call TrcValue("bstrAdsRootPath", bstrAdsRootPath)
RaiseOnError Wizard("DSAuthFailed")
call TrcLeave("DSAuthenticate")
end sub
'=============================================================================
' GenerateGuid
'
function GenerateGuid(ByVal bstrServer)
call TrcEnter("GenerateGuid")
dim oGuidGen
set oGuidGen = CreateRemoteObj("Membership.GuidGen.1", bstrServer)
call TrcObjValue("oGuidGen", oGuidGen)
GenerateGuid = oGuidGen.GenerateGuid
call TrcValue("GenerateGuid", GenerateGuid)
set oGuidGen = Nothing
call TrcLeave("GenerateGuid")
end function
'=============================================================================
' GetBrokConfig
'
function GetBrokConfig(ByVal instance, ByVal bstrServer)
call TrcEnter("GetBrokConfig")
call TrcValue("instance", instance)
if g_ErrorHandler then on error resume next
dim oObjCreator, oBrokServer, oBrokConfig
dim dsInstance, bstrComment
set oObjCreator = CreateObject("ObjCreator.ObjCreator.1")
if not IsObject(oObjCreator) then
MsgBox Wizard("DSCreateObjCreatorFailed")
end if
set oBrokServer = oObjCreator.CreateObjAuth("MemAdmin.BrokServers.1")
if not IsObject(oBrokServer) then
MsgBox Wizard("DSCreateBrokServerFailed")
end if
set oBrokConfig = oObjCreator.CreateObjAuth("MemAdmin.BrokConfig.1")
if not IsObject(oBrokConfig) then
MsgBox Wizard("DSCreateBrokConfigFailed")
end if
oBrokServer.MappedTo "W3SVC", CLng(instance), dsInstance, bstrComment
oBrokConfig.GetConfig dsInstance
set GetBrokConfig = oBrokConfig
set oObjCreator = Nothing
set oBrokServer = Nothing
call TrcLeave("GetBrokConfig")
end function
'=============================================================================
' GetLdapHostName
'
function GetLdapHostName(ByVal oBrokConfig)
call TrcEnter("GetLdapHostName")
if g_ErrorHandler then on error resume next
if CBool(oBrokConfig.bLocal) then
GetLdapHostName = CStr("localhost")
else
GetLdapHostName = CStr(oBrokConfig.bszServerName)
end if
call TrcValue("GetLdapHostName", GetLdapHostName)
call TrcLeave("GetLdapHostName")
end function
'=============================================================================
' GetLdapPort
'
function GetLdapPort(ByVal oBrokConfig)
call TrcEnter("GetLdapPort")
if g_ErrorHandler then on error resume next
GetLdapPort = CStr(oBrokConfig.lPort)
call TrcValue("GetLdapPort", GetLdapPort)
call TrcLeave("GetLdapPort")
end function
'=============================================================================
' GetAdsRootCtx
'
const kADS_NO_AUTHENTICATION = 16
function GetAdsRootCtx(ByVal bstrLdapHostName, ByVal bstrLdapPort)
call TrcEnter("GetAdsRootCtx")
call TrcValue("bstrLdapHostName", bstrLdapHostName)
call TrcValue("bstrLdapPort", bstrLdapPort)
if g_ErrorHandler then on error resume next
dim oAdsLdap
dim bstrAdsRootCtx
dim oAdsRootCtx
set oAdsLdap = GetObject("LDAP:")
call TrcObjValue("oAdsLdap", oAdsLdap)
bstrAdsRootCtx = "LDAP://" & bstrLdapHostName & ":" & bstrLdapPort & "/RootDSE"
call TrcValue("bstrAdsRootCtx", bstrAdsRootCtx)
set oAdsRootCtx = oAdsLdap.OpenDSObject(bstrAdsRootCtx, "", "", kADS_NO_AUTHENTICATION)
call TrcObjValue("oAdsRootCtx", oAdsRootCtx)
GetAdsRootCtx = oAdsRootCtx.Get("realm")
call TrcValue("GetAdsRootCtx", GetAdsRootCtx)
set oAdsRootCtx = Nothing
call TrcLeave("GetAdsRootCtx")
end function
'=============================================================================
' GetAdsRoot
'
function GetAdsRoot(ByVal bstrLdapPath, ByVal bstrAcctDN, bstrDSAcctPwd)
call TrcEnter("GetAdsRoot")
call TrcValue("bstrLdapPath", bstrLdapPath)
call TrcValue("bstrAcctDN", bstrAcctDN)
call TrcValue("bstrDSAcctPwd", bstrDSAcctPwd)
if g_ErrorHandler then on error resume next
dim oAdsLdap
set oAdsLdap = GetObject("LDAP:")
call TrcObjValue("oAdsLdap", oAdsLdap)
set GetAdsRoot = oAdsLdap.OpenDSObject(bstrLdapPath, bstrAcctDN, bstrDSAcctPwd, 0)
call TrcObjValue("GetAdsRoot", GetAdsRoot)
set oAdsLdap = Nothing
call TrcLeave("GetAdsRoot")
end function
'=============================================================================
' GetAdsRootPath
'
function GetAdsRootPath(ByVal instance, ByVal bstrServer)
call TrcEnter("GetAdsRootPath")
dim oBrokConfig, bstrLdapHostName, bstrLdapPort, bstrAdsRootCtx, bstrLdapPath, oAdsRoot
set oBrokConfig = GetBrokConfig(instance, bstrServer)
call TrcObjValue("oBrokConfig", oBrokConfig)
bstrLdapHostName = GetLdapHostName(oBrokConfig)
call TrcValue("bstrLdapHostName", bstrLdapHostName)
bstrLdapPort = GetLdapPort(oBrokConfig)
call TrcValue("bstrLdapPort", bstrLdapPort)
bstrAdsRootCtx = GetAdsRootCtx(bstrLdapHostName, bstrLdapPort)
call TrcValue("bstrAdsRootCtx", bstrAdsRootCtx)
bstrLdapPath = "LDAP://" & bstrLdapHostName
if Len(bstrLdapPort) > 0 then
bstrLdapPath = bstrLdapPath & ":" & bstrLdapPort
end if
bstrLdapPath = bstrLdapPath & "/o=" & bstrAdsRootCtx
call TrcValue("bstrLdapPath", bstrLdapPath)
g_bstrAcctDN = AUOUserToDN(g_bstrDSAcctName, bstrAdsRootCtx)
call TrcValue("g_bstrAcctDN", g_bstrAcctDN)
set oAdsRoot = GetAdsRoot(bstrLdapPath, g_bstrAcctDN, g_bstrDSAcctPwd)
call TrcObjValue("oAdsRoot", oAdsRoot)
GetAdsRootPath = oAdsRoot.adsPath
call TrcValue("GetAdsRootPath", GetAdsRootPath)
set oBrokConfig = Nothing
set oAdsRoot = Nothing
call TrcLeave("GetAdsRootPath")
end function
'=============================================================================
' AUOUserToDN
'
function AUOUserToDN(ByVal bstrAUOUser, ByVal bstrAdsRootCtx)
' ARGUMENTS:
' bstrAUOUser: username snagged from the login form
' bstrAdsRootCtx: name of root object in the directory, ie o=???
if g_ErrorHandler then on error resume next
dim iPos
dim bstrUserDN
dim bstrFolder
REM - reverse the AUOUser to a DN:
iPos = Instr(bstrAUOUser, "\")
do while (iPos > 0)
bstrFolder = Left(bstrAUOUser, iPos-1)
if Len(bstrFolder) > 0 then
if Len(bstrUserDN) > 0 then
bstrUserDN = "ou=" & Left(bstrAUOUser, iPos-1) & "," & bstrUserDN
else
bstrUserDN = "ou=" & Left(bstrAUOUser, iPos-1)
end if
end if
bstrAUOUser = Mid(bstrAUOUser, iPos+1)
iPos = Instr(bstrAUOUser, "\")
loop
REM - insert the user name:
if Len(bstrUserDN) > 0 then
bstrUserDN = "cn=" & bstrAUOUser & "," & bstrUserDN
else
bstrUserDN = "cn=" & bstrAUOUser
end if
REM - append the right zoning for the credentials:
bstrUserDN = bstrUserDN & ",ou=members,o=" & bstrAdsRootCtx
AUOUserToDN = bstrUserDN
end function
'=============================================================================
' GetLDAPObject
'
function GetLDAPObject(ByVal bstrTargetSubPath, ByVal bstrServer)
call TrcEnter("GetLDAPObject")
call TrcValue("bstrTargetSubPath", bstrTargetSubPath)
call TrcValue("g_instance", g_instance)
call TrcValue("g_bstrDSAcctName", g_bstrDSAcctName)
call TrcValue("g_bstrDSAcctPwd", g_bstrDSAcctPwd)
call TrcValue("g_bstrAcctDN", g_bstrAcctDN)
call TrcValue("g_bstrAdsRootPath", g_bstrAdsRootPath)
if g_ErrorHandler then on error resume next
dim bstrTargetPath, oAdsLdap
if g_bstrAdsRootPath = "" then
g_bstrAdsRootPath = GetAdsRootPath(g_instance, bstrServer)
end if
call TrcValue("g_bstrAdsRootPath", g_bstrAdsRootPath)
bstrTargetPath = g_bstrAdsRootPath & bstrTargetSubPath
call TrcValue("bstrTargetPath", bstrTargetPath)
set oAdsLdap = GetObject("LDAP:")
call TrcObjValue("oAdsLdap", oAdsLdap)
set GetLDAPObject = oAdsLdap.OpenDSObject(bstrTargetPath, g_bstrAcctDN, g_bstrDSAcctPwd, 0)
call TrcObjValue("GetLDAPObject", GetLDAPObject)
call TrcValue("GetLDAPObject.adsPath", GetLDAPObject.adsPath)
set oAdsLdap = Nothing
RaiseOnError Wizard("GetLDAPObjectFailed")
call TrcLeave("GetLDAPObject")
end function
'=============================================================================
' GetDSSiteGroup
'
function GetDSSiteGroup(ByVal instance, ByVal bstrSiteName)
call TrcEnter("GetDSSiteGroup")
GetDSSiteGroup = bstrSiteName & "_" & CStr(instance)
call TrcValue("GetDSSiteGroup", GetDSSiteGroup)
call TrcLeave("GetDSSiteGroup")
end function
'=============================================================================
' GetDSPrefix
'
Function GetDSPrefix(ByVal instance, ByVal bstrServer)
call TrcEnter("GetDSPrefix")
call TrcValue("instance", instance)
call TrcValue("bstrServer", bstrServer)
if g_ErrorHandler then on error resume next
dim bIsMembership
dim oBrokConfig
bIsMembership = CBool(IsMembership(instance, bstrServer))
call TrcValue("bIsMembership", bIsMembership)
if bIsMembership then
set oBrokConfig = GetBrokConfig(instance, bstrServer)
call TrcValue("GetBrokConfig Err.Number", Err.Number)
call TrcObjValue("oBrokConfig", oBrokConfig)
call TrcValue("oBrokConfig.bszGroupPrefix", oBrokConfig.bszGroupPrefix)
GetDSPrefix = oBrokConfig.bszGroupPrefix
set oBrokConfig = Nothing
else
GetDSPrefix = ""
end if
Err.Clear
call TrcValue("GetDSPrefix", GetDSPrefix)
call TrcLeave("GetDSPrefix")
End Function
'=============================================================================
' PrivateGetOrg
'
Function PrivateGetOrg(ByVal bstrServer)
call TrcEnter("PrivateGetOrg")
call TrcValue("g_instance", g_instance)
dim oBrokConfig, bstrLdapHostName, bstrLdapPort
set oBrokConfig = GetBrokConfig(g_instance, bstrServer)
call TrcObjValue("oBrokConfig", oBrokConfig)
bstrLdapHostName = GetLdapHostName(oBrokConfig)
call TrcValue("bstrLdapHostName", bstrLdapHostName)
bstrLdapPort = GetLdapPort(oBrokConfig)
call TrcValue("bstrLdapPort", bstrLdapPort)
PrivateGetOrg = GetAdsRootCtx(bstrLdapHostName, bstrLdapPort)
call TrcValue("PrivateGetOrg", PrivateGetOrg)
set oBrokConfig = Nothing
call TrcLeave("PrivateGetOrg")
End Function
'=============================================================================
' PrivateAddUserToGroup
'
Sub PrivateAddUserToGroup(ByVal bstrChild, ByVal bstrParent, ByVal bstrServer)
call TrcEnter("PrivateAddUserToGroup")
call TrcValue("bstrChild", bstrChild)
call TrcValue("bstrParent", bstrParent)
if g_ErrorHandler then on error resume next
PrivateAddUserToGroupExt bstrChild, bstrParent, bstrServer, "/ou=groups"
call TrcLeave("PrivateAddUserToGroup")
End Sub
'=============================================================================
' PrivateAddUserToGroupExt
'
Sub PrivateAddUserToGroupExt(ByVal bstrChild, ByVal bstrParent, ByVal bstrServer, _
ByVal bstrGroupContainer)
call TrcEnter("PrivateAddUserToGroupExt")
call TrcValue("bstrChild", bstrChild)
call TrcValue("bstrParent", bstrParent)
call TrcValue("bstrGroupContainer", bstrGroupContainer)
if g_ErrorHandler then on error resume next
dim oAdsContainer, bstrMemberObjPath, oAdsMemberOf
set oAdsContainer = GetLDAPObject(bstrGroupContainer & "/cn=" & bstrParent, bstrServer)
call TrcObjValue("oAdsContainer", oAdsContainer)
bstrMemberObjPath = Format2("cn=%1,ou=members,o=%2", bstrChild, PrivateGetOrg(bstrServer))
call TrcValue("bstrMemberObjPath", bstrMemberObjPath)
set oAdsMemberOf = oAdsContainer.Create("memberof", "cn=" & GenerateGuid(bstrServer))
call TrcObjValue("oAdsMemberOf", oAdsMemberOf)
oAdsMemberOf.Put "memberobject", (bstrMemberObjPath)
oAdsMemberOf.SetInfo
if &h800700B7 = Err.Number then
Err.Clear
end if
RaiseOnError Format2(Wizard("PrivateAddUserToGroupFailed"), bstrChild, bstrParent)
call TrcLeave("PrivateAddUserToGroupExt")
End Sub
'=============================================================================
' PrivateAddGroupToGroupCommon
'
Sub PrivateAddGroupToGroupCommon(ByVal bstrChild, ByVal oAdsParent, ByVal bstrServer)
call TrcEnter("PrivateAddGroupToGroupCommon")
call TrcObjValue("oAdsParent", oAdsParent)
call TrcValue("oAdsParent.adsPath", oAdsParent.adsPath)
call TrcValue("bstrChild", bstrChild)
if g_ErrorHandler then on error resume next
dim bstrChildDN
dim bstrGuidDN
dim oAdsChild
bstrChildDN = Format2("cn=%1,ou=groups,o=%2", bstrChild, PrivateGetOrg(bstrServer))
bstrChildDN = CStr(bstrChildDN)
call TrcValue("bstrChildDN", bstrChildDN)
bstrGuidDN = "cn=" & GenerateGuid(bstrServer)
call TrcValue("bstrGuidDN", bstrGuidDN)
set oAdsChild = oAdsParent.Create("GroupMemberOf", bstrGuidDN)
call TrcValue("oAdsParent.Create Err.Number", Err.Number)
call TrcObjValue("oAdsChild", oAdsChild)
call TrcValue("oAdsChild.adsPath", oAdsChild.adsPath)
oAdsChild.Put "groupObject", (bstrChildDN)
call TrcValue("oAdsChild.Put Err.Number", Err.Number)
oAdsChild.SetInfo
call TrcValue("oAdsChild.SetInfo Err.Number", Err.Number)
if &h800700B7 = Err.Number then
Err.Clear
end if
RaiseOnError Wizard("PrivateAddGroupToGroupFailed")
call TrcLeave("PrivateAddGroupToGroupCommon")
End Sub
'=============================================================================
' PrivateAddGroupToGroup
'
Sub PrivateAddGroupToGroup(ByVal bstrChild, ByVal bstrParent, ByVal bstrServer)
call TrcEnter("PrivateAddGroupToGroup")
call TrcValue("bstrParent", bstrParent)
call TrcValue("bstrChild", bstrChild)
if g_ErrorHandler then on error resume next
dim oAdsParent
set oAdsParent = GetLDAPObject("/ou=groups/cn=" & bstrParent, bstrServer)
call TrcObjValue("oAdsParent", oAdsParent)
call TrcValue("oAdsParent.adsPath", oAdsParent.adsPath)
call PrivateAddGroupToGroupCommon(bstrChild, oAdsParent, bstrServer)
call TrcLeave("PrivateAddGroupToGroup")
End Sub
'=============================================================================
' PrivateAddGroupToNTGroup
'
Sub PrivateAddGroupToNTGroup(ByVal bstrChild, ByVal bstrParent, ByVal bstrServer)
call TrcEnter("PrivateAddGroupToNTGroup")
call TrcValue("bstrParent", bstrParent)
call TrcValue("bstrChild", bstrChild)
if g_ErrorHandler then on error resume next
dim oAdsParent
set oAdsParent = GetLDAPObject("/ou=groups/ou=NTGroups/cn=" & bstrParent, bstrServer)
call TrcObjValue("oAdsParent", oAdsParent)
call TrcValue("oAdsParent.adsPath", oAdsParent.adsPath)
call PrivateAddGroupToGroupCommon(bstrChild, oAdsParent, bstrServer)
call TrcLeave("PrivateAddGroupToNTGroup")
End Sub
'=============================================================================
' CreateDSGroup
'
Sub CreateDSGroup(ByVal bstrGroupName, ByVal bstrServer)
call TrcEnter("CreateDSGroup")
call TrcValue("bstrGroupName", bstrGroupName)
if g_ErrorHandler then on error resume next
CreateDSGroupExt bstrGroupName, bstrServer, "/ou=groups"
call TrcLeave("CreateDSGroup")
End Sub
'=============================================================================
' CreateDSGroupExt
'
Sub CreateDSGroupExt(ByVal bstrGroupName, ByVal bstrServer, ByVal bstrGroupContainer)
call TrcEnter("CreateDSGroupExt")
call TrcValue("bstrGroupName", bstrGroupName)
call TrcValue("bstrGroupContainer", bstrGroupContainer)
if g_ErrorHandler then on error resume next
dim oAdsGroupContainer, oAdsGroup
set oAdsGroupContainer = GetLDAPObject(bstrGroupContainer, bstrServer)
call TrcObjValue("oAdsGroupContainer", oAdsGroupContainer)
set oAdsGroup = oAdsGroupContainer.Create("mgroup", "cn=" & bstrGroupName)
call TrcObjValue("oAdsGroup", oAdsGroup)
oAdsGroup.SetInfo
if &h800700B7 = Err.Number then
Err.Clear
end if
RaiseOnError Format1(Wizard("CreateDSGroupFailed"), bstrGroupName)
call TrcLeave("CreateDSGroupExt")
End Sub
'=============================================================================
' CreateContainer
'
Sub CreateContainer(ByVal bstrGroupName, ByVal bstrServer, ByVal bstrGroupContainer)
call TrcEnter("CreateContainer")
call TrcValue("bstrGroupName", bstrGroupName)
call TrcValue("bstrGroupContainer", bstrGroupContainer)
if g_ErrorHandler then on error resume next
dim oAdsGroupContainer, oAdsGroup
set oAdsGroupContainer = GetLDAPObject(bstrGroupContainer, bstrServer)
call TrcObjValue("oAdsGroupContainer", oAdsGroupContainer)
WriteProgressMsg "Creating organizationalUnit"
Set oAdsGroup = oAdsGroupContainer.Create("organizationalUnit", "ou=Profiles")
call TrcObjValue("oAdsGroup", oAdsGroup)
oAdsGroup.SetInfo
if &h800700B7 = Err.Number then
Err.Clear
end if
RaiseOnError Format1(Wizard("CreateContainerFailed"), bstrGroupName)
call TrcLeave("CreateContainer")
End Sub
'=============================================================================
' CreateDSManagerGroup
'
Sub CreateDSManagerGroup(ByVal instance, ByVal bstrSiteName, ByVal bstrServer)
call TrcEnter("CreateDSManagerGroup")
call TrcValue("bstrSiteName", bstrSiteName)
if g_ErrorHandler then on error resume next
dim bstrDSOperatorsGroup
dim bstrDSManagerGroup
bstrDSOperatorsGroup = GetManagerGroup( bstrServer )
call TrcValue("bstrDSOperatorsGroup", bstrDSOperatorsGroup)
bstrDSManagerGroup = GetDSSiteGroup(instance, bstrSiteName)
call TrcValue("bstrDSManagerGroup", bstrDSManagerGroup)
call CreateDSGroup(bstrDSManagerGroup, bstrServer)
' Add Group relationship:
call PrivateAddGroupToGroup("AdminGroup", bstrDSManagerGroup, bstrServer)
call PrivateAddGroupToNTGroup(bstrDSManagerGroup, bstrDSOperatorsGroup, bstrServer)
RaiseOnError Wizard("CreateDSManagerGroupFailed")
call TrcLeave("CreateDSManagerGroup")
End Sub
'=============================================================================
' CreateDSUser
'
Sub CreateDSUser(ByVal bstrAccount, ByVal bstrPassword, ByVal bstrServer)
call TrcEnter("CreateDSUser")
call TrcValue("bstrAccount", bstrAccount)
call TrcValue("bstrPassword", bstrPassword)
if g_ErrorHandler then on error resume next
dim oAdsMemberContainer, oAdsUser
set oAdsMemberContainer = GetLDAPObject("/ou=members", bstrServer)
call TrcObjValue("oAdsMemberContainer", oAdsMemberContainer)
set oAdsUser = oAdsMemberContainer.Create("member", "cn=" & bstrAccount)
call TrcObjValue("oAdsUser", oAdsUser)
oAdsUser.Put "GUID", GenerateGuid(bstrServer)
oAdsUser.Put "userPassword", (bstrPassword)
oAdsUser.SetInfo
if Err.number = &h80071392 then
TraceOnError "User " & bstrAccount & " already exists"
end if
if &h800700B7 = Err.Number then
Err.Clear
end if
RaiseOnError Format1(Wizard("CreateDSUserFailed"), bstrAccount)
call TrcLeave("CreateDSUser")
End Sub
'=============================================================================
' InitForMembership
'
const kBrokAuthTypeAnon = &H0001
const kBrokAuthTypePwdCookie = &H0002
const kBrokAuthTypeBasic = &H0004
const kBrokAuthTypeDPA = &H0008
const kIISAuthTypeAllowAnon = &H0010
const kIISAuthTypeEnableCerts = &H0020
const kIISAuthTypeRequireCerts = &H0040
const kBrokAuthTypeMapCerts = &H0080
sub InitForMembership(ByVal instance, ByVal bstrSiteName, ByVal bstrDestDir, ByVal bstrServer)
call TrcEnter("InitForMembership")
if g_ErrorHandler then on error resume next
dim oAdminFiles
set oAdminFiles = CreateRemoteObj("Commerce.AdminFiles", bstrServer)
oAdminFiles.CreateDirectory bstrDestDir + "\Member"
dim oObjCreator, oBrokServers
set oObjCreator = CreateObject("ObjCreator.ObjCreator.1")
if not IsObject(oObjCreator) then
MsgBox Wizard("InitForMembershipCreateObjCreatorFailed")
end if
'set BrokServers = CreateRemoteObj("MemAdmin.BrokServers.1", bstrServer)
set oBrokServers = oObjCreator.CreateObjAuth("MemAdmin.BrokServers.1")
if not IsObject(oBrokServers) then
MsgBox Wizard("InitForMembershipCreateBrokServerFailed")
end if
call oBrokServers.Init()
Dim bstrPath, bstrPathMember, bstrPathManager, bstrPathAspPE, bstrPathSBW
bstrPath = Format2("/LM/W3SVC/%1/Root/%2", instance, bstrSiteName)
bstrPathMember = Format1("%1/Member", bstrPath)
bstrPathManager = Format1("%1/Manager", bstrPath)
bstrPathAspPE = Format1("%1/Manager/MSCS_PipeEdit", bstrPath)
bstrPathSBW = Format1("%1/Manager/MSCS_CommerceSiteBuilderWizard", bstrPath)
oBrokServers.SetAuthTypes bstrPath, kIISAuthTypeAllowAnon
oBrokServers.SetAuthTypes bstrPathMember, kBrokAuthTypePwdCookie
oBrokServers.SetAuthTypes bstrPathManager, kBrokAuthTypeBasic Or kBrokAuthTypeDPA
oBrokServers.SetAuthTypes bstrPathAspPE, kBrokAuthTypeBasic Or kBrokAuthTypeDPA
oBrokServers.SetAuthTypes bstrPathSBW, kBrokAuthTypeBasic Or kBrokAuthTypeDPA
call TrcLeave("InitForMembership")
end sub
'=============================================================================
' CreateTextConstraint
'
Function CreateTextConstraint(ByVal MinLen, ByVal MaxLen)
call TrcEnter("CreateTextConstraint")
CreateTextConstraint = Format2("(C:%1:%2)", CStr(MinLen), CStr(MaxLen))
call TrcLeave("CreateTextConstraint")
End Function
'=============================================================================
' AddSchemaAttribute
'
Sub AddSchemaAttribute(ByVal bstrAttrName, ByVal AttrType, ByVal SingleValued, _
ByVal Searchable, ByVal Description, _
ByVal Constraint, ByVal bstrDisplayName, _
ByVal bstrServer)
call TrcEnter("AddSchemaAttribute")
if g_ErrorHandler then on error resume next
dim oAdsSchemaContainer, oAdsSchemaAttribute
set oAdsSchemaContainer = GetLDAPObject("/ou=Admin/cn=Schema", bstrServer)
set oAdsSchemaAttribute = oAdsSchemaContainer.Create("attributeSchema", "cn=" & bstrAttrName )
oAdsSchemaAttribute.Put "attributeSyntax", Array(AttrType)
oAdsSchemaAttribute.Put "isSingleValued", CInt(SingleValued)
oAdsSchemaAttribute.Put "isSearchable", CInt(Searchable)
if Len(Description) > 0 then
oAdsSchemaAttribute.Put "description", Array(Description)
end if
if Len(Constraint) > 0 then
oAdsSchemaAttribute.Put "syntaxConstraints", Array(Constraint)
end if
if Len(bstrDisplayName) > 0 then
oAdsSchemaAttribute.Put "displayName", Array(bstrDisplayName)
else
oAdsSchemaAttribute.Put "displayName", Array(bstrAttrName)
end if
oAdsSchemaAttribute.SetInfo
if Err.Number = &h800700B7 then ' Already exists ignore
Err.Clear
end if
if Err.Number = &h80071392 then ' Already exists?? - ignore
Trace "AddSchemaAttribute - attribute already exists"
Err.Clear
end if
RaiseOnError Format1(Wizard("AddSchemaAttributeFailed"), bstrAttrName)
call TrcLeave("AddSchemaAttribute")
End Sub
'============================================================================
' AddOptionalAttributeToClass
'
Sub AddOptionalAttributeToClass(ByVal bstrSchema, ByVal bstrNewAttr, ByVal bstrServer)
call TrcEnter("AddOptionalAttributeToClass")
if g_ErrorHandler then on error resume next
dim oAdsSchemaContainer, oAdsSchemaClass, rgbstrMayContains
set oAdsSchemaContainer = GetLDAPObject("/ou=Admin/cn=Schema", bstrServer)
set oAdsSchemaClass = oAdsSchemaContainer.GetObject("classSchema", "cn=" & bstrSchema)
rgbstrMayContains = oAdsSchemaClass.GetEx("mayContain")
dim bItemFound, bstrItem
bItemFound = False
for each bstrItem in rgbstrMayContains
bItemFound = bItemFound Or (bstrItem = bstrNewAttr)
next
if not bItemFound then
dim nTotal
nTotal = UBound(rgbstrMayContains) - LBound(rgbstrMayContains)
redim Preserve rgbstrMayContains( nTotal + 1 )
rgbstrMayContains(nTotal + 1) = bstrNewAttr
oAdsSchemaClass.Put "mayContain", ( rgbstrMayContains )
oAdsSchemaClass.SetInfo
end if
RaiseOnError Format1(Wizard("AddOptionalAttributeToClassFailed"), bstrNewAttr)
call TrcLeave("AddOptionalAttributeToClass")
End Sub
'========================================================================
' AddMembershipAttributes
'
Sub AddMembershipAttributes( ByVal WebsiteID, ByVal DSAdminPassword, ByVal MemAttribs )
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "ADD MEMBERSHIP ATTRIBUTES"
TraceParameters Array("WebsiteID", "DSAdminPassword", "MemAttribs"), _
Array(WebsiteID, DSAdminPassword, MemAttribs)
SetDSAccountInfo WebsiteID, "Administrator", DSAdminPassword
if not IsMembership(WebsiteID,"") then
RaiseError Format1(Wizard("MemAttr_MembRequired"),WebsiteID)
end if
if not IsErrorClear() then
exit sub
end if
Dim Attrib, AttrName, AttrType, AttrMulti, AttrSingle, AttrDisplayName, AttrDesc
for each AttrName in MemAttribs
Attrib = MemAttribs(AttrName)
AttrType = Attrib(0)
AttrMulti = Attrib(1)
if AttrMulti = 0 then
AttrSingle = "1"
else
AttrSingle = "0"
end if
AttrDisplayName = Attrib(2)
AttrDesc = Attrib(3)
Trace "** Add attribute " & CStr(AttrName)
AddSchemaAttribute AttrName, AttrType, AttrSingle, "0", AttrDesc, "", AttrDisplayName, ""
AddOptionalAttributeToClass "member", AttrName, ""
TraceOnError "Error adding Membership attribute"
' Proceed with next attribute, even if this attribute fails
''if not IsErrorClear() then
'' exit sub
''end if
next
DisplayActionFinish "ADD MEMBERSHIP ATTRIBUTES"
End Sub
'========================================================================
' AddMembershipUser
'
Sub AddMembershipUser( ByVal WebsiteID, ByVal DSAdminPassword, _
ByVal UserID, ByVal Password, ByVal UserAttribs, ByVal MemScriptUser )
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "ADD MEMBERSHIP USER"
TraceParameters _
Array("WebsiteID", "DSAdminPassword", "UserID", "Password", "UserAttribs", "MemScriptUser"), _
Array(WebsiteID, DSAdminPassword, UserID, Password, UserAttribs, MemScriptUser)
SetDSAccountInfo WebsiteID, "Administrator", DSAdminPassword
if not IsMembership(WebsiteID,"") then
RaiseError Format1(Wizard("UserAttr_MembRequired"),WebsiteID)
end if
if not IsErrorClear() then
exit sub
end if
if not Defined(Password) then
Password = ""
end if
' For MemScriptUser, the password is not supplied but must be fetched here
if Defined(MemScriptUser) then
if MemScriptUser <> "" and LCase(MemScriptUser) = "y" then
WriteProgressMsg "Retrieving mem script code ..."
GetMemScriptUserPassword Password
if not IsErrorClear() then
Trace "Could not get password for MemScript user: user not added"
exit sub
end if
end if
end if
WriteProgressMsg "Adding membership user " & UserID & "..."
CreateDSUser UserID, Password, ""
if not IsEmpty( UserAttribs ) then
' == Add user attributes
WriteProgressMsg "Setting membership attributes for user " & User
Dim Members, User
Set Members = GetLDAPObject("/ou=members", "")
Set User = Members.GetObject("member", "cn=" & UserID)
RaiseOnError Wizard("UserAttr_CannotGetUser")
Dim AttrName, AttrValues
for each AttrName in UserAttribs
Trace "Attribute: "& AttrName
AttrValues = UserAttribs(AttrName)
if UBound(AttrValues) > 0 then
User.PutEx 2, AttrName, (AttrValues)
else
User.Put AttrName, (AttrValues(0))
end if
RaiseOnError Format1(Wizard("UserAttr_CannotSetAttr"),AttrName)
next
User.SetInfo
RaiseOnError Wizard("UserAttr_CannotSaveUser")
end if
DisplayActionFinish "ADD MEMBERSHIP USER"
End Sub
' Registry key where to store the MemScriptUser password
Const REGKEY_MEMSCRIPTCODE = "HKLM\SOFTWARE\Baan\Baan E-Enterprise 1.1\MemScriptCode"
Const REGKEY_MEMSCRIPTCODE2 = "HKLM\SOFTWARE\Baan\Baan E-Enterprise\MemScriptCode"
'========================================================================
' GetMemScriptUserPassword
'
Sub GetMemScriptUserPassword( ByRef Password )
if g_ErrorHandler then on error resume next
Trace "Fetch MemScriptUser password"
Password = ""
MetaGetGlobalParamValue "MemScriptCode", Password
' If password could not be fetched, generate it and store it in the metabase
if Password = "" then
Trace "Generate new MemScriptUser password"
Password = GenerateGuid("")
MetaSetGlobalParamValue "MemScriptCode", Password
end if
' Now store it in the Registry under the E-Enterprise key
Dim Reg
Set Reg = GetWshShell()
' Try to read from the "new" E-Enterprise key (E-Enterprise 2.0), if that fails,
' use the old registry key
Dim Value, RegKey
Value = Reg.RegRead( REGKEY_BASE2 & "\InstallDir" )
if Err.number = 0 then
RegKey = REGKEY_MEMSCRIPTCODE2
Trace "Using Reg.Key E-Enterprise 2.0"
else
RegKey = REGKEY_MEMSCRIPTCODE
Trace "Using Reg.Key E-Enterprise 1.1"
end if
Err.Clear
Reg.RegWrite RegKey, Password
End Sub
'========================================================================
' SetMemAuthMethods
'
Sub SetMemAuthMethods( ByVal WebsiteID, ByVal MemAuthEntries, ByVal WebSiteName )
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "SET MEMBERSHIP AUTHENTICATION METHODS"
TraceParameters Array("WebsiteID", "MemAuthEntries", "WebSiteName"), Array(WebsiteID, MemAuthEntries, WebSiteName)
Dim URL, LdapPath, MemAuth, AuthMethod
Dim BrokServers
Set BrokServers = MemCreateObj(MBS_OBJ_BROKSERVERS)
RaiseOnError Wizard("MemAuth_Init")
if not IsMembership(WebsiteID,"") then
RaiseError Format1(Wizard("MemAuth_MembRequired"),WebsiteID)
end if
if not IsErrorClear() then
exit sub
end if
' Iterate the list of URLs
for each URL in MemAuthEntries
' Authentication settings for this URL
MemAuth = MemAuthEntries(URL)
' If there are any security settings for this URL
if not IsEmpty(MemAuth) then
' == Set Membership Authentication method on the URL
if MemAuth(0) <> 0 then ' Memb. auth. specified
''LdapPath = "/LM/W3SVC/" & WebsiteID & "/ROOT/" & URL
LdapPath = "/LM/W3SVC/" & WebsiteID & "/ROOT/" & WebSiteName & "/" & URL
if MemAuth(0) = 2 then ' anonymous
AuthMethod = 2 + 16 ' Forms login OR'ed with Allow Anonymous
else ' forms login
AuthMethod = 2 ' Forms login
end if
Trace "Set authentication method " & CStr(AuthMethod) & " on " & LdapPath
BrokServers.SetAuthTypes LdapPath, AuthMethod
RaiseOnError Format1(Wizard("MemAuth_SetAuthMethod"),LdapPath)
end if
' Proceed with next URL, even if this one fails
''if not IsErrorClear() then
'' exit sub
''end if
end if
next
DisplayActionFinish "SET MEMBERSHIP AUTHENTICATION METHODS"
End Sub
'========================================================================
' SetIISPermissions
'
Sub SetIISPermissions( ByVal WebsiteID, ByVal MemAuthEntries, ByVal WebSiteName)
If g_ErrorHandler Then On Error Resume Next
DisplayActionStart "SET IIS PERMISSIONS"
TraceParameters Array("WebsiteID", "MemAuthEntries", "WebSiteName"), Array(WebsiteID, MemAuthEntries, WebSiteName)
Dim URL, MemAuth
Dim IISPermission, IISAdminObj
' Get root container object of the home directory of this web site,
' which allows us to retrieve or create IIS admin objects for the paths under this root.
'
' IIS admin objects are loaded from and saved to the IIS Metabase and contain settings
' (e.g. permissions) for IIS paths.
Dim IISPath
IISPath = "IIS://LocalHost/w3svc/" & WebsiteID & "/ROOT"
Dim IISRoot
Set IISRoot = GetObject(IISPath)
RaiseOnError Format1(Wizard("IISPerm_GetRootObj"),IISPath)
if not IsErrorClear() then
exit sub
end if
''' Initialize Windows NT security object with permission "Full Control for group Everyone"
''' which is to be granted to the specified folders
''Dim Security
''Set Security = CreateObj("Commerce.AdminSecurity")
''Security.AddPermission Wizard("SecureSiteEveryone"), &h001F01FF
''
''TraceOnError Wizard("NTPerm_InitSecurity")
' Iterate the list of URLs
for each URL in MemAuthEntries
' Authentication settings for this URL
MemAuth = MemAuthEntries(URL)
' If there are any security settings for this URL
if not IsEmpty(MemAuth) then
' == Set IIS permissions on the URL
if MemAuth(1) <> 0 then ' IIS permission specified
IISPermission = MemAuth(1)
Trace "Set IIS permissions " & CStr(IISPermission) & " on " & WebSiteName & "/" & URL
Set IISAdminObj = IISRoot.GetObject("IIsWebDirectory",WebSiteName & "/" & URL)
' If there is not yet an IIS admin object for this URL (because we haven't yet
' specified any permissions or other settings for this URL), we must create it
if Err.number = &h80070003 then
Err.Clear
Trace "Creating IIS admin object for URL " & WebSiteName & "/" & URL
Set IISAdminObj = IISRoot.Create("IIsWebDirectory",WebSiteName & "/" & URL)
end if
RaiseOnError Format1(Wizard("IISPerm_GetIISObj"),WebSiteName & "/" & URL)
' 1 = read
' 2 = write
' 3 = execute
' 4 = execute & write
' 5 = script
' 6 = script & write
' First, clear all permissions
IISAdminObj.Put "AccessRead", false
IISAdminObj.Put "AccessWrite", false
IISAdminObj.Put "AccessExecute", false
IISAdminObj.Put "AccessScript", true
' Then, add only the selected ones
IISAdminObj.Put "AccessRead", true
if IISPermission = 2 or IISPermission = 4 then
IISAdminObj.Put "AccessWrite", true
end if
if IISPermission = 3 or IISPermission = 4 then
IISAdminObj.Put "AccessExecute", true
end if
if IISPermission = 5 then
IISAdminObj.Put "AccessScript", false
end if
if IISPermission = 6 then
IISAdminObj.Put "AccessWrite", true
IISAdminObj.Put "AccessScript", false
end if
' Save to IIS Metabase
IISAdminObj.SetInfo
RaiseOnError Format1(Wizard("IISPerm_SetIISObj"),WebSiteName & "/" & URL)
'' Set NT permissions on the physical directory to which the URL maps.
'' For now, we simple grant NT permission "Full Control" if IIS Write and or Execute
'' permission is specified
'if IISPermission <> 1 then
' ' Get full path to the URL's physical directory
' Path = AppPath & "\" & Replace(&URL, "/", "\")
'
' Trace "Set NT permissions on " & Path
'
' Security.WriteSecurityDirectory Path, True
' RaiseOnError Format1(Wizard("NTPerm_SetSecurity",Path)
'
' ' Write changes to the metabase (?)
' ''Security.WriteSecurityMetabase Format2("W3SVC/%1/ROOT/%2", WebsiteID, URL), True
' ''RaiseOnError Format1(Wizard("NTPerm_SaveSecurity",URL)
'end if
end if
' Proceed with next URL, even if this one fails
''if not IsErrorClear() then
'' exit sub
''end if
end if
next
DisplayActionFinish "SET IIS PERMISSIONS"
End Sub
'#############################################################################
'# Installation Metabase
'#############################################################################
' DSN string for accessing the Installation Metabase
Const DSN_METABASE = "DSN=EEMetabase;UID=WWWappsMetabase;PWD=;"
'========================================================================
' MetaGetGlobalParamValue
'
Sub MetaGetGlobalParamValue( ByVal ParamName, ByRef ParamValue )
if g_ErrorHandler then on error resume next
Trace "Fetching value of global parameter " & ParamName
ParamValue = ""
Dim Conn, ConnString
Set Conn = CreateObj("ADODB.Connection")
ConnString = DSN_METABASE
Conn.Open ConnString
' Check error
RaiseOnError Wizard("ExecQuery_LoginFailed")
if IsErrorClear() then
Dim Query, Count, RecordSet
' Fetch value for parameter out of metabase table GLOBALPARAMETER
Query = "SELECT * FROM GLOBALPARAMETER WHERE PARAMNAME='" & ParamName & "'"
Set RecordSet = Conn.Execute( Query, Count )
RaiseOnError Format2(Wizard("ExecQuery_ExecFailed"),Query,ConnString)
if IsErrorClear() then
' Fetch first row out of recordset
if RecordSet.EOF then
Trace "Resultset is empty"
else
Dim Value
Value = RecordSet("PARAMVALUE")
RaiseOnError Format1(Wizard("ExecQuery_FieldGetFailed"),"PARAMVALUE")
if IsErrorClear() and not IsNull(Value) then
Trace "Value of global parameter is " & Value
ParamValue = Value
end if
end if
end if
Conn.Close
end if
End Sub
'========================================================================
' MetaSetGlobalParamValue
'
Sub MetaSetGlobalParamValue( ByVal ParamName, ByVal ParamValue )
if g_ErrorHandler then on error resume next
Trace "Storing value of global parameter " & ParamName & " = " & ParamValue
Dim Conn, ConnString
Set Conn = CreateObj("ADODB.Connection")
ConnString = DSN_METABASE
Conn.Open ConnString
' Check error
RaiseOnError Wizard("Metabase_LoginFailed")
if IsErrorClear() then
Dim Query, Count, RecordSet
' See if the parameter already exists:
' Fetch value for parameter out of metabase table GLOBALPARAMETER
Dim bExists
bExists = false
Query = "SELECT * FROM GLOBALPARAMETER WHERE PARAMNAME='" & ParamName & "'"
Set RecordSet = Conn.Execute( Query, Count )
RaiseOnError Format2(Wizard("ExecQuery_ExecFailed"),Query,ConnString)
if IsErrorClear() then
' Fetch first row out of recordset
if RecordSet.EOF then
Trace "Resultset is empty"
else
bExists = true
end if
end if
' Insert or update the parameter value
if bExists then
' do an UPDATE
Query = "UPDATE GLOBALPARAMETER " & _
"SET PARAMVALUE='" & ParamValue & "' WHERE PARAMNAME='" & ParamName & "'"
else
' do an INSERT
Query = "INSERT INTO GLOBALPARAMETER (PARAMNAME, PARAMVALUE) " & _
"VALUES ('" & ParamName & "','" & ParamValue & "')"
end if
Trace "Perform SQL command: " & Query
Conn.Execute Query, Count
RaiseOnError Format2(Wizard("ExecQuery_ExecFailed"),Query,ConnString)
Conn.Close
end if
End Sub
' Registry key where installation information for the ServerTypes (ConfigTypes) is stored
Const REGKEY_SERVERTYPES = "HKLM\SOFTWARE\Baan\Baan E-Enterprise\ConfigTypes"
Const REGKEY_SERVERTYPES2 = "HKLM\SOFTWARE\Baan\Baan E-Enterprise\ConfigTypes"
'========================================================================
' MetaUpdate
'
Sub MetaUpdate( ByVal Machine, ByVal ServerType, ByVal Action, ByVal FileList,_
ByVal Version, ByVal ServicePack, ByVal Patch, ByVal HistOnly )
if g_ErrorHandler then on error resume next
DisplayActionStart "UPDATING METABASE"
TraceParameters _
Array("Machine", "ServerType", "Action", "FileList", "Version", "ServicePack", "Patch", "HistOnly"),_
Array(Machine, ServerType, Action, FileList, Version, ServicePack, Patch, HistOnly)
if not Defined(Action) then
Action = ""
end if
if not Defined(FileList) then
FileList = ""
end if
if not Defined(Version) then
Version = ""
end if
if not Defined(ServicePack) then
ServicePack = ""
end if
if not Defined(Patch) then
Patch = ""
end if
if not Defined(HistOnly) then
HistOnly = ""
end if
Dim bHistOnly
bHistOnly = false
if UCase(HistOnly) = "Y" then
bHistOnly = true
end if
' == Open the metabase
WriteProgressMsg "Initializing Metabase ..."
Dim Conn, ConnString
Set Conn = CreateObj("ADODB.Connection")
ConnString = DSN_METABASE
Conn.Open ConnString
' Check error
RaiseOnError Wizard("Metabase_LoginFailed")
if IsErrorClear() then
' == Metabase is updated in two phases: first, delete the 'old' information; then, add the
' 'new' information. This simplifies the whole process (otherwise, we would have to
' check which rows have to be deleted, updated and inserted)
' Base registry key for accessing information on this server type
Dim Reg, RegKeyBase
Set Reg = GetWshShell()
' Try to read from the "new" E-Enterprise key (E-Enterprise 2.0), if that fails,
' use the old registry key
Dim Value
Value = Reg.RegRead( REGKEY_BASE2 & "\InstallDir" )
if Err.number = 0 then
RegKeyBase = REGKEY_SERVERTYPES2
Trace "Using Reg.Key E-Enterprise 2.0"
else
RegKeyBase = REGKEY_SERVERTYPES
Trace "Using Reg.Key E-Enterprise 1.1"
end if
Err.Clear
if ServerType = "BldServer" then ' translate "BldServer" to "BuildServer"
RegKeyBase = RegKeyBase & "\BuildServerConfig"
else
RegKeyBase = RegKeyBase & "\" & ServerType & "Config"
end if
' See if server type is still installed
Dim bInstalled
bInstalled = true
Value = Reg.RegRead( RegKeyBase & "\Installed" )
' if the key does not exist, an error is thrown and the value remains empty
Err.Clear
if IsEmpty(Value) then
Value = ""
end if
if Value <> "1" then
Trace "Server type " & ServerType & " is not installed any more on this machine"
bInstalled = false
end if
Dim WhereClause
WhereClause = "WHERE MACHINE = '" & Machine & "' AND SERVER = '" & ServerType & "'"
if bHistOnly then
ClearError
else
' == First, delete the old information for this machine and servertype
WriteProgressMsg "Resetting Metabase ..."
' == Delete the rows for this machine and server type, from the relevant tables.
' This must be done in a specific order (sequence), because of referential integrity
' constraints.
' -- Cleanup OBJECT table:
' - if server type (still) installed, backup the information in OBJECT before deleting it
if bInstalled then
MetaBackupObjects Conn, WhereClause
end if
' - clear the table
MetaCleanupTable Conn, "OBJECT", WhereClause
' -- Cleanup MODULE table:
MetaCleanupTable Conn, "MODULE", WhereClause
' -- Cleanup APPLICATION table:
MetaCleanupTable Conn, "APPLICATION", WhereClause
' -- If this is not a patch installation, cleanup the PATCH table:
if Patch = "" then
MetaCleanupTable Conn, "PATCH", WhereClause
end if
end if
if IsErrorClear() then
' If servertype not installed any more, delete the rows from the INSTALLATIONHISTORY,
' SERVERPARAMETER and SERVER tables (and do not add any new information to the metabase)
if not bInstalled then
Trace "Remove information completely ..."
' -- Cleanup INSTALLATIONHISTORY table:
MetaCleanupTable Conn, "INSTALLATIONHISTORY", WhereClause
' -- Cleanup SERVERPARAMETER table:
MetaCleanupTable Conn, "SERVERPARAMETER", WhereClause
' -- Cleanup SERVER table:
MetaCleanupTable Conn, "SERVER", WhereClause
' Servertype is (still) installed: add information (again) to the metabase
else
' == Next, add the new state for this machine and servertype
Dim Sql, Count, InstallDate
' Set current date as the installation date:
InstallDate = CStr(Now())
' == Insert the rows into the relevant tables. This must be done in a specific order
' (sequence), because of referential integrity constraints. The order is the
' reverse from the one we used for DELETING the rows (see above)
WriteProgressMsg "Writing Metabase ..."
' If History Only, do not update the other tables, only the History table
if not bHistOnly then
' -- Write SERVER table:
' Insert or update row in the SERVER table
Dim InstallDateSP, InstallSP
if ServicePack = "" then
InstallSP = "null"
InstallDateSP = "null"
else
InstallSP = "'" & ServicePack & "'"
InstallDateSP = "'" & InstallDate & "'"
end if
Sql = "INSERT INTO SERVER " & _
"(MACHINE,SERVER,INSTALLATIONSTATUS,SERVICEPACK,INSTALLATIONDATESP) " &_
"VALUES ('" & Machine & "','" & ServerType & "',0," & InstallSP & "," &_
InstallDateSP & ")"
Conn.Execute Sql, Count
' If error (i.e., the row already existed), try UPDATE
if not IsErrorClear() then
' trace the error
TraceOnError Format1(Wizard("MetaInsert_Failed"),Sql)
Trace "Try UPDATE on SERVER table"
Sql = "UPDATE SERVER " & _
"SET SERVICEPACK=" & InstallSP & ",INSTALLATIONDATESP=" & InstallDateSP &_
" " & WhereClause
Conn.Execute Sql, Count
' trace the error
TraceOnError Format1(Wizard("MetaUpdate_Failed"),Sql)
end if
' -- Write APPLICATION table:
MetaAddApplication Reg, RegKeyBase, Conn, Machine, ServerType, _
"E-Sales", "E-Sales", InstallDate
MetaAddApplication Reg, RegKeyBase, Conn, Machine, ServerType, _
"E-Collaboration", "E-Collaboration", InstallDate
MetaAddApplication Reg, RegKeyBase, Conn, Machine, ServerType, _
"E-Procurement", "E-Procurement", InstallDate
MetaAddApplication Reg, RegKeyBase, Conn, Machine, ServerType, _
"E-Service", "E-Service", InstallDate
MetaAddApplication Reg, RegKeyBase, Conn, Machine, ServerType, _
"E-ServiceRemote", "E-ServiceRemote", InstallDate
' -- Write MODULE table:
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Common", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Sales", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Collaboration", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Dashboard", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Procurement", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Catalog", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-ServiceRemote", InstallDate
MetaAddModule Reg, RegKeyBase, Conn, Machine, ServerType, "E-Service", InstallDate
' -- Write PATCH table:
if Patch <> "" then
Sql = "INSERT INTO PATCH " & _
"(MACHINE,SERVER,PATCH,INSTALLATIONDATE,INSTALLATIONSTATUS) " &_
"VALUES ('" & Machine & "','" & ServerType & "','" & Patch & "'," &_
"'" & InstallDate & "',0)"
Conn.Execute Sql, Count
' trace the error
TraceOnError Format1(Wizard("MetaInsert_Failed"),Sql)
end if
end if
' -- Add row to History table:
Dim Description, InstallVersion
InstallVersion = ""
if Version <> "" then
InstallVersion = "version " & Version & " for "
end if
Description = "Installed " & InstallVersion & "server type " & ServerType
if Action <> "" then
Description = Description & ", Action: " & Action
end if
Sql = "INSERT INTO INSTALLATIONHISTORY " &_
"(MACHINE,SERVER,DESCRIPTION,INSTALLATIONDATE,INSTALLATIONSTATUS) VALUES " &_
"('" & Machine & "','" & ServerType & "','" & Description & "','" & InstallDate & "',0)"
Conn.Execute Sql, Count
RaiseOnError Format1(Wizard("MetaInsert_Failed"),Sql)
' If History Only, do not update the other tables, only the History table
if not bHistOnly then
' -- Write OBJECT table:
' Restore old objects
MetaRestoreObjects Conn, WhereClause, Machine, ServerType
' Add/update new objects from version file
if FileList <> "" then
MetaUpdateObjects FileList, Machine, ServerType, Conn, Version, InstallDate
end if
end if
end if
end if
Conn.Close
end if
DisplayActionFinish "UPDATING METABASE"
End Sub
'========================================================================
' MetaUpdateObjects
'
Sub MetaUpdateObjects( ByVal FileList, ByVal Machine, ByVal ServerType, ByVal Conn, _
ByVal AppVersion, ByVal InstallDate )
if g_ErrorHandler then on error resume next
Trace "Reading version file: " & FileList
' Open the version file
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
if not Fso.FileExists(FileList) then
RaiseError Format1(Wizard("Meta_FileNotFound"),FileList)
end if
if IsErrorClear() then
Dim File
Set File = Fso.OpenTextFile( FileList, 1 )
RaiseOnError Format1(Wizard("Meta_CannotOpenFile"),FileList)
end if
' process the file
if IsErrorClear() then
' read the files from the configuration file
Dim Path, DisplayPath
DisplayPath = ""
Dim Line, Parts, FileName, Module, FileVersion, Checksum
do while not File.AtEndOfStream
Line = Trim( File.ReadLine() )
if Line <> "" then
Parts = Split(Line,";")
FileName = Parts(0)
Checksum = Parts(1)
FileVersion = Parts(2)
Module = MetaGetModuleName(FileName)
' show progress
Path = Fso.GetParentFolderName(FileName)
' If folder name starts with "Web\", replace "Web\" with "EE11\"
if InStr(Path,"Web\") = 1 then
Path = "EE11\" & Mid(Path,5)
end if
if Path <> DisplayPath then
DisplayPath = Path
WriteProgressMsg "File path: " & DisplayPath
end if
if FileName <> "" and FileVersion <> "" then
MetaWriteFileInfo Machine, ServerType, AppVersion, FileName, Module, FileVersion, _
Checksum, InstallDate, Conn
end if
end if
loop
File.Close
end if
End Sub
'========================================================================
' MetaCleanupTable
'
Sub MetaCleanupTable( ByVal Conn, ByVal Table, ByVal WhereClause )
if g_ErrorHandler then on error resume next
Trace "Cleanup metabase table: " & Table
Dim Sql, Count
Sql = "DELETE FROM " & Table & " " & WhereClause
Conn.Execute Sql, Count
RaiseOnError Format1(Wizard("MetaDelete_Failed"),Sql)
End Sub
'========================================================================
' MetaAddApplication
'
Sub MetaAddApplication( ByVal Reg, ByVal RegKeyBase, ByVal Conn, _
ByVal Machine, ByVal ServerType, ByVal AppName, ByVal ModuleName, ByVal InstallDate )
if g_ErrorHandler then on error resume next
Dim RegKeyModules
RegKeyModules = RegKeyBase & "\Modules"
Dim Value
'
' Check if the application is installed.
' This is done by checking if a certain module, which is always part of that application,
' but is not part of any other application, is installed.
'
' For instance:
' - If the MODULE "E-Requisition" is installed, then we know that the APPLICATION
' "E-Procurement" is installed
' - If the MODULE "E-Sales" is installed, then we know that the APPLICATION
' "E-Sales" is installed
'
Value = Reg.RegRead( RegKeyModules & "\" & ModuleName & "\Installed" )
Err.Clear
if IsEmpty(Value) then
Value = ""
end if
if Value = "1" then
Trace "Application " & AppName & " is installed"
Dim Version, Release
Version = Reg.RegRead( RegKeyModules & "\" & ModuleName & "\AppVersion" )
Release = Version
if InStr(Version,".") > 0 then
Dim SubParts
SubParts = Split(Version,".")
Release = SubParts(0) & "." & SubParts(1)
end if
Dim Sql, Count
Sql = "INSERT INTO APPLICATION " & _
"(MACHINE,SERVER,APPLICATION,INSTALLATIONDATE,RELEASE,INSTALLATIONSTATUS) " &_
"VALUES ('" & Machine & "','" & ServerType & "','" & AppName & "'," & _
"'" & InstallDate & "','" & Release & "',0)"
Conn.Execute Sql, Count
RaiseOnError Format1(Wizard("MetaInsert_Failed"),Sql)
else
Trace "Application " & AppName & " is not installed"
end if
End Sub
'========================================================================
' MetaAddModule
'
Sub MetaAddModule( ByVal Reg, ByVal RegKeyBase, ByVal Conn, ByVal Machine, ByVal ServerType, _
ByVal Module, ByVal InstallDate )
if g_ErrorHandler then on error resume next
Dim RegKeyModules
RegKeyModules = RegKeyBase & "\Modules"
Dim Value
Value = Reg.RegRead( RegKeyModules & "\" & Module & "\Installed" )
Err.Clear
if IsEmpty(Value) then
Value = ""
end if
if Value = "1" then
Trace "Module " & Module & " is installed"
Dim Version
Version = Reg.RegRead( RegKeyModules & "\" & Module & "\AppVersion" )
Dim Sql, Count
Sql = "INSERT INTO MODULE " & _
"(MACHINE,SERVER,MODULE,INSTALLATIONDATE,VERSION,INSTALLATIONSTATUS) " &_
"VALUES ('" & Machine & "','" & ServerType & "','" & Module & "'," & _
"'" & InstallDate & "','" & Version & "',0)"
Conn.Execute Sql, Count
RaiseOnError Format1(Wizard("MetaInsert_Failed"),Sql)
else
Trace "Module " & Module & " is not installed"
end if
End Sub
'========================================================================
' MetaBackupObjects
'
Sub MetaBackupObjects( ByVal Conn, ByVal WhereClause )
if g_ErrorHandler then on error resume next
Trace "Backing up OBJECT table"
Dim Sql, Count
Sql = "DROP TABLE tempOBJECT"
Conn.Execute Sql, Count
TraceOnError Format1(Wizard("MetaSql_Failed"),Sql)
Sql = "CREATE TABLE tempOBJECT (" & _
"MACHINE varchar(20) not null," & _
"SERVER varchar(10) not null," & _
"MODULE varchar(20) not null," & _
"OBJECT varchar(255) not null," & _
"VSSVERSION smallint not null," & _
"VERSION varchar(10) not null," & _
"SIZE int not null," & _
"INSTALLATIONDATE datetime not null," & _
"INSTALLATIONSTATUS smallint not null," & _
"CHECKSUM varchar(4) not null," & _
"constraint PK_OBJECT primary key (MACHINE, SERVER, MODULE, OBJECT)" & _
")"
Conn.Execute Sql, Count
TraceOnError Format1(Wizard("MetaSql_Failed"),Sql)
Sql = "DELETE FROM tempOBJECT"
Conn.Execute Sql, Count
TraceOnError Format1(Wizard("MetaSql_Failed"),Sql)
Sql = "INSERT INTO tempOBJECT " & _
"SELECT MACHINE, SERVER, MODULE, OBJECT, VSSVERSION, VERSION, SIZE, " & _
"INSTALLATIONDATE, INSTALLATIONSTATUS, CHECKSUM FROM OBJECT" & " " & WhereClause
Conn.Execute Sql, Count
TraceOnError Format1(Wizard("MetaSql_Failed"),Sql)
End Sub
'========================================================================
' MetaRestoreObjects
'
Sub MetaRestoreObjects( ByVal Conn, ByVal WhereClause, ByVal Machine, ByVal ServerType )
if g_ErrorHandler then on error resume next
Trace "Restoring OBJECT table"
Dim Sql, Count
Sql = "INSERT INTO OBJECT (MACHINE, SERVER, MODULE, OBJECT, VSSVERSION, VERSION, SIZE, " & _
"INSTALLATIONDATE, INSTALLATIONSTATUS, CHECKSUM) " & _
"(SELECT MACHINE, SERVER, MODULE, OBJECT, VSSVERSION, VERSION, SIZE, " & _
"INSTALLATIONDATE, INSTALLATIONSTATUS, CHECKSUM FROM tempOBJECT" & " " & _
"WHERE MACHINE = '" & Machine & "' AND SERVER = '" & ServerType & "' AND " & _
"MODULE IN (SELECT MODULE FROM MODULE " & _
"WHERE MACHINE = '" & Machine & "' AND SERVER = '" & ServerType & "'))"
Conn.Execute Sql, Count
TraceOnError Format1(Wizard("MetaSql_Failed"),Sql)
Sql = "DROP TABLE tempOBJECT"
Conn.Execute Sql, Count
TraceOnError Format1(Wizard("MetaSql_Failed"),Sql)
End Sub
'========================================================================
' MetaCheckFileVersions
'
Sub MetaCheckFileVersions( ByVal Machine, ByVal ServerType, ByVal SrcDir, _
ByVal InFile, ByVal OutFile, ByVal CheckVersions )
if g_ErrorHandler then on error resume next
DisplayActionStart "CHECKING METABASE FILE VERSIONS"
TraceParameters Array("Machine", "ServerType", "SrcDir", "InFile", "OutFile", "CheckVersions"),_
Array(Machine, ServerType, SrcDir, InFile, OutFile, CheckVersions)
Dim bCheckVer
if LCase(CheckVersions) = "y" then
bCheckVer = true
else
bCheckVer = false
end if
' Algorithm for checking file versions:
'
' - Read input file containing file version numbers into a dictionary [-> 'new' version numbers]
' - Read metabase table OBJECT into the same dictionary [-> 'old' version numbers]
' [this need not be done if bCheckVer is FALSE]
' - Generate the output file:
' - Enumerate files in the folder "SrcDir".
' - For each file in this folder, write the file's full pathname and checksum to the output file,
' if one of the following is true:
' - the file is not in the dictionary (because it was not in the input file). In this case,
' do not write a checksum for the file
' - the file is in the dictionary, and one of the folowing is true:
' - bCheckVer is FALSE
' - bCheckVer is TRUE but the new version number is greater than the old version number
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
' Read the input file version list into a dictionary
Dim VersionList
Set VersionList = CreateObj("Scripting.Dictionary")
MetaReadVersionFile Fso, InFile, VersionList
' Read metabase info into the dictionary
MetaReadObjectTable Machine, ServerType, VersionList
' Write output file
MetaWriteFileList Fso, OutFile, SrcDir, VersionList, bCheckVer
DisplayActionFinish "CHECKING METABASE FILE VERSIONS"
End Sub
'========================================================================
' MetaReadVersionFile
'
Sub MetaReadVersionFile( ByVal Fso, ByVal VersionFile, ByVal VersionList )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Reading version file ..."
if not Fso.FileExists(VersionFile) then
RaiseError Format1(Wizard("Meta_FileNotFound"),VersionFile)
end if
if IsErrorClear() then
Dim File
Set File = Fso.OpenTextFile( VersionFile, 1 )
RaiseOnError Format1(Wizard("Meta_CannotOpenFile"),VersionFile)
end if
' read the file
if IsErrorClear() then
Dim FileName, Module, FileVersion, Checksum, DisplayPath
' path for progress display
DisplayPath = ""
Dim FileProps(2)
do while not File.AtEndOfStream
MetaGetFileInfo File, Fso, FileName, FileVersion, Checksum, DisplayPath
Module = MetaGetModuleName(FileName)
if FileName <> "" and FileVersion <> "" then
' FileProps(0) contains 'new' version number from the version file
FileProps(0) = CInt(FileVersion)
' FileProps(1) will contain 'old' version number from the repository
FileProps(1) = 0
' FileProps(2) will contain 'old' checksum from the repository
FileProps(2) = ""
VersionList(LCase(FileName)) = FileProps
end if
loop
File.Close
end if
End Sub
'========================================================================
' MetaReadObjectTable
'
Sub MetaReadObjectTable( ByVal Machine, ByVal ServerType, ByVal VersionList )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Reading metabase ..."
Dim Conn, ConnString
Set Conn = CreateObj("ADODB.Connection")
ConnString = DSN_METABASE
Conn.Open ConnString
' Check error
RaiseOnError Wizard("Metabase_LoginFailed")
if IsErrorClear() then
Dim Count, RecordSet, Query
' Get rows from OBJECT table for this machine and server type
Query = "SELECT * FROM OBJECT " & _
"WHERE MACHINE = '" & Machine & "' AND SERVER = '" & ServerType & "'"
Set RecordSet = Conn.Execute( Query, Count )
RaiseOnError Format2(Wizard("ExecQuery_ExecFailed"),Query,ConnString)
if IsErrorClear() then
' Fetch rows out of recordset
Dim FileName, FileVersion, Checksum
Dim Values(2), FileProps
do while not RecordSet.EOF
FileName = RecordSet("OBJECT")
FileVersion = RecordSet("VSSVERSION")
Checksum = RecordSet("CHECKSUM")
' get file's properties from the dictionary
FileProps = VersionList(LCase(FileName))
if IsEmpty(FileProps) then ' file not found
FileProps = Values
FileProps(0) = 0
end if
FileProps(1) = FileVersion
FileProps(2) = Checksum
VersionList(LCase(FileName)) = FileProps
RecordSet.MoveNext
loop
end if
Conn.Close
end if
End Sub
'========================================================================
' MetaWriteFileList
'
Sub MetaWriteFileList( ByVal Fso, ByVal OutFile, ByVal SrcDir, ByVal VersionList, ByVal bCheckVer )
if g_ErrorHandler then on error resume next
WriteProgressMsg "Writing file list ..."
Dim File
Set File = Fso.CreateTextFile( OutFile, true )
RaiseOnError Format1(Wizard("Meta_CannotOpenFile"),OutFile)
' read the file
if IsErrorClear() then
Dim DisplayPath
' path for progress display
DisplayPath = ""
' Generate the output file:
' - Enumerate files in the folder "SrcDir".
' - For each file in this folder, write the file's full pathname and checksum to the output
' file, if one of the following is true:
' - the file is not in the dictionary (because it was not in the input file). In this case,
' do not write a checksum for the file
' - the file is in the dictionary, and one of the folowing is true:
' - bCheckVer is FALSE
' - bCheckVer is TRUE but the new version number is greater than the old version number
MetaWriteFolder Fso, File, SrcDir, SrcDir, VersionList, bCheckVer, DisplayPath
File.Close
end if
End Sub
'========================================================================
' MetaWriteFolder
'
Sub MetaWriteFolder( Fso, OutFile, Path, BasePath, VersionList, bCheckVer, DisplayPath )
if g_ErrorHandler then on error resume next
Dim Folder
Set Folder = Fso.GetFolder(Path)
' Handle the files in the folder itself
Dim Start
Start = Len(BasePath)+2
Dim File, FileName, FileProps, bOK, Checksum, OldVer, NewVer
for each File in Folder.Files
' Write the file's full pathname and checksum to the output file, if one of the following
' is true:
' - the file is not in the dictionary (because it was not in the input file). In this case,
' do not write a checksum for the file
' - the file is in the dictionary, and one of the folowing is true:
' - bCheckVer is FALSE
' - bCheckVer is TRUE but the new version number is greater than the old version number
' search the file in the dictionary
FileName = Mid(File.Path,Start)
FileProps = VersionList(LCase(FileName))
Checksum = ""
OldVer = ""
NewVer = ""
bOK = false
if IsEmpty(FileProps) then
bOK = true
else
OldVer = FileProps(1)
NewVer = FileProps(0)
if not bCheckVer then
bOK = true
elseif NewVer > OldVer then
bOK = true
end if
if bOK then
Checksum = FileProps(2)
end if
end if
if bOK then
' Write file info
OutFile.WriteLine FileName & ";" & Checksum & ";" & NewVer
else
Trace "Skipped file " & FileName & " " &_
"(old version: " & CStr(OldVer) & ", new version: " & CStr(NewVer) & ")"
end if
' show progress
Dim FilePath
FilePath = Fso.GetParentFolderName(FileName)
if FilePath <> DisplayPath then
DisplayPath = FilePath
WriteProgressMsg "File path: " & DisplayPath
end if
next
' Handle the folder's subfolders
Dim SubFolder
for each SubFolder in Folder.SubFolders
' Call the subroutine recursively for each subfolder
MetaWriteFolder Fso, OutFile, SubFolder.Path, BasePath, VersionList, bCheckVer, DisplayPath
next
End Sub
'========================================================================
' MetaFix2_0
'
Sub MetaFix2_0( ByVal Machine, ByVal ServerType, ByVal AppVersion, ByVal FileList )
if g_ErrorHandler then on error resume next
DisplayActionStart "FIXING METABASE"
TraceParameters Array("Machine", "ServerType", "FileList"), Array(Machine, ServerType, FileList)
' == Open the metabase
WriteProgressMsg "Initializing Metabase ..."
Dim Conn, ConnString
Set Conn = CreateObj("ADODB.Connection")
ConnString = DSN_METABASE
Conn.Open ConnString
' Check error
RaiseOnError Wizard("Metabase_LoginFailed")
if IsErrorClear() then
' Open the version file
Dim Fso
Set Fso = CreateObject("Scripting.FileSystemObject")
if not Fso.FileExists(FileList) then
RaiseError Format1(Wizard("Meta_FileNotFound"),FileList)
end if
if IsErrorClear() then
Dim File
Set File = Fso.OpenTextFile( FileList, 1 )
RaiseOnError Format1(Wizard("Meta_CannotOpenFile"),FileList)
end if
' process the file
if IsErrorClear() then
' read the files from the configuration file
Dim DisplayPath
DisplayPath = ""
' Set current date as the installation date:
Dim InstallDate
InstallDate = CStr(Now())
Dim FileName, Module, FileVersion, Checksum
do while not File.AtEndOfStream
MetaGetFileInfo File, Fso, FileName, FileVersion, Checksum, DisplayPath
Module = MetaGetModuleName(FileName)
if FileName <> "" and FileVersion <> "" then
MetaWriteFileInfo Machine, ServerType, AppVersion, FileName, Module, FileVersion, _
Checksum, InstallDate, Conn
end if
loop
File.Close
end if
Conn.Close
end if
DisplayActionFinish "FIXING METABASE"
End Sub
'========================================================================
' MetaGetFileInfo
'
Sub MetaGetFileInfo( ByVal File, ByVal Fso, _
ByRef FileName, ByRef Version, ByRef Checksum, ByRef DisplayPath )
if g_ErrorHandler then on error resume next
FileName = ""
Version = ""
Checksum = ""
Dim Line
do while not File.AtEndOfStream and FileName = ""
Line = Trim( File.ReadLine() )
if Left(Line,1) = "[" then
FileName = Mid(Line,2,Len(Line)-2)
end if
loop
if FileName <> "" then
' show progress
Dim Path
Path = Fso.GetParentFolderName(FileName)
' If folder name starts with "Web\", replace "Web\" with "EE11\"
if InStr(Path,"Web\") = 1 then
Path = "EE11\" & Mid(Path,5)
end if
if Path <> DisplayPath then
DisplayPath = Path
WriteProgressMsg "File path: " & DisplayPath
end if
' process file information
Dim Parts, Key, Value
Line = " "
do while not File.AtEndOfStream and Line <> ""
' Get file's attributes
Line = Trim( File.ReadLine() )
Parts = Split(Line,"=")
if UBound(Parts) > 0 then
Key = Parts(0)
Value = Parts(1)
if Key = "Version" then
Version = Value
elseif Key = "Checksum" then
Checksum = Value
end if
end if
loop
end if
End Sub
'========================================================================
' MetaGetModuleName
'
Function MetaGetModuleName( ByRef FileName )
' This function determines to which application module (e.g. E-Sales, E-Common) the
' given file belongs, by looking at the file's folder.
'
' E.g., if the FileName parameter is "Web\E-Sales\default.asp" then the file belongs to
' the application module "E-Sales".
Dim Module, StartPos, EndPos
Module = ""
' Path starts with "Components\", so the file is a Component file (DLL etc.)
if InStr(FileName,"Components\") = 1 then
' Extract sub folder
StartPos = Len("Components\")+1
EndPos = InStr(StartPos, FileName, "\")
if StartPos > 0 then
Module = Mid(FileName,StartPos,EndPos-StartPos)
end if
' Deduct the module name from the sub folder name
select case Module
case "ESales", "BIC"
Module = "E-Sales"
case "ECollaboration"
Module = "E-Collaboration"
case "EDashboard"
Module = "E-Dashboard"
case "EECommon", "EEnterprise", "EEBackendComponent", "EEBCBELookup"
Module = "E-Common"
case "EService"
Module = "E-Service"
case "ECatalog"
Module = "E-Catalog"
case "EProcurement"
Module = "E-Procurement"
case "EServiceRemote"
Module = "E-ServiceRemote"
end select
' Path starts with "Web\", so the file is a Web file (ASP etc.)
elseif InStr(FileName,"Web\") = 1 then
' Extract sub folder
StartPos = Len("Web\")+1
EndPos = InStr(StartPos, FileName, "\")
if EndPos = 0 then
Module = ""
elseif StartPos > 0 then
Module = Mid(FileName,StartPos,EndPos-StartPos)
end if
' Deduct the module name from the sub folder name
select case Module
case "E-Sales", ",E-Catalog", "E-Collaboration", "E-Dashboard", _
"E-Procurement", "E-ServiceRemote", "E-Service"
' Do nothing: path already contains the correct module name
case else
' Rest is considered to be E-Common
Module = "E-Common"
end select
' Web files are not under "Web" but under "EE11" on the web server;
' correct the file path
FileName = "EE11\" & Mid(FileName,5)
end if
if Module = "" then
Module = "E-Common"
end if
MetaGetModuleName = Module
End Function
'========================================================================
' MetaWriteFileInfo
'
Sub MetaWriteFileInfo( ByVal Machine, ByVal ServerType, ByVal AppVersion, ByVal FileName, _
ByVal Module, ByVal Version, ByVal Checksum, ByVal InstallDate, ByVal Conn )
if g_ErrorHandler then on error resume next
' Store file's attributes in the database
Dim Sql, Count
Sql = _
"INSERT INTO OBJECT " & _
"(MACHINE,SERVER,MODULE,OBJECT,VSSVERSION,VERSION,SIZE,CHECKSUM," & _
"INSTALLATIONDATE,INSTALLATIONSTATUS) " & _
"VALUES " & _
"('" & Machine & "','" & ServerType & "','" & Module & "','" & FileName & "'," & _
Version & ",'" & AppVersion & "',0,'" & Checksum & "','" & InstallDate & "',0)"
Conn.Execute Sql, Count
' If error (i.e., the row already existed), try UPDATE
if not IsErrorClear() then
' trace the error
''TraceOnError Format1(Wizard("MetaInsert_Failed"),Sql)
''Trace "Try UPDATE on OBJECT table"
ClearError
Sql = "UPDATE OBJECT " & _
"SET " & _
"VSSVERSION = " & Version & ", " & _
"VERSION = '" & AppVersion & "', " & _
"SIZE = 0, " & _
"CHECKSUM = '" & Checksum & "', " & _
"INSTALLATIONDATE = '" & InstallDate & "', " & _
"INSTALLATIONSTATUS = 0" & _
" WHERE MACHINE = '" & Machine & "' AND SERVER = '" & ServerType & "' AND " & _
"MODULE = '" & Module & "' AND OBJECT = '" & FileName & "'"
Conn.Execute Sql, Count
' trace the error
TraceOnError Format1(Wizard("MetaUpdate_Failed"),Sql)
end if
End Sub
'#############################################################################
'# Resources
'#############################################################################
''=============================================================================
'' DefineResourceUnit
''
'Function DefineResourceUnit(ByRef parent, ByVal Name)
' dim rsrcUnit
' set rsrcUnit = CreateObj("Scripting.Dictionary")
' set rsrcUnit.Form = CreateObj("Scripting.Dictionary")
' set rsrcUnit.Warn = CreateObj("Scripting.Dictionary")
' set rsrcUnit.Grid = CreateObj("Scripting.Dictionary")
' set rsrcUnit.User = CreateObj("Scripting.Dictionary")
' rsrcUnit("Name") = Name
'
' set parent(Name) = rsrcUnit
'
' REM - set return value:
' set DefineResourceUnit = rsrcUnit
'End Function
'========================================================================
' DefineGlobalResources
'
Function DefineGlobalResources
Dim Wizard
Set Wizard = CreateObj("Scripting.Dictionary")
Set DefineGlobalResources = Wizard
'====================================================================
' Globals
'
''Set Page = DefineResourceUnit(Wizard, "Globals")
Wizard("CommerceSiteManagersGroup") =_
"Members can use the common site components in Commerce Server 3.0."
Wizard("CommerceSiteGroup") =_
"Members can use the site manager in Commerce Server 3.0."
Wizard("StatusOpen") =_
"Open"
Wizard("StatusClosed") =_
"Closed"
Wizard("StatusInvalid") =_
"Invalid"
Wizard("SecurityNT") =_
"Windows NT"
Wizard("SecurityMembership") =_
"Membership"
Wizard("NoSession") =_
"Session Expired." + vbCrLf + vbCrLf +_
"Your administration session has expired." + vbCrLf +_
"Restart the application."
Wizard("AddAcct") =_
"Cannot add user to the Windows NT group %1."
Wizard("DelAcct") =_
"Cannot delete user from the Windows NT group %1."
Wizard("CreateAcct") =_
"Cannot create a new Windows NT user account."
Wizard("CreateGroup") =_
"Cannot create a new Windows NT group %1."
Wizard("DeleteGroup") =_
"Cannot delete Windows NT group %1."
Wizard("SiteInit") =_
"Cannot initialize Commerce Site."
Wizard("SiteLoad") =_
"Cannot load Commerce Site properties."
Wizard("SiteSave") =_
"Cannot save Commerce Site properties."
Wizard("CreateWeb") =_
"Cannot create Web project."
Wizard("CreateTmpl") =_
"Cannot generate the site foundation."
Wizard("SaveSettings") =_
"Cannot write properties to the new site."
Wizard("AddAccts") =_
"Cannot add accounts."
Wizard("ExecuteScript") =_
"Cannot execute database script."
Wizard("Connect") =_
"Cannot connect to the database with the information provided."
Wizard("CreateSiteNoID") =_
"Cannot create site without WebSite ID."
Wizard("CreateSiteNoSiteName") =_
"Cannot create site without SiteName."
Wizard("CreateSiteNoConnectionString") =_
"Cannot create site without ConnectionString."
Wizard("CreateSiteDisplayName") =_
"New Site"
Wizard("CreateSiteExistingDict") =_
"Cannot use an existing directory."
Wizard("CreateSiteCantCreatePath") =_
"The destination path you entered cannot be created."
Wizard("CreateSiteNameNotValid") =_
"The site name you entered is not valid." + vbCrLf +_
"The name contains invalid characters or " + vbCrLf +_
"the name is already used by another Web application."
Wizard("CreateSiteMembershipInitFailed") =_
"Membership initialization failed"
Wizard("CreateSiteCreateDSManagerGroupFailed") =_
"Create DSManager Group failed"
Wizard("CreateSiteSecureSiteFailed") =_
"Secure site failed"
Wizard("SetFPSecurityFailed") =_
"This site has not been enabled for FrontPage"
Wizard("DeleteSiteCannotDelete20Site") =_
"Cannot delete 2.0 site."
Wizard("DeleteSiteCannotDeleteFiles") =_
"Cannot delete files."
Wizard("DeleteSiteCannotDeleteSite") =_
"Cannot delete site '%1'."
Wizard("GetStatusFailed") =_
"Unable to get status for '%1'"
Wizard("SetStatusFailed") =_
"Unable to set status for '%1'"
Wizard("ReloadSiteFailed") =_
"Unable to reload site '%1'"
Wizard("GetDefaultConnectionFailed") =_
"Unable to get default connection for '%1'"
Wizard("SetDefaultConnectionFailed") =_
"Unable to set default connection for '%1'"
Wizard("AddConnectionToMapFailed") =_
"Unable to add DB connection to connection map for '%1'"
Wizard("RemoveConnectionFromMapFailed") =_
"Unable to remove DB connection from map for '%1'"
Wizard("SetSitePropertiesDisplayNameNotValid") =_
"The display name you entered is not valid."
Wizard("GetTemplateDirectoryFailed") =_
"Unable to read template directory."
Wizard("GetWebSitesFailed") =_
"Failed to enumerate Web Sites."
Wizard("GetCommerceSitesFailed") =_
"Failed to enumerate commerce sites."
Wizard("GetURLBaseFailed") =_
"Cannot get base URL for WebSite ID '%1'"
Wizard("GetWebSitePropertiesFailed") =_
"Cannot get properties for WebSiteID '%1'"
Wizard("GetManagerGroupFailed") =_
"Cannot retrieve Commerce Operator Group name from registry"
Wizard("GetAdministratorsGroupDefault") =_
"Administrators"
Wizard("GetSiteServerAdministratorsGroupDefault") =_
"SiteServer Administrators"
Wizard("AddManagerFailedOnMembership") =_
"Cannot use this routine to add accounts to Membership."
Wizard("DelManagerFailedOnMembership") =_
"Cannot use this routine to delete accounts from Membership."
Wizard("GetManagersFailed") =_
"Cannot retrieve Commerce Operator Group name from registry"
Wizard("SecureSiteEveryone") =_
"Everyone"
Wizard("ValidateConnectionFailed") =_
"Database connection failed."
Wizard("CreateRemoteObjFailed") =_
"Check installation." + vbCrlf +_
"Unable to create object : %1 on %2"
Wizard("GetLDAPObjectFailed") =_
"P&M LDAP Service is not running"
Wizard("DSAuthFailed") =_
"The Account Name and Password you provided are not valid for this site's Membership Directory."
Wizard("DSCreateObjCreatorFailed") =_
"Cannot create Object Creator"
Wizard("DSCreateBrokServerFailed") =_
"Couldn't create BrokServer: 3"
Wizard("DSCreateBrokConfigFailed") =_
"Cannot connect to Admin Object with Authentication. Couldn't create BrokConfig"
Wizard("PrivateAddUserToGroupFailed") =_
"Cannot add user '%1' to parent Group '%2'."
Wizard("PrivateAddGroupToGroupFailed") =_
"Cannot add Group to parent Group."
Wizard("PrivateAddGroupToNTGroupFailed") =_
"Cannot add Group '%1' to parent Group '%2'."
Wizard("CreateDSManagerGroupFailed") =_
"Unable to set DS groups"
Wizard("CreateDSGroupFailed") =_
"Unable to set DS Group %1"
Wizard("CreateContainerFailed") =_
"Unable to create Container :Providers %1"
Wizard("CreateDSUserFailed") =_
"Unable to add DS user %1"
Wizard("InitForMembershipCreateObjCreatorFailed") =_
"Cannot create Object Creator"
Wizard("InitForMembershipCreateBrokServerFailed") =_
"Cannot create BrokServer : 4"
Wizard("AddSchemaAttributeFailed") =_
"Cannot add attribute %1"
Wizard("AddOptionalAttributeToClassFailed") =_
"Cannot bind attribute %1"
Wizard("RaiseErrorCommerce") = "Commerce"
Wizard("RaiseOnErrorDetails") = "Details:"
Wizard("RaiseOnErrorError") = "Error: "
Wizard("DSN_NoDsn") = "Connection string ""%1"": no DSN specified."
Wizard("DSN_NoServer") = "Connection string ""%1"": no server specified."
Wizard("DSN_NoDatabase") = "Connection string ""%1"": no database specified."
Wizard("DSN_NoUser") = "Connection string ""%1"": no user specified."
Wizard("Database_InvalidConnString") = _
"Connection string ""%1"": database, UID or size not specified or incorrect."
Wizard("Sql_LoginFailed") = "SQL Login failed"
Wizard("Sql_ConnectFailed") = "Failed to connect with connection string ""%1"""
Wizard("Mem_CreateCreator") = "Error creating object creator"
Wizard("Mem_CreateObjAuth") = "Error creating authenticated object with creator"
Wizard("Mem_CreateObj") = "Error creating object (without creator)"
Wizard("Mem_Init") = "Error while initializing for Membership admin"
Wizard("Mem_FindServer") = "Error while searching membership server"
Wizard("Mem_OpenDB") = "Error while creating/opening membership database"
Wizard("Mem_ServerExists") = "Membership server already exists. Use ""recreate_memserver"""
Wizard("Mem_CreateMem") = "Error while creating membership server instance"
Wizard("Mem_ConfigMem") = "Error during membership server configuration"
Wizard("Mem_PreconfigMem") = "Error during membership server preconfiguration"
Wizard("Mem_CreateLDAP") = "Error while creating LDAP server"
Wizard("Mem_ServerNotFound")= "Membership server does not exist yet"
Wizard("Mem_GetBrokCfgFailed") = "Get BrokCfg failed"
Wizard("Mem_GetInfoFailed") = "GetInfo failed"
Wizard("Mem_SetInfoFailed") = "SetInfo failed"
Wizard("Mem_GetEntryFailed")= "GetEntry failed"
Wizard("Mem_SetEntryFailed")= "SetEntry failed"
Wizard("Mem_RemoveEntryFailed") = "RemoveEntry failed"
Wizard("Mem_MapToSiteFailed") = "Error while mapping the membership server to web site %1"
Wizard("LDAP_AttachFailed") = "Create LDAP server: attach failed"
Wizard("LDAP_CreateFailed") = "Create LDAP server: create instance failed"
Wizard("LDAP_ConfigFailed") = "Create LDAP server: config failed"
Wizard("LDAPCfg_AttachFailed") = "Config LDAP: attach failed"
Wizard("LDAPCfg_ConfigFailed") = "Config LDAP: config failed"
Wizard("DMail_CreateFailed") = "Create DMail server instance failed"
Wizard("MemCfg_CreateGroups") = "Config Membership: Create default groups failed"
Wizard("MemCfg_AuoGetInfo") = "Config Membership: Get Info failed"
Wizard("MemCfg_AuoSetEntry") = "Config Membership: Set Entry failed"
Wizard("MemCfg_CreateBrkAcct") = "Config Membership: Create broker account failed"
Wizard("MemCfg_BrkSetConfig") = "Config Membership: Set broker config failed"
Wizard("MemCfg_StartLdap") = "Config Membership: Start Ldap failed"
Wizard("MemDel_NotFound") = "Delete membership server: membership server not found"
Wizard("MemDel_Init") = "Delete membership server: error while initializing"
Wizard("MemDel_Dmail") = "Delete membership server: delete DMail failed"
Wizard("MemDel_Ldap") = "Delete membership server: delete Ldap failed"
Wizard("MemDel_Auo") = "Delete membership server: delete AUO failed"
Wizard("MemDel_Mem") = "Delete membership server: delete Memb. instance failed"
Wizard("MemAuth_CfgFile") = "Set Membership authentication: Error reading config file %1"
Wizard("MemAuth_CfgOpen") = "Set Membership authentication: Error opening config file %1"
Wizard("MemAuth_WrongEntry") = "Wrong format for configuration file entry: %1"
Wizard("MemAuth_WrongEntry2") = "Error in configuration file entry ""%1"": " & vbCRLF & _
"authentication method and IIS permission must be numbers >= 0."
Wizard("MemAuth_Init") = "Set Membership authentication: Error initializing"
Wizard("MemAuth_MembRequired") = "Set Membership authentication: web site %1 does not run under Membership"
Wizard("MemAuth_SetAuthMethod") = "Set Membership authentication: Error setting auth. method on %1"
Wizard("IISPerm_GetRootObj") = "Set IIS permissions: Error getting IIS root object for %1"
Wizard("IISPerm_GetIISObj") = "Set IIS permissions: Error getting IIS object for %1"
Wizard("IISPerm_SetIISObj") = "Set IIS permissions: Error setting IIS permission on %1"
Wizard("ProcAcl_FileNotFound") = "Process ACL file: File %1 not found"
Wizard("ProcAcl_CannotOpen") = "Process ACL file: Cannot open file %1"
Wizard("ProcAcl_SetPermission") = "Process ACL file: Error setting permission for %1"
Wizard("ASPSessions_GetIISObj") = "Enable ASP Session State: Error getting IIS object for %1"
Wizard("ASPSessions_SetIISObj") = "Enable ASP Session State: Error setting IIS object for %1"
Wizard("ASPScriptTimeout_GetIISObj") = "Set ASP ScriptTimeout: Error getting IIS object for %1"
Wizard("ASPScriptTimeout_SetIISObj") = "Set ASP ScriptTimeout: Error setting IIS object for %1"
Wizard("MemAttr_CfgFile") = "Add Membership attributes: Error reading config file %1"
Wizard("MemAttr_CfgOpen") = "Add Membership attributes: Error opening config file %1"
Wizard("MemAttr_WrongEntry") = "Wrong format for configuration file entry: %1"
Wizard("MemAttr_WrongEntry2") = "Error in configuration file entry ""%1"": " & vbCRLF & _
"attribute multivaluedness must be a number >= 0."
Wizard("MemAttr_MembRequired") = "Add Membership attributes: web site %1 does not run under Membership"
Wizard("UserAttr_WrongEntry") = "Wrong format for entry '%1': no values specified"
Wizard("UserAttr_MembRequired") = "Add Membership user: web site %1 does not run under Membership"
Wizard("UserAttr_CannotGetUser")= "Add Membership user: cannot get user object"
Wizard("UserAttr_CannotSetAttr")= "Add Membership user: cannot set attribute %1"
Wizard("UserAttr_CannotSaveUser") = "Add Membership user: cannot set attributes on user"
Wizard("CreateDB_LoginFailed") = "Create database: SQL Login failed"
Wizard("CreateDB_CreateDBFailed") = "Create database: Create database %1 failed"
Wizard("CreateDB_SetSizeFailed") = "Create database: Set size on database %1 to %2 Mb failed"
Wizard("CreateDB_CreateLoginFailed")= "Create database: Create login %1 failed"
Wizard("CreateDB_CreateUserFailed") = "Create database: Create user %1 failed"
Wizard("DeleteDB_LoginFailed") = "Delete database: SQL Login failed"
Wizard("DeleteDB_DeleteDBFailed") = "Delete database: Delete database %1 failed"
Wizard("ExecSQLCommand_LoginFailed")= "Exec SQL command: SQL Login failed"
Wizard("ExecSQLCommand_GetDBFailed")= "Exec SQL command: database %1 not found"
Wizard("ExecSQLCommand_ExecFailed") = "Exec SQL command: error executing command %1 on %2"
Wizard("ExecQuery_LoginFailed") = "Exec SQL query: SQL Login failed"
Wizard("ExecQuery_ExecFailed") = "Exec SQL query: error executing query %1 on %2"
Wizard("ExecQuery_FieldGetFailed") = "Exec SQL query: cannot get value of field %1"
Wizard("Metabase_LoginFailed") = "EEMetabase: SQL Login failed"
Wizard("MetaDelete_Failed") = "EEMetabase: Delete command (%1) failed"
Wizard("MetaInsert_Failed") = "EEMetabase: Insert command (%1) failed"
Wizard("MetaUpdate_Failed") = "EEMetabase: Update command (%1) failed"
Wizard("MetaSql_Failed") = "EEMetabase: SQL command (%1) failed"
Wizard("Meta_FileNotFound") = "Metabase: File %1 not found"
Wizard("Meta_CannotOpenFile") = "Metabase: Cannot open file %1"
Wizard("StopService_NoServices") = "Stop services: no services to stop"
Wizard("StartService_NoServices") = "Start services: no services to start"
Wizard("InstComp_CfgFile") = "Install components: Error reading config file %1"
Wizard("InstComp_CfgOpen") = "Install components: Error opening config file %1"
Wizard("InstMts_GetCatalog") = "Install MTS components: Create Catalog object failed." & vbCRLF & _
"MTS is either not installed or not started."
Wizard("InstMts_GetPackages") = "Install MTS components: Get Packages failed."
Wizard("InstMts_AddPackage") = "Install MTS components: Add package failed."
Wizard("InstMts_GetComponents") = "Install MTS components: Get Components & Util failed."
Wizard("CfgBuild_NoMembAllowed") = "Configure Build server: web site %1 runs under Membership"
Wizard("CfgBuild_CreateSite") = "Configure Build server: unable to create site %1 on port %2"
Wizard("CfgBuild_SbpFileNotFound") = "Configure Build server: .SBP file ""%1"" not found"
Wizard("CfgBuild_SbpFileImport") = "Configure Build server: error importing .SBP file ""%1"""
Wizard("CfgBuild_SbpLogonFailure") = "Configure Build server: logon failure. In MMC, under Search ->" & vbCRLF &_
"Catalog Build Server -> Properties, check the administrative account" & vbCRLF &_
"on the tab page Accounts, and verify if user and password are correct."
Wizard("CfgBuild_GetCatalogFailed") = "Configure Build server: could not get catalog object"
Wizard("CfgBuild_AddStartPage") = "Configure Build server: error adding start page ""%1"""
Wizard("CfgBuild_AddMapping") = "Configure Build server: error adding mapping ""%1"""
Wizard("CfgBuild_AddSearchServers") = "Configure Build server: error adding search server(s)"
Wizard("UnCfgBuild_Failed") = "Unconfigure Build server: error removing catalog %1"
Wizard("RemoveCatalog_Failed") = "Error removing catalog %1"
Wizard("CheckNTUser_NotFound") = "User %1 was not found in domain %2"
Wizard("CheckNTUser_Failed") = "Error occurred"
Wizard("CheckMemUser_NoMemServer") = "Web site #%1 is not running under Membership"
Wizard("CheckMemUser_LoginFailed") = "Failed to log in with the supplied membership user and password."
End Function
' ====================================================================
' FILE: Schema.vbs
'
' DESCRIPTION: This file contains a library of utility functions for
' managing the U2 schema.
'
' Schema Functions
' ----------------
' CreateAttribute - Creates a new attribute in the schema
' ModifyAttribute - Modifies an existing attribute in the schema
' CreateClass - Creates a new class in the schema
' ModifyClass - Modifies an existing class in the schema
'
' Configuration Functions
' -----------------------
' GetRootDSEObject - Returns the RootDSE configuration object.
' GetDefaultContainerPath - Returns the path to the default container.
' GetSchemaPath - Returns the path to the schema.
'
' Generic Object Functions
' ------------------------
' ADsOpenObject - Connects to the DS an gets an object as the
' specified user.
' DeleteObject - Removes any object from the DS.
' DisplayObject - Displays the attributes and values for any object.
' DisplayContainer - Displays the ADsPath to each child in the
' container.
' Misc. Functions
' ---------------
' ConvertDNToADSPath - Converts a server name and DN to an object
' to a fully qualified DN.
' GetServerNameFromADsPath - Returns the server name and port portion
' of the specified ADsPath.
'
' (C) Copyright 1998 Microsoft Corporation. All Rights Reserved.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF
' ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO
' THE IMPLIED WARRANTIES OF MERCHANTABILITY AND/OR FITNESS FOR A
' PARTICULAR PURPOSE.
' ====================================================================
'**********************************************************************
'
' Constants used by ADSI:
'
'**********************************************************************
const ADS_ATTR_CLEAR = 1
const ADS_ATTR_UPDATE = 2
const ADS_ATTR_APPEND = 3
const ADS_ATTR_DELETE = 4
'**********************************************************************
'
' Schema Functions
'
'**********************************************************************
'======================================================================
' Function: CreateAttribute
'
' Description: Create an attribute in the DS
'
' Parameters: Server to connect to
' Common-name (for scripting, e.g. "cn=myAttribute")
' Display name (for localization, e.g. "My Attribute")
' Description of object
' Attribute syntax (string, integer, etc.)
' Unenforced syntax constraints
' True if object is multivalued, False otherwise
' True if object is searchable, False otherwise
'
' Returns: Nothing
'======================================================================
Sub CreateAttribute (sServer, sCN, sDisplayName, sDescription, _
sSyntax, sConstraint, fMultivalued, fSearchable)
Dim sSchema
Dim oSchema
Dim oAttribute
'
' Get the schema container:
'
sSchema = GetSchemaPath(sServer)
Set oSchema = ADsOpenObject(sSchema, "", "", 0)
'
' Create the object:
'
Set oAttribute = oSchema.Create ("attributeSchema", sCN)
'
' Write out the mandatory properties:
'
oAttribute.Put "attributeSyntax", (sSyntax)
oAttribute.Put "isSingleValued", Abs(Not(fMultivalued))
oAttribute.Put "isSearchable", Abs(fSearchable)
'
' Write out the optional properties, if needed:
'
If Len(sDisplayName) > 0 Then oAttribute.Put "displayName", (sDisplayName)
If Len(sDescription) > 0 Then oAttribute.Put "description", (sDescription)
If Len(sConstraint) > 0 Then oAttribute.Put "syntaxConstraints", (sConstraint)
'
' Save the attribute:
'
oAttribute.SetInfo
End Sub
'======================================================================
' Function: ModifyAttribute
'
' Description: Modify an attribute in the DS.
' Note: The type of the attribute (including multivalued
' and searchable) should not be modified after
' creation.
'
' Parameters: Server to connect to
' Common-name (for scripting, e.g. "cn=myAttribute")
' Display name (for localization, e.g. "My Attribute")
' Description of object
' Unenforced syntax constraints
'
' Returns: Nothing
'======================================================================
Sub ModifyAttribute (sServer, sCN, sDisplayName, sDescription, _
sConstraint)
Dim sAttribute
Dim oAttribute
'
' Get the schema container:
'
sAttribute = GetSchemaPath(sServer) & "/" & sCN
Response.Write sAttribute
Set oAttribute = ADsOpenObject(sAttribute, "", "", 0)
'
' Write out the optional properties or clear them, if needed:
'
If Len(sDisplayName) > 0 Then
oAttribute.Put "displayName", (sDisplayName)
Else
oAttribute.PutEx ADS_ATTR_CLEAR, "displayName", (sDisplayName)
End If
If Len(sDescription) > 0 Then
oAttribute.Put "description", (sDescription)
Else
oAttribute.PutEx ADS_ATTR_CLEAR, "description", (sDescription)
End If
If Len(sConstraint) > 0 Then
oAttribute.Put "syntaxConstraints", (sConstraint)
Else
oAttribute.PutEx ADS_ATTR_CLEAR, "syntaxConstraints", (sConstraint)
End If
'
' Save the attribute:
'
oAttribute.SetInfo
End Sub
'======================================================================
' Function: CreateClass
'
' Description: Create a class object in the DS
'
' Parameters: Server to connect to
' Common-name (for scripting, e.g. "cn=myAttribute")
' Display name (for localization, e.g. "My Attribute")
' Description of object
' Array of mandatory attributes (by name)
' Array of optional attributes (by name)
' The RDN attribute id (normally "cn")
' Array of parent classes (by name, normally "organizationalUnit")
' True if the class is a container (normally false)
' Flags to specify the type of container (normally 0)
' True if the class is a security principal (normally false)
'
' Returns: Nothing
'======================================================================
Sub CreateClass (sCN, sDisplayName, sDescription, _
asMustContain, asMayContain, sRDNAttributeId, _
asPossibleSuperiors, fContainer, fContainerType, _
fSecurityPrincipal)
Dim sSchema
Dim oSchema
Dim oClass
Dim sServer
'
' Get the schema container:
'
Dim MemServerID
FindMembershipServer "E-Enterprise", MemServerID
if MemServerID = 0 then
RaiseError Wizard("Mem_ServerNotFound")
Exit Sub
End If
Dim BrokConfig
Set BrokConfig = MemCreateObj(MBS_OBJ_BROKCFG)
BrokConfig.GetConfig MemServerID
RaiseOnError Wizard("Mem_GetBrokCfgFailed")
If Not IsErrorClear Then
exit sub
End If
Dim LDAPPort,LDAPHost
LDAPPort = BrokConfig.lPort
LDAPHost = BrokConfig.bszServerName
sServer = LDAPHost & ":" & LDAPPort
' Create Attribute ProfileGroupDNs
CreateAttribute sServer, "cn=ProfileGroupDNs", "ProfileGroupDNs", "ProfileGroupDNs", "DN", "", True, True
sSchema = GetSchemaPath(sServer)
Set oSchema = ADsOpenObject(sSchema, "", "", 0)
'
' Create the object:
'
Set oClass = oSchema.Create ("classSchema", sCN)
'
' Make sure our arrays are really arrays:
'
If IsArray(asMustContain) = False Then asMustContain = Array(asMustContain)
If IsArray(asPossibleSuperiors) = False Then asPossibleSuperiors = Array(asPossibleSuperiors)
If IsArray(asMayContain) = False Then asMayContain = Array(asMayContain)
'
' Write out the mandatory properties:
'
oClass.Put "mustContain", (asMustContain)
oClass.Put "rdnAttId", (sRDNAttributeId)
oClass.Put "possSuperiors", (asPossibleSuperiors)
oClass.Put "isContainer", Abs(fContainer)
oClass.Put "containerType", CInt(fContainerType)
oClass.Put "isSecurityPrincipal", Abs(fSecurityPrincipal)
oClass.Put "mayContain", (asMayContain)
'
' Write out the optional properties, if needed:
'
If Len(sDisplayName) > 0 Then oClass.Put "displayName", (sDisplayName)
If Len(sDescription) > 0 Then oClass.Put "description", (sDescription)
'
' Save the class:
'
oClass.SetInfo
End Sub
'======================================================================
' Function: ModifyClass
'
' Description: Modifies a class object in the DS
'
' Parameters: Server to connect to
' Common-name (for scripting, e.g. "cn=myAttribute")
' Display name (for localization, e.g. "My Attribute")
' Description of object
' Array of mandatory attributes (by name)
' Array of optional attributes (by name)
' Array of parent classes (by name, normally "organizationalUnit")
' True if the class is a container (normally false)
' Flags to specify the type of container (normally 0)
' True if the class is a security principal (normally false)
'
' Returns: Nothing
'======================================================================
Sub ModifyClass (sServer, sCN, sDisplayName, sDescription, _
asMustContain, asMayContain, asPossibleSuperiors, _
fContainer, fContainerType, fSecurityPrincipal)
Dim sClass
Dim oClass
'
' Get the class object:
'
sClass = GetSchemaPath(sServer) & "/" & sCN
Set oClass = ADsOpenObject(sClass, "", "", 0)
'
' Make sure our arrays are really arrays:
'
If IsArray(asMustContain) = False Then asMustContain = Array(asMustContain)
If IsArray(asPossibleSuperiors) = False Then asPossibleSuperiors = Array(asPossibleSuperiors)
If (IsArray(asMayContain) = False) And (Len(asMayContain) > 0) Then
asMayContain = Array(asMayContain)
End If
'
' Write out the mandatory properties:
'
oClass.Put "mustContain", (asMustContain)
oClass.Put "possSuperiors", (asPossibleSuperiors)
oClass.Put "isContainer", Abs(fContainer)
oClass.Put "containerType", CInt(fContainerType)
oClass.Put "isSecurityPrincipal", Abs(fSecurityPrincipal)
'
' Write out the optional properties, if needed:
'
If Len(sDisplayName) > 0 Then oClass.Put "displayName", (sDisplayName)
If Len(sDescription) > 0 Then oClass.Put "description", (sDescription)
If IsArray(asMayContain) = True Then oClass.Put "mayContain", (asMayContain)
'
' Save the class:
'
oClass.SetInfo
End Sub
'**********************************************************************
'
' Configuration Functions
'
'**********************************************************************
'======================================================================
' Function: GetRootDSEObject
'
' Description: Returns the root DSE object for a server.
'
' Parameters: The server to connect to.
'
' Returns: The ADS object that is the root DSE.
'======================================================================
Function GetRootDSEObject (sServer)
'
' Note: The RootDSE object is a special configuration object
' that can not be secured. In order to get this object,
' a special flag (ADS_NO_AUTHENTICATION [16]) needs to
' be passed to ADSI so ADSI will not attempt to bind to
' the DS.
'
Set GetRootDSEObject = ADsOpenObject("LDAP://" & sServer & "/RootDSE", "", "", 16)
End Function
'======================================================================
' Function: GetDefaultContainerPath
'
' Description: Returns the ADsPath to the default container for the
' specified server.
'
' Parameters: The server to connect to.
'
' Returns: The resulting ADsPath to the default container.
'======================================================================
Function GetDefaultContainerPath (sServer)
Dim oRootDSE
Set oRootDSE = GetRootDSEObject(sServer)
GetDefaultContainerPath = ConvertDNToADsPath(sServer, oRootDSE.Get("defaultNamingContext"))
End Function
'======================================================================
' Function: GetSchemaPath
'
' Description: Returns the ADsPath to the schema for the specified
' server.
'
' Parameters: The server to connect to.
'
' Returns: The resulting ADsPath to the schema.
'======================================================================
Function GetSchemaPath (sServer)
Dim oRootDSE
Set oRootDSE = GetRootDSEObject(sServer)
GetSchemaPath = ConvertDNToADsPath(sServer, oRootDSE.Get("subSchemaSubEntry"))
End Function
'**********************************************************************
'
' Generic Object Functions
'
'**********************************************************************
'======================================================================
' Function: ADsOpenObject
'
' Description: Gets the specified object from the DS using the
' supplied credentials.
'
' Parameters: Path to object to get.
' Username to bind with.
' Password to bind with.
' Flags to pass to ADSI.
'
' Returns: Nothing
'======================================================================
Function ADsOpenObject(sADsPath, sUsername, sPassword, fFlags)
Dim oSecureCreator
Set oSecureCreator = GetObject("LDAP:")
Set ADsOpenObject = oSecureCreator.OpenDSObject(sADsPath, sUsername, sPassword, fFlags)
End Function
'======================================================================
' Function: DeleteObject
'
' Description: Delete any object from the DS
'
' Parameters: Path to object to delete.
'
' Returns: Nothing
'======================================================================
Sub DeleteObject (sADsPath)
Dim oObject
Dim oParent
Set oObject = ADsOpenObject(sADsPath, "", "", 0)
Set oParent = ADsOpenObject(oObject.Parent, "", "", 0)
oParent.Delete oObject.Class, oObject.Name
End Sub
'======================================================================
' Function: DisplayObject
'
' Description: Displays all of the attributes and values for the
' specified object.
'
' Parameters: ADsPath to the object to display.
'
' Returns: The resulting ADsPath
'======================================================================
Sub DisplayObject (sObjectPath)
On Error Resume Next
Dim oObject
Dim oClass
DIm Properties
Dim Property
Dim Values
Dim Value
'
' Get the object and it's schema:
'
Set oObject = ADsOpenObject(sObjectPath, "", "", 0)
Set oClass = ADsOpenObject(oObject.Schema, "", "", 0)
'
' Display the basic object information:
'
Response.Write oObject.ADsPath
'
' Loop through the mandatory properties:
'
Properties = oClass.MandatoryProperties
For Each Property In Properties
Response.Write "[" & Property & "]"
Values = oObject.GetEx(Property)
For Each Value In Values
Response.Write vbTab & Value
Next
Values = ""
Next
'
' Loop through the optional properties:
'
Properties = oClass.OptionalProperties
For Each Property In Properties
Response.Write "[" & Property & "]"
Values = oObject.GetEx(Property)
For Each Value In Values
Response.Write vbTab & Value
Next
Values = ""
Next
End Sub
'======================================================================
' Function: DisplayContainer
'
' Description: Displays the ADsPath to each child in the container.
'
' Parameters: Path to container to display.
'
' Returns: Nothing
'======================================================================
Sub DisplayContainer (sADsPath)
Dim oContainer: Set oContainer = ADsOpenObject(sADsPath, "", "", 0)
Dim oChild
'
' Enumerate through each object in the container:
'
For Each oChild In oContainer
'
' Display the object's ADsPath:
'
Response.Write oChild.ADsPath
'
' Note: Uncomment the following line to display all of the
' attributes of each child:
'
'DisplayObject oChild.ADsPath
Next
End Sub
'**********************************************************************
'
' Misc. Functions
'
'**********************************************************************
'======================================================================
' Function: ConvertDNToADSPath
'
' Description: Converts the specified DN and server name to an
' ADsPath
'
' Parameters: Server part of the ADsPath
' DN to append to the server part in ADsPath format.
'
' Returns: The resulting ADsPath
'======================================================================
Function ConvertDNToADsPath(sServer, sDN)
Dim asDNs: asDNs = Split(sDN, ",")
Dim iIndex
Dim sADsPath
sADSPath = "LDAP://" & sServer
For iIndex = UBound(asDNs) To LBound(asDNs) Step - 1
sADSPath = sADSPath & "/" + asDNs(iIndex)
Next
ConvertDNToADSPath = sADSPath
End Function
'======================================================================
' Function: GetServerNameFromADsPath
'
' Description: Returns the name of the LDAP server in a valid ADsPath.
'
' Parameters: Server part of the ADsPath
' DN to append to the server part in ADsPath format.
'
' Returns: The resulting server name, or nothing if the result
' is invalid.
'======================================================================
Function GetServerNameFromADsPath(sADsPath)
Dim sServer
Dim iEndOfServer
'
' Is this a valid LDAP:// ADsPath?
'
If Left(sADsPath, 6) <> "LDAP://" Then
'
' Where does the Server name end?
'
iEndOfServer = Instr(8, sADsPath, "/")
If iEndOfServer > 0 Then
sServer = Mid(sADsPath, 8, iEndOfServer - 8)
Else
sServer = Mid(sADsPath, 8)
End If
End If
GetServerNameFromADsPath = sServer
End Function
'%>