helpers.vbs@ 89795

Last change on this file since 89795 was 87407, checked in by vboxsync, 4 years ago
configure.vbs,tools/envSub.vbs,helpers.vbs: DbgPrint for DirExits and FileExists.
Property svn:eol-style set to `CRLF` Property svn:keywords set to `Id`
File size: 54.6 KB

Line
1	' $Id: helpers.vbs 87407 2021-01-24 16:58:27Z vboxsync $
2	'' @file
3	' Common VBScript helpers used by configure.vbs and later others.
4	'
5	' Requires the script including it to define a LogPrint function.
6	'
7
8	'
9	' Copyright (C) 2006-2020 Oracle Corporation
10	'
11	' This file is part of VirtualBox Open Source Edition (OSE), as
12	' available from http://www.virtualbox.org. This file is free software;
13	' you can redistribute it and/or modify it under the terms of the GNU
14	' General Public License (GPL) as published by the Free Software
15	' Foundation, in version 2 as it comes in the "COPYING" file of the
16	' VirtualBox OSE distribution. VirtualBox OSE is distributed in the
17	' hope that it will be useful, but WITHOUT ANY WARRANTY of any kind.
18	'
19
20
21	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
22	' Global Variables '
23	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
24	dim g_objShell
25	Set g_objShell = WScript.CreateObject("WScript.Shell")
26
27	dim g_objFileSys
28	Set g_objFileSys = WScript.CreateObject("Scripting.FileSystemObject")
29
30	'' Whether to ignore (continue) on errors.
31	dim g_blnContinueOnError
32	g_blnContinueOnError = False
33
34	'' The script's exit code (for ignored errors).
35	dim g_rcScript
36	g_rcScript = 0
37
38
39	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
40	' Helpers: Paths '
41	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
42
43	''
44	' Converts to unix slashes
45	function UnixSlashes(str)
46	UnixSlashes = replace(str, "\", "/")
47	end function
48
49
50	''
51	' Converts to dos slashes
52	function DosSlashes(str)
53	DosSlashes = replace(str, "/", "\")
54	end function
55
56
57	''
58	' Get the path of the parent directory. Returns root if root was specified.
59	' Expects abs path.
60	function PathParent(str)
61	PathParent = g_objFileSys.GetParentFolderName(DosSlashes(str))
62	end function
63
64
65	''
66	' Strips the filename from at path.
67	function PathStripFilename(str)
68	PathStripFilename = g_objFileSys.GetParentFolderName(DosSlashes(str))
69	end function
70
71
72	''
73	' Get the abs path, use the short version if necessary.
74	function PathAbs(str)
75	strAbs = g_objFileSys.GetAbsolutePathName(DosSlashes(str))
76	strParent = g_objFileSys.GetParentFolderName(strAbs)
77	if strParent = "" then
78	PathAbs = strAbs
79	else
80	strParent = PathAbs(strParent) ' Recurse to resolve parent paths.
81	PathAbs = g_objFileSys.BuildPath(strParent, g_objFileSys.GetFileName(strAbs))
82
83	dim obj
84	set obj = Nothing
85	if FileExists(PathAbs) then
86	set obj = g_objFileSys.GetFile(PathAbs)
87	elseif DirExists(PathAbs) then
88	set obj = g_objFileSys.GetFolder(PathAbs)
89	end if
90
91	if not (obj is nothing) then
92	for each objSub in obj.ParentFolder.SubFolders
93	if obj.Name = objSub.Name or obj.ShortName = objSub.ShortName then
94	if InStr(1, objSub.Name, " ") > 0 _
95	Or InStr(1, objSub.Name, "&") > 0 _
96	Or InStr(1, objSub.Name, "$") > 0 _
97	then
98	PathAbs = g_objFileSys.BuildPath(strParent, objSub.ShortName)
99	if InStr(1, PathAbs, " ") > 0 _
100	Or InStr(1, PathAbs, "&") > 0 _
101	Or InStr(1, PathAbs, "$") > 0 _
102	then
103	MsgFatal "PathAbs(" & str & ") attempted to return filename with problematic " _
104	& "characters in it (" & PathAbs & "). The tool/sdk referenced will probably " _
105	& "need to be copied or reinstalled to a location without 'spaces', '$', ';' " _
106	& "or '&' in the path name. (Unless it's a problem with this script of course...)"
107	end if
108	else
109	PathAbs = g_objFileSys.BuildPath(strParent, objSub.Name)
110	end if
111	exit for
112	end if
113	next
114	end if
115	end if
116	end function
117
118
119	''
120	' Get the abs path, use the long version.
121	function PathAbsLong(str)
122	strAbs = g_objFileSys.GetAbsolutePathName(DosSlashes(str))
123	strParent = g_objFileSys.GetParentFolderName(strAbs)
124	if strParent = "" then
125	PathAbsLong = strAbs
126	else
127	strParent = PathAbsLong(strParent) ' Recurse to resolve parent paths.
128	PathAbsLong = g_objFileSys.BuildPath(strParent, g_objFileSys.GetFileName(strAbs))
129
130	dim obj
131	set obj = Nothing
132	if FileExists(PathAbsLong) then
133	set obj = g_objFileSys.GetFile(PathAbsLong)
134	elseif DirExists(PathAbsLong) then
135	set obj = g_objFileSys.GetFolder(PathAbsLong)
136	end if
137
138	if not (obj is nothing) then
139	for each objSub in obj.ParentFolder.SubFolders
140	if obj.Name = objSub.Name or obj.ShortName = objSub.ShortName then
141	PathAbsLong = g_objFileSys.BuildPath(strParent, objSub.Name)
142	exit for
143	end if
144	next
145	end if
146	end if
147	end function
148
149
150	''
151	' Compare two paths w/o abspathing them.
152	'
153	' Ignores case, slash direction, multiple slashes and single dot components.
154	'
155	function PathMatch(strPath1, strPath2)
156	PathMatch = true
157	if StrComp(strPath1, strPath2, vbTextCompare) <> 0 then
158	strPath1 = DosSlashes(strPath1)
159	strPath2 = DosSlashes(strPath2)
160	if StrComp(strPath1, strPath2, vbTextCompare) <> 0 then
161	' Compare character by character
162	dim off1 : off1 = 1
163	dim off2 : off2 = 1
164
165	' Compare UNC prefix if any, because the code below cannot handle it. UNC has exactly two slashes.
166	if Mid(strPath1, 1, 2) = "\\" and Mid(strPath2, 1, 2) = "\\" then
167	if (Mid(strPath1, 3, 1) = "\") <> (Mid(strPath2, 3, 1) = "\") then
168	PathMatch = false
169	exit function
170	end if
171	off1 = off1 + 2
172	off2 = off2 + 2
173	if Mid(strPath1, 3, 1) = "\" then
174	off1 = PathMatchSkipSlashesAndSlashDotHelper(strPath1, off1)
175	off2 = PathMatchSkipSlashesAndSlashDotHelper(strPath2, off2)
176	end if
177	end if
178
179	' Compare the rest.
180	dim ch1, ch2
181	do while off1 <= Len(strPath1) and off2 <= Len(strPath2)
182	ch1 = Mid(strPath1, off1, 1)
183	ch2 = Mid(strPath2, off2, 1)
184	if StrComp(ch1, ch2, vbTextCompare) = 0 then
185	off1 = off1 + 1
186	off2 = off2 + 1
187	if ch1 = "\" then
188	off1 = PathMatchSkipSlashesAndSlashDotHelper(strPath1, off1)
189	off2 = PathMatchSkipSlashesAndSlashDotHelper(strPath2, off2)
190	end if
191	else
192	PathMatch = False
193	exit function
194	end if
195	loop
196
197	' One or both of the strings ran out. That's fine if we've only got slashes
198	' and "." components left in the other.
199	if off1 <= Len(strPath1) and Mid(strPath1, off1, 1) = "\" then
200	off1 = PathMatchSkipSlashesAndSlashDotHelper(strPath1, off1 + 1)
201	end if
202	if off2 <= Len(strPath2) and Mid(strPath2, off2, 1) = "\" then
203	off2 = PathMatchSkipSlashesAndSlashDotHelper(strPath2, off2 + 1)
204	end if
205	PathMatch = off1 > Len(strPath1) and off2 > Len(strPath2)
206	end if
207	end if
208	end function
209
210	'' PathMatch helper
211	function PathMatchSkipSlashesAndSlashDotHelper(strPath, off)
212	dim ch
213	do while off <= Len(strPath)
214	ch = Mid(strPath, off, 1)
215	if ch = "\" then
216	off = off + 1
217	elseif ch = "." and off = Len(strPath) then
218	off = off + 1
219	elseif ch = "." and Mid(strPath, off, 2) = ".\" then
220	off = off + 2
221	else
222	exit do
223	end if
224	loop
225	PathMatchSkipSlashesAndSlashDotHelper = off
226	end function
227
228
229	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
230	' Helpers: Files and Dirs '
231	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
232
233	''
234	' Read a file (typically the tmp file) into a string.
235	function FileToString(strFilename)
236	const ForReading = 1, TristateFalse = 0
237	dim objLogFile, str
238
239	set objFile = g_objFileSys.OpenTextFile(DosSlashes(strFilename), ForReading, False, TristateFalse)
240	str = objFile.ReadAll()
241	objFile.Close()
242
243	FileToString = str
244	end function
245
246
247	''
248	' Deletes a file
249	sub FileDelete(strFilename)
250	if g_objFileSys.FileExists(DosSlashes(strFilename)) then
251	g_objFileSys.DeleteFile(DosSlashes(strFilename))
252	end if
253	end sub
254
255
256	''
257	' Appends a line to an ascii file.
258	sub FileAppendLine(strFilename, str)
259	const ForAppending = 8, TristateFalse = 0
260	dim objFile
261
262	set objFile = g_objFileSys.OpenTextFile(DosSlashes(strFilename), ForAppending, True, TristateFalse)
263	objFile.WriteLine(str)
264	objFile.Close()
265	end sub
266
267
268	''
269	' Checks if the file exists.
270	function FileExists(strFilename)
271	FileExists = g_objFileSys.FileExists(DosSlashes(strFilename))
272	DbgPrint "FileExists(" & strFilename & ") -> " & FileExists
273	end function
274
275
276	''
277	' Checks if the directory exists.
278	function DirExists(strDirectory)
279	DirExists = g_objFileSys.FolderExists(DosSlashes(strDirectory))
280	DbgPrint "DirExists(" & strDirectory & ") -> " & DirExists
281	end function
282
283
284	''
285	' Returns true if there are subfolders starting with the given string.
286	function HasSubdirsStartingWith(strFolder, strStartingWith)
287	HasSubdirsStartingWith = False
288	if DirExists(strFolder) then
289	dim obj
290	set obj = g_objFileSys.GetFolder(strFolder)
291	for each objSub in obj.SubFolders
292	if StrComp(Left(objSub.Name, Len(strStartingWith)), strStartingWith) = 0 then
293	HasSubdirsStartingWith = True
294	LogPrint "# HasSubdirsStartingWith(" & strFolder & "," & strStartingWith & ") found " & objSub.Name
295	exit for
296	end if
297	next
298	end if
299	end function
300
301
302	''
303	' Returns a sorted array of subfolder names that starts with the given string.
304	function GetSubdirsStartingWith(strFolder, strStartingWith)
305	if DirExists(strFolder) then
306	dim obj, i
307	set obj = g_objFileSys.GetFolder(strFolder)
308	i = 0
309	for each objSub in obj.SubFolders
310	if StrComp(Left(objSub.Name, Len(strStartingWith)), strStartingWith) = 0 then
311	i = i + 1
312	end if
313	next
314	if i > 0 then
315	redim arrResult(i - 1)
316	i = 0
317	for each objSub in obj.SubFolders
318	if StrComp(Left(objSub.Name, Len(strStartingWith)), strStartingWith) = 0 then
319	arrResult(i) = objSub.Name
320	i = i + 1
321	end if
322	next
323	GetSubdirsStartingWith = arrResult
324	else
325	GetSubdirsStartingWith = Array()
326	end if
327	else
328	GetSubdirsStartingWith = Array()
329	end if
330	end function
331
332
333	''
334	' Returns a sorted array of subfolder names that starts with the given string.
335	function GetSubdirsStartingWithVerSorted(strFolder, strStartingWith)
336	GetSubdirsStartingWithVerSorted = ArrayVerSortStrings(GetSubdirsStartingWith(strFolder, strStartingWith))
337	end function
338
339
340	''
341	' Returns a reverse version sorted array of subfolder names that starts with the given string.
342	function GetSubdirsStartingWithRVerSorted(strFolder, strStartingWith)
343	GetSubdirsStartingWithRVerSorted = ArrayRVerSortStrings(GetSubdirsStartingWith(strFolder, strStartingWith))
344	end function
345
346
347	''
348	' Try find the specified file in the specified path variable.
349	function WhichEx(strEnvVar, strFile)
350	dim strPath, iStart, iEnd, str
351
352	' the path
353	strPath = EnvGet(strEnvVar)
354	iStart = 1
355	do while iStart <= Len(strPath)
356	iEnd = InStr(iStart, strPath, ";")
357	if iEnd <= 0 then iEnd = Len(strPath) + 1
358	if iEnd > iStart then
359	str = Mid(strPath, iStart, iEnd - iStart) & "/" & strFile
360	if FileExists(str) then
361	WhichEx = str
362	exit function
363	end if
364	end if
365	iStart = iEnd + 1
366	loop
367
368	' registry or somewhere?
369
370	WhichEx = ""
371	end function
372
373
374	''
375	' Try find the specified file in the path.
376	function Which(strFile)
377	Which = WhichEx("Path", strFile)
378	end function
379
380
381	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
382	' Helpers: Processes '
383	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
384
385	''
386	' Checks if this is a WOW64 process.
387	function IsWow64()
388	if g_objShell.Environment("PROCESS")("PROCESSOR_ARCHITEW6432") <> "" then
389	IsWow64 = 1
390	else
391	IsWow64 = 0
392	end if
393	end function
394
395
396	''
397	' Executes a command in the shell catching output in strOutput
398	function Shell(strCommand, blnBoth, ByRef strOutput)
399	dim strShell, strCmdline, objExec, str
400
401	strShell = g_objShell.ExpandEnvironmentStrings("%ComSpec%")
402	if blnBoth = true then
403	strCmdline = strShell & " /c " & strCommand & " 2>&1"
404	else
405	strCmdline = strShell & " /c " & strCommand & " 2>nul"
406	end if
407
408	LogPrint "# Shell: " & strCmdline
409	Set objExec = g_objShell.Exec(strCmdLine)
410	strOutput = objExec.StdOut.ReadAll()
411	objExec.StdErr.ReadAll()
412	do while objExec.Status = 0
413	Wscript.Sleep 20
414	strOutput = strOutput & objExec.StdOut.ReadAll()
415	objExec.StdErr.ReadAll()
416	loop
417
418	LogPrint "# Status: " & objExec.ExitCode
419	LogPrint "# Start of Output"
420	LogPrint strOutput
421	LogPrint "# End of Output"
422
423	Shell = objExec.ExitCode
424	end function
425
426
427	''
428	' Gets the SID of the current user.
429	function GetSid()
430	dim objNet, strUser, strDomain, offSlash, objWmiUser
431	GetSid = ""
432
433	' Figure the user + domain
434	set objNet = CreateObject("WScript.Network")
435	strUser = objNet.UserName
436	strDomain = objNet.UserDomain
437	offSlash = InStr(1, strUser, "\")
438	if offSlash > 0 then
439	strDomain = Left(strUser, offSlash - 1)
440	strUser = Right(strUser, Len(strUser) - offSlash)
441	end if
442
443	' Lookup the user.
444	on error resume next
445	set objWmiUser = GetObject("winmgmts:{impersonationlevel=impersonate}!/root/cimv2:Win32_UserAccount." _
446	& "Domain='" & strDomain &"',Name='" & strUser & "'")
447	if err.number = 0 then
448	GetSid = objWmiUser.SID
449	end if
450	end function
451
452
453	''
454	' Gets the commandline used to invoke the script.
455	function GetCommandline()
456	dim str, i
457
458	'' @todo find an api for querying it instead of reconstructing it like this...
459	GetCommandline = "cscript configure.vbs"
460	for i = 1 to WScript.Arguments.Count
461	str = WScript.Arguments.Item(i - 1)
462	if str = "" then
463	str = """"""
464	elseif (InStr(1, str, " ")) then
465	str = """" & str & """"
466	end if
467	GetCommandline = GetCommandline & " " & str
468	next
469	end function
470
471
472	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
473	' Helpers: Environment '
474	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
475
476	''
477	' Gets an environment variable.
478	function EnvGet(strName)
479	EnvGet = g_objShell.Environment("PROCESS")(strName)
480	end function
481
482
483	''
484	' Gets an environment variable with default value if not found.
485	function EnvGetDef(strName, strDefault)
486	dim strValue
487	strValue = g_objShell.Environment("PROCESS")(strName)
488	if strValue = "" or IsNull(strValue) or IsEmpty(strValue) then
489	EnvGetDef = strDefault
490	else
491	EnvGetDef = strValue
492	end if
493	end function
494
495
496	''
497	' Gets an environment variable with default value if not found or not
498	' in the array of valid values. Issue warning about invalid values.
499	function EnvGetDefValid(strName, strDefault, arrValidValues)
500	dim strValue
501	strValue = g_objShell.Environment("PROCESS")(strName)
502	if strValue = "" or IsNull(strValue) or IsEmpty(strValue) then
503	EnvGetDefValid = strDefault
504	elseif not ArrayContainsString(arrValidValues, strValue) then
505	MsgWarning "Invalid value " & strName & " value '" & EnvGetDefValid & "', using '" & strDefault & "' instead."
506	EnvGetDefValid = strDefault
507	else
508	EnvGetDefValid = strValue
509	end if
510	end function
511
512
513	''
514	' Sets an environment variable.
515	sub EnvSet(strName, strValue)
516	g_objShell.Environment("PROCESS")(strName) = strValue
517	LogPrint "EnvSet: " & strName & "=" & strValue
518	end sub
519
520
521	''
522	' Prepends a string to an Path-like environment variable.
523	function EnvPrependItemEx(strName, strItem, strSep, blnKeepEmpty, ByRef fnItemMatcher)
524	dim strValue
525	strValue = EnvRemoveItemEx(strName, strItem, strSep, blnKeepEmpty, fnItemMatcher, "EnvPrependItemEx")
526	if strValue <> "" then
527	strValue = strItem & strSep & strValue
528	else
529	strValue = strItem
530	end if
531	g_objShell.Environment("PROCESS")(strName) = strValue
532	EnvPrependItemEx = strValue
533	end function
534
535
536	''
537	' Appends a string to an Path-like environment variable,
538	function EnvAppendItemEx(strName, strItem, strSep, blnKeepEmpty, ByRef fnItemMatcher)
539	dim strValue
540	strValue = EnvRemoveItemEx(strName, strItem, strSep, blnKeepEmpty, fnItemMatcher, "EnvAppendItemEx")
541	if strValue <> "" then
542	strValue = strValue & strSep & strItem
543	else
544	strValue = strItem
545	end if
546	g_objShell.Environment("PROCESS")(strName) = strValue
547	EnvAppendItemEx = strValue
548	end function
549
550
551	''
552	' Generic item remover.
553	'
554	' fnItemMatcher(strItem1, strItem2)
555	'
556	function EnvRemoveItemEx(strName, strItem, strSep, blnKeepEmpty, ByRef fnItemMatcher, strCaller)
557	dim strValue, off
558	strValue = g_objShell.Environment("PROCESS")(strName)
559	EnvRemoveItemEx = strValue
560	if strValue <> "" then
561	' Split it up into an array of items
562	dim arrItems : arrItems = Split(strValue, strSep, -1, vbTextCompare)
563
564	' Create an array of matching indexes that we should remove.
565	dim cntToRemove : cntToRemove = 0
566	redim arrIdxToRemove(ArraySize(arrItems) - 1)
567	dim i, strCur
568	for i = LBound(arrItems) to UBound(arrItems)
569	strCur = arrItems(i)
570	if fnItemMatcher(strCur, strItem) or (not blnKeepEmpty and strCur = "") then
571	arrIdxToRemove(cntToRemove) = i
572	cntToRemove = cntToRemove + 1
573	end if
574	next
575
576	' Did we find anthing to remove?
577	if cntToRemove > 0 then
578	' Update the array and join it up again.
579	for i = cntToRemove - 1 to 0 step -1
580	arrItems = ArrayRemove(arrItems, arrIdxToRemove(i))
581	next
582	dim strNewValue : strNewValue = ArrayJoinString(arrItems, strSep)
583	EnvRemoveItemEx = strNewValue
584
585	' Update the environment variable.
586	LogPrint strCaller &": " & strName & ": '" & strValue & "' --> '" & strNewValue & "'"
587	g_objShell.Environment("PROCESS")(strName) = strNewValue
588	end if
589	end if
590	end function
591
592
593	''
594	' Generic case-insensitive item matcher.
595	' See also PathMatch().
596	function EnvItemMatch(strItem1, strItem2)
597	EnvItemMatch = (StrComp(strItem1, strItem2) = 0)
598	end function
599
600
601	''
602	' Prepends an item to an environment variable, after first removing any
603	' existing ones (case-insensitive, preserves empty elements).
604	function EnvPrependItem(strName, strItem, strSep)
605	EnvPrependItem = EnvPrependItemEx(strName, strItem, strSep, true, GetRef("EnvItemMatch"))
606	LogPrint "EnvPrependItem: " & strName & "=" & EnvPrependPathItem
607	end function
608
609
610	''
611	' Appends an item to an environment variable, after first removing any
612	' existing ones (case-insensitive, preserves empty elements).
613	function EnvAppendItem(strName, strItem, strSep)
614	EnvAppendItem = EnvAppendItemEx(strName, strItem, strSep, true, GetRef("EnvItemMatch"))
615	LogPrint "EnvAppendItem: " & strName & "=" & EnvPrependPathItem
616	end function
617
618
619	''
620	' Removes a string element from an environment variable, case
621	' insensitive but preserving empty elements.
622	function EnvRemoveItem(strName, strItem, strSep)
623	EnvRemoveItem = EnvRemoveItemEx(strName, strIten, strSep, true, GetRef("EnvItemMatch"), "EnvRemoveItem")
624	end function
625
626
627	''
628	' Appends a string to an Path-like environment variable,
629	function EnvPrependPathItem(strName, strItem, strSep)
630	EnvPrependPathItem = EnvPrependItemEx(strName, strItem, strSep, false, GetRef("PathMatch"))
631	LogPrint "EnvPrependPathItem: " & strName & "=" & EnvPrependPathItem
632	end function
633
634
635	''
636	' Appends a string to an Path-like environment variable,
637	function EnvAppendPathItem(strName, strItem, strSep)
638	EnvAppendPathItem = EnvAppendItemEx(strName, strItem, strSep, false, GetRef("PathMatch"))
639	LogPrint "EnvAppendPathItem: " & strName & "=" & EnvAppendPathItem
640	end function
641
642
643	''
644	' Removes a string element from an Path-like environment variable, case
645	' insensitive and treating forward and backward slashes the same way.
646	function EnvRemovePathItem(strName, strItem, strSep)
647	EnvRemovePathItem = EnvRemoveItemEx(strName, strIten, strSep, false, GetRef("PathMatch"), "EnvRemovePathItem")
648	end function
649
650
651	''
652	' Prepends a string to an environment variable
653	sub EnvUnset(strName)
654	g_objShell.Environment("PROCESS").Remove(strName)
655	LogPrint "EnvUnset: " & strName
656	end sub
657
658
659	''
660	' Gets the first non-empty environment variable of the given two.
661	function EnvGetFirst(strName1, strName2)
662	EnvGetFirst = g_objShell.Environment("PROCESS")(strName1)
663	if EnvGetFirst = "" then
664	EnvGetFirst = g_objShell.Environment("PROCESS")(strName2)
665	end if
666	end function
667
668	''
669	' Checks if the given enviornment variable exists.
670	function EnvExists(strName)
671	EnvExists = g_objShell.Environment("PROCESS")(strName) <> ""
672	end function
673
674
675	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
676	' Helpers: Strings '
677	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
678
679	''
680	' Right pads a string with spaces to the given length
681	function RightPad(str, cch)
682	if Len(str) < cch then
683	RightPad = str & String(cch - Len(str), " ")
684	else
685	RightPad = str
686	end if
687	end function
688
689
690	''
691	' Checks if the given character is a decimal digit
692	function CharIsDigit(ch)
693	CharIsDigit = (InStr(1, "0123456789", ch) > 0)
694	end function
695
696	''
697	' Worker for StrVersionCompare
698	' The offset is updated to point to the first non-digit character.
699	function CountDigitsIgnoreLeadingZeros(ByRef str, ByRef off)
700	dim cntDigits, blnLeadingZeros, ch, offInt
701	cntDigits = 0
702	if CharIsDigit(Mid(str, off, 1)) then
703	' Rewind to start of digest sequence.
704	do while off > 1
705	if not CharIsDigit(Mid(str, off - 1, 1)) then exit do
706	off = off - 1
707	loop
708	' Count digits, ignoring leading zeros.
709	blnLeadingZeros = True
710	for off = off to Len(str)
711	ch = Mid(str, off, 1)
712	if CharIsDigit(ch) then
713	if ch <> "0" or blnLeadingZeros = False then
714	cntDigits = cntDigits + 1
715	blnLeadingZeros = False
716	end if
717	else
718	exit for
719	end if
720	next
721	' If all zeros, count one of them.
722	if cntDigits = 0 then cntDigits = 1
723	end if
724	CountDigitsIgnoreLeadingZeros = cntDigits
725	end function
726
727	''
728	' Very simple version string compare function.
729	' @returns < 0 if str1 is smaller than str2
730	' @returns 0 if str1 and str2 are equal
731	' @returns > 1 if str2 is larger than str1
732	function StrVersionCompare(str1, str2)
733	' Compare the strings. We can rely on StrComp if equal or one is empty.
734	'LogPrint "StrVersionCompare("&str1&","&str2&"):"
735	StrVersionCompare = StrComp(str2, str1)
736	if StrVersionCompare <> 0 then
737	dim cch1, cch2, off1, off2, ch1, ch2, chPrev1, chPrev2, intDiff, cchDigits
738	cch1 = Len(str1)
739	cch2 = Len(str2)
740	if cch1 > 0 and cch2 > 0 then
741	' Compare the common portion
742	off1 = 1
743	off2 = 1
744	chPrev1 = "x"
745	chPrev2 = "x"
746	do while off1 <= cch1 and off2 <= cch2
747	ch1 = Mid(str1, off1, 1)
748	ch2 = Mid(str2, off2, 1)
749	if ch1 = ch2 then
750	off1 = off1 + 1
751	off2 = off2 + 1
752	chPrev1 = ch1
753	chPrev2 = ch2
754	else
755	' Is there a digest sequence in play. This includes the scenario where one of the
756	' string ran out of digests.
757	dim blnDigest1 : blnDigest1 = CharIsDigit(ch1)
758	dim blnDigest2 : blnDigest2 = CharIsDigit(ch2)
759	if (blnDigest1 = True or blnDigest2 = True) _
760	and (blnDigest1 = True or CharIsDigit(chPrev1) = True) _
761	and (blnDigest2 = True or CharIsDigit(chPrev2) = True) _
762	then
763	'LogPrint "StrVersionCompare: off1="&off1&" off2="&off2&" ch1="&ch1&" chPrev1="&chPrev1&" ch2="&ch2&" chPrev2="&chPrev2
764	if blnDigest1 = False then off1 = off1 - 1
765	if blnDigest2 = False then off2 = off2 - 1
766	' The one with the fewer digits comes first.
767	' Note! off1 and off2 are adjusted to next non-digit character in the strings.
768	cchDigits = CountDigitsIgnoreLeadingZeros(str1, off1)
769	intDiff = cchDigits - CountDigitsIgnoreLeadingZeros(str2, off2)
770	'LogPrint "StrVersionCompare: off1="&off1&" off2="&off2&" cchDigits="&cchDigits
771	if intDiff <> 0 then
772	StrVersionCompare = intDiff
773	'LogPrint "StrVersionCompare: --> "&intDiff&" #1"
774	exit function
775	end if
776
777	' If the same number of digits, the smaller digit wins. However, because of
778	' potential leading zeros, we must redo the compare. Assume ASCII-like stuff
779	' and we can use StrComp for this.
780	intDiff = StrComp(Mid(str1, off1 - cchDigits, cchDigits), Mid(str2, off2 - cchDigits, cchDigits))
781	if intDiff <> 0 then
782	StrVersionCompare = intDiff
783	'LogPrint "StrVersionCompare: --> "&intDiff&" #2"
784	exit function
785	end if
786	chPrev1 = "x"
787	chPrev2 = "x"
788	else
789	if blnDigest1 then
790	StrVersionCompare = -1 ' Digits before characters
791	'LogPrint "StrVersionCompare: --> -1 (#3)"
792	elseif blnDigest2 then
793	StrVersionCompare = 1 ' Digits before characters
794	'LogPrint "StrVersionCompare: --> 1 (#4)"
795	else
796	StrVersionCompare = StrComp(ch1, ch2)
797	'LogPrint "StrVersionCompare: --> "&StrVersionCompare&" (#5)"
798	end if
799	exit function
800	end if
801	end if
802	loop
803
804	' The common part matches up, so the shorter string 'wins'.
805	StrVersionCompare = (cch1 - off1) - (cch2 - off2)
806	end if
807	end if
808	'LogPrint "StrVersionCompare: --> "&StrVersionCompare&" (#6)"
809	end function
810
811
812	''
813	' Returns the first list of the given string.
814	function StrGetFirstLine(str)
815	dim off
816	off = InStr(1, str, Chr(10))
817	if off <= 0 then off = InStr(1, str, Chr(13))
818	if off > 0 then
819	StrGetFirstLine = Mid(str, 1, off)
820	else
821	StrGetFirstLine = str
822	end if
823	end function
824
825
826	''
827	' Returns the first word in the given string.
828	'
829	' Only recognizes space, tab, newline and carriage return as word separators.
830	'
831	function StrGetFirstWord(str)
832	dim strSep, offWord, offEnd, offEnd2, strSeparators
833	strSeparators = " " & Chr(9) & Chr(10) & Chr(13)
834
835	' Skip leading separators.
836	for offWord = 1 to Len(str)
837	if InStr(1, strSeparators, Mid(str, offWord, 1)) < 1 then exit for
838	next
839
840	' Find the end.
841	offEnd = Len(str) + 1
842	for offSep = 1 to Len(strSeparators)
843	offEnd2 = InStr(offWord, str, Mid(strSeparators, offSep, 1))
844	if offEnd2 > 0 and offEnd2 < offEnd then offEnd = offEnd2
845	next
846
847	StrGetFirstWord = Mid(str, offWord, offEnd - offWord)
848	end function
849
850
851	''
852	' Checks if the string starts with the given prefix (case sensitive).
853	function StrStartsWith(str, strPrefix)
854	if len(str) >= Len(strPrefix) then
855	StrStartsWith = (StrComp(Left(str, Len(strPrefix)), strPrefix, vbBinaryCompare) = 0)
856	else
857	StrStartsWith = false
858	end if
859	end function
860
861
862	''
863	' Checks if the string starts with the given prefix, case insenstive edition.
864	function StrStartsWithI(str, strPrefix)
865	if len(str) >= Len(strPrefix) then
866	StrStartsWithI = (StrComp(Left(str, Len(strPrefix)), strPrefix, vbTextCompare) = 0)
867	else
868	StrStartsWithI = false
869	end if
870	end function
871
872
873	''
874	' Checks if the string ends with the given suffix (case sensitive).
875	function StrEndsWith(str, strSuffix)
876	if len(str) >= Len(strSuffix) then
877	StrEndsWith = (StrComp(Right(str, Len(strSuffix)), strSuffix, vbBinaryCompare) = 0)
878	else
879	StrEndsWith = false
880	end if
881	end function
882
883
884	''
885	' Checks if the string ends with the given suffix, case insenstive edition.
886	function StrEndsWithI(str, strSuffix)
887	if len(str) >= Len(strSuffix) then
888	StrEndsWithI = (StrComp(Right(str, Len(strSuffix)), strSuffix, vbTextCompare) = 0)
889	else
890	StrEndsWithI = false
891	end if
892	end function
893
894
895	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
896	' Helpers: Arrays '
897	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
898
899	''
900	' Returns a reverse array (copy).
901	function ArrayReverse(arr)
902	dim cnt, i, j, iHalf, objTmp
903	cnt = UBound(arr) - LBound(arr) + 1
904	if cnt > 0 then
905	j = UBound(arr)
906	iHalf = Fix(LBound(arr) + cnt / 2)
907	for i = LBound(arr) to iHalf - 1
908	objTmp = arr(i)
909	arr(i) = arr(j)
910	arr(j) = objTmp
911	j = j - 1
912	next
913	end if
914	ArrayReverse = arr
915	end function
916
917
918	''
919	' Returns a reverse sorted array (strings).
920	function ArraySortStringsEx(arrStrings, ByRef fnCompare)
921	dim str1, str2, i, j
922	for i = LBound(arrStrings) to UBound(arrStrings)
923	str1 = arrStrings(i)
924	for j = i + 1 to UBound(arrStrings)
925	str2 = arrStrings(j)
926	if fnCompare(str2, str1) < 0 then
927	arrStrings(j) = str1
928	str1 = str2
929	end if
930	next
931	arrStrings(i) = str1
932	next
933	ArraySortStringsEx = arrStrings
934	end function
935
936	'' Wrapper for StrComp as GetRef("StrComp") fails.
937	function WrapStrComp(str1, str2)
938	WrapStrComp = StrComp(str1, str2)
939	end function
940
941	''
942	' Returns a reverse sorted array (strings).
943	function ArraySortStrings(arrStrings)
944	ArraySortStrings = ArraySortStringsEx(arrStrings, GetRef("WrapStrComp"))
945	end function
946
947
948	''
949	' Returns a reverse sorted array (strings).
950	function ArrayVerSortStrings(arrStrings)
951	ArrayVerSortStrings = ArraySortStringsEx(arrStrings, GetRef("StrVersionCompare"))
952	end function
953
954
955	'' Wrapper for StrComp as GetRef("StrComp") fails.
956	function WrapStrCompNeg(str1, str2)
957	WrapStrCompNeg = -StrComp(str1, str2)
958	end function
959
960	''
961	' Returns a reverse sorted array (strings).
962	function ArrayRSortStrings(arrStrings)
963	ArrayRSortStrings = ArraySortStringsEx(arrStrings, GetRef("WrapStrCompNeg"))
964	end function
965
966
967	''
968	' Returns a reverse version sorted array (strings).
969	function ArrayRVerSortStrings(arrStrings)
970	ArrayRVerSortStrings = ArrayReverse(ArraySortStringsEx(arrStrings, GetRef("StrVersionCompare")))
971	end function
972
973
974	''
975	' Prints a string array.
976	sub ArrayPrintStrings(arrStrings, strPrefix)
977	for i = LBound(arrStrings) to UBound(arrStrings)
978	Print strPrefix & "arrStrings(" & i & ") = '" & arrStrings(i) & "'"
979	next
980	end sub
981
982
983	''
984	' Returns an Array() statement string
985	function ArrayToString(arrStrings)
986	dim strRet, i
987	strRet = "Array("
988	for i = LBound(arrStrings) to UBound(arrStrings)
989	if i <> LBound(arrStrings) then strRet = strRet & ", "
990	strRet = strRet & """" & arrStrings(i) & """"
991	next
992	ArrayToString = strRet & ")"
993	end function
994
995
996	''
997	' Joins the elements of an array into a string using the given item separator.
998	' @remark this is the same as Join() really.
999	function ArrayJoinString(arrStrings, strSep)
1000	if ArraySize(arrStrings) = 0 then
1001	ArrayJoinString = ""
1002	else
1003	dim i
1004	ArrayJoinString = "" & arrStrings(LBound(arrStrings))
1005	for i = LBound(arrStrings) + 1 to UBound(arrStrings)
1006	ArrayJoinString = ArrayJoinString & strSep & arrStrings(i)
1007	next
1008	end if
1009	end function
1010
1011
1012	''
1013	' Returns the input array with the string appended.
1014	' @note This works by reference
1015	function ArrayAppend(ByRef arr, str)
1016	dim i
1017	redim preserve arr(UBound(arr) + 1)
1018	arr(UBound(arr)) = str
1019	ArrayAppend = arr
1020	end function
1021
1022
1023	''
1024	' Returns the input array with the string prepended.
1025	' @note This works by reference
1026	function ArrayPrepend(ByRef arr, str)
1027	dim i
1028	redim preserve arr(UBound(arr) + 1)
1029	for i = UBound(arr) to (LBound(arr) + 1) step -1
1030	arr(i) = arr(i - 1)
1031	next
1032	arr(LBound(arr)) = str
1033	ArrayPrepend = arr
1034	end function
1035
1036
1037	''
1038	' Returns the input array with the string prepended.
1039	' @note This works by reference
1040	function ArrayRemove(ByRef arr, idx)
1041	dim i
1042	for i = idx to (UBound(arr) - 1)
1043	arr(i) = arr(i + 1)
1044	next
1045	redim preserve arr(UBound(arr) - 1)
1046	ArrayRemove = arr
1047	end function
1048
1049
1050	''
1051	' Checks if the array contains the given string (case sensitive).
1052	function ArrayContainsString(ByRef arr, str)
1053	dim strCur
1054	ArrayContainsString = False
1055	for each strCur in arr
1056	if StrComp(strCur, str) = 0 then
1057	ArrayContainsString = True
1058	exit function
1059	end if
1060	next
1061	end function
1062
1063
1064	''
1065	' Checks if the array contains the given string, using case insensitive compare.
1066	function ArrayContainsStringI(ByRef arr, str)
1067	dim strCur
1068	ArrayContainsStringI = False
1069	for each strCur in arr
1070	if StrComp(strCur, str, vbTextCompare) = 0 then
1071	ArrayContainsStringI = True
1072	exit function
1073	end if
1074	next
1075	end function
1076
1077
1078	''
1079	' Returns the index of the first occurance of the given string; -1 if not found.
1080	function ArrayFindString(ByRef arr, str)
1081	dim i
1082	for i = LBound(arr) to UBound(arr)
1083	if StrComp(arr(i), str, vbBinaryCompare) = 0 then
1084	ArrayFindString = i
1085	exit function
1086	end if
1087	next
1088	ArrayFindString = LBound(arr) - 1
1089	end function
1090
1091
1092	''
1093	' Returns the index of the first occurance of the given string, -1 if not found,
1094	' case insensitive edition.
1095	function ArrayFindStringI(ByRef arr, str)
1096	dim i
1097	for i = LBound(arr) to UBound(arr)
1098	if StrComp(arr(i), str, vbTextCompare) = 0 then
1099	ArrayFindStringI = i
1100	exit function
1101	end if
1102	next
1103	ArrayFindStringI = LBound(arr) - 1
1104	end function
1105
1106
1107	''
1108	' Returns the number of entries in an array.
1109	function ArraySize(ByRef arr)
1110	if (UBound(arr) >= 0) then
1111	ArraySize = UBound(arr) - LBound(arr) + 1
1112	else
1113	ArraySize = 0
1114	end if
1115	end function
1116
1117
1118	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1119	' Helpers: Registry '
1120	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1121
1122	'' The registry globals
1123	dim g_objReg, g_objRegCtx
1124	dim g_blnRegistry
1125	g_blnRegistry = false
1126
1127
1128	''
1129	' Init the register provider globals.
1130	function RegInit()
1131	RegInit = false
1132	On Error Resume Next
1133	if g_blnRegistry = false then
1134	set g_objRegCtx = CreateObject("WbemScripting.SWbemNamedValueSet")
1135	' Comment out the following for lines if the cause trouble on your windows version.
1136	if IsWow64() then
1137	g_objRegCtx.Add "__ProviderArchitecture", 64
1138	g_objRegCtx.Add "__RequiredArchitecture", true
1139	LogPrint "RegInit: WoW64"
1140	end if
1141	set objLocator = CreateObject("Wbemscripting.SWbemLocator")
1142	set objServices = objLocator.ConnectServer("", "root\default", "", "", , , , g_objRegCtx)
1143	set g_objReg = objServices.Get("StdRegProv")
1144	g_blnRegistry = true
1145	end if
1146	RegInit = true
1147	end function
1148
1149
1150	''
1151	' Translates a register root name to a value
1152	' This will translate HKCU path to HKEY_USERS and fixing
1153	function RegTransRoot(strRoot, ByRef sSubKeyName)
1154	const HKEY_LOCAL_MACHINE = &H80000002
1155	const HKEY_CURRENT_USER = &H80000001
1156	const HKEY_USERS = &H80000003
1157
1158	select case strRoot
1159	case "HKLM"
1160	RegTransRoot = HKEY_LOCAL_MACHINE
1161	case "HKUS"
1162	RegTransRoot = HKEY_USERS
1163	case "HKCU"
1164	dim strCurrentSid
1165	strCurrentSid = GetSid()
1166	if strCurrentSid <> "" then
1167	sSubKeyName = strCurrentSid & "\" & sSubKeyName
1168	RegTransRoot = HKEY_USERS
1169	'LogPrint "RegTransRoot: HKCU -> HKEY_USERS + " & sSubKeyName
1170	else
1171	RegTransRoot = HKEY_CURRENT_USER
1172	LogPrint "RegTransRoot: Warning! HKCU -> HKEY_USERS failed!"
1173	end if
1174	case else
1175	MsgFatal "RegTransRoot: Unknown root: '" & strRoot & "'"
1176	RegTransRoot = 0
1177	end select
1178	end function
1179
1180
1181	''
1182	' Gets a value from the registry. Returns "" if string wasn't found / valid.
1183	function RegGetString(strName)
1184	RegGetString = ""
1185	if RegInit() then
1186	dim strRoot, strKey, strValue
1187
1188	' split up into root, key and value parts.
1189	strRoot = left(strName, instr(strName, "\") - 1)
1190	strKey = mid(strName, instr(strName, "\") + 1, instrrev(strName, "\") - instr(strName, "\"))
1191	strValue = mid(strName, instrrev(strName, "\") + 1)
1192
1193	' Must use ExecMethod to call the GetStringValue method because of the context.
1194	Set InParms = g_objReg.Methods_("GetStringValue").Inparameters
1195	InParms.hDefKey = RegTransRoot(strRoot, strKey)
1196	InParms.sSubKeyName = strKey
1197	InParms.sValueName = strValue
1198	On Error Resume Next
1199	set OutParms = g_objReg.ExecMethod_("GetStringValue", InParms, , g_objRegCtx)
1200	if OutParms.ReturnValue = 0 then
1201	if not IsNull(OutParms.sValue) then
1202	RegGetString = OutParms.sValue
1203	end if
1204	end if
1205	else
1206	' fallback mode
1207	On Error Resume Next
1208	RegGetString = g_objShell.RegRead(strName)
1209	end if
1210	end function
1211
1212
1213	''
1214	' Gets a multi string value from the registry. Returns array of strings if found, otherwise empty array().
1215	function RegGetMultiString(strName)
1216	RegGetMultiString = Array()
1217	if RegInit() then
1218	dim strRoot, strKey, strValue
1219
1220	' split up into root, key and value parts.
1221	strRoot = left(strName, instr(strName, "\") - 1)
1222	strKey = mid(strName, instr(strName, "\") + 1, instrrev(strName, "\") - instr(strName, "\"))
1223	strValue = mid(strName, instrrev(strName, "\") + 1)
1224
1225	' Must use ExecMethod to call the GetStringValue method because of the context.
1226	Set InParms = g_objReg.Methods_("GetMultiStringValue").Inparameters
1227	InParms.hDefKey = RegTransRoot(strRoot, strKey)
1228	InParms.sSubKeyName = strKey
1229	InParms.sValueName = strValue
1230	On Error Resume Next
1231	set OutParms = g_objReg.ExecMethod_("GetMultiStringValue", InParms, , g_objRegCtx)
1232	if OutParms.ReturnValue = 0 then
1233	if OutParms.sValue <> Null then
1234	RegGetMultiString = OutParms.sValue
1235	end if
1236	end if
1237	else
1238	' fallback mode
1239	On Error Resume Next
1240	RegGetMultiString = g_objShell.RegRead(strName)
1241	end if
1242	end function
1243
1244
1245	''
1246	' Returns an array of subkey strings.
1247	function RegEnumSubKeys(strRoot, ByVal strKeyPath)
1248	RegEnumSubKeys = Array()
1249	if RegInit() then
1250	' Must use ExecMethod to call the EnumKey method because of the context.
1251	Set InParms = g_objReg.Methods_("EnumKey").Inparameters
1252	InParms.hDefKey = RegTransRoot(strRoot, strKeyPath)
1253	InParms.sSubKeyName = strKeyPath
1254	On Error Resume Next
1255	set OutParms = g_objReg.ExecMethod_("EnumKey", InParms, , g_objRegCtx)
1256	'LogPrint "RegEnumSubKeys(" & Hex(InParms.hDefKey) & "," & InParms.sSubKeyName &") -> " & OutParms.GetText_(1)
1257	if OutParms.ReturnValue = 0 then
1258	if OutParms.sNames <> Null then
1259	RegEnumSubKeys = OutParms.sNames
1260	end if
1261	end if
1262	else
1263	' fallback mode
1264	dim objReg, rc, arrSubKeys
1265	set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
1266	On Error Resume Next
1267	rc = objReg.EnumKey(RegTransRoot(strRoot, strKeyPath), strKeyPath, arrSubKeys)
1268	if rc = 0 then
1269	RegEnumSubKeys = arrSubKeys
1270	end if
1271	end if
1272	end function
1273
1274
1275	''
1276	' Returns an array of full path subkey strings.
1277	function RegEnumSubKeysFull(strRoot, strKeyPath)
1278	dim arrTmp
1279	arrTmp = RegEnumSubKeys(strRoot, strKeyPath)
1280	for i = LBound(arrTmp) to UBound(arrTmp)
1281	arrTmp(i) = strKeyPath & "\" & arrTmp(i)
1282	next
1283	RegEnumSubKeysFull = arrTmp
1284	end function
1285
1286
1287	''
1288	' Returns an rsorted array of subkey strings.
1289	function RegEnumSubKeysRVerSorted(strRoot, strKeyPath)
1290	RegEnumSubKeysRVerSorted = ArrayRVerSortStrings(RegEnumSubKeys(strRoot, strKeyPath))
1291	end function
1292
1293
1294	''
1295	' Returns an rsorted array of subkey strings.
1296	function RegEnumSubKeysFullRVerSorted(strRoot, strKeyPath)
1297	RegEnumSubKeysFullRVerSorted = ArrayRVerSortStrings(RegEnumSubKeysFull(strRoot, strKeyPath))
1298	end function
1299
1300
1301	''
1302	' Returns an array of value name strings.
1303	function RegEnumValueNames(strRoot, ByVal strKeyPath)
1304	RegEnumValueNames = Array()
1305	if RegInit() then
1306	' Must use ExecMethod to call the EnumKey method because of the context.
1307	Set InParms = g_objReg.Methods_("EnumValues").Inparameters
1308	InParms.hDefKey = RegTransRoot(strRoot, strKeyPath)
1309	InParms.sSubKeyName = strKeyPath
1310	On Error Resume Next
1311	set OutParms = g_objReg.ExecMethod_("EnumValues", InParms, , g_objRegCtx)
1312	'LogPrint "RegEnumValueNames(" & Hex(InParms.hDefKey) & "," & InParms.sSubKeyName &") -> " & OutParms.GetText_(1)
1313	if OutParms.ReturnValue = 0 then
1314	if OutParms.sNames <> Null then
1315	RegEnumValueNames = OutParms.sNames
1316	end if
1317	end if
1318	else
1319	' fallback mode
1320	dim objReg, rc, arrSubKeys
1321	set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
1322	On Error Resume Next
1323	rc = objReg.EnumValues(RegTransRoot(strRoot, strKeyPath), strKeyPath, arrSubKeys)
1324	if rc = 0 then
1325	RegEnumValueNames = arrSubKeys
1326	end if
1327	end if
1328	end function
1329
1330
1331	''
1332	' Returns an array of full path value name strings.
1333	function RegEnumValueNamesFull(strRoot, strKeyPath)
1334	dim arrTmp
1335	arrTmp = RegEnumValueNames(strRoot, strKeyPath)
1336	for i = LBound(arrTmp) to UBound(arrTmp)
1337	arrTmp(i) = strKeyPath & "\" & arrTmp(i)
1338	next
1339	RegEnumValueNamesFull = arrTmp
1340	end function
1341
1342
1343	''
1344	' Extract relevant paths from program links using a callback function.
1345	'
1346	' Enumerates start menu program links from "HKCU\SOFTWARE\Microsoft\Windows\CurrentVersion\UFH\SHC"
1347	' and similar, using the given callback to examine each and return a path if relevant. The relevant
1348	' paths are returned in reverse sorted order.
1349	'
1350	' The callback prototype is as follows fnCallback(ByRef arrStrings, cStrings, ByRef objUser).
1351	' Any non-empty return strings are collected, reverse sorted uniquely and returned.
1352	'
1353	function CollectFromProgramItemLinks(ByRef fnCallback, ByRef objUser)
1354	dim arrValues, strValue, arrStrings, str, arrCandidates, iCandidates, cStrings
1355	CollectFromProgramItemLinks = Array()
1356
1357	arrValues = RegEnumValueNamesFull("HKCU", "SOFTWARE\Microsoft\Windows\CurrentVersion\UFH\SHC")
1358	redim arrCandidates(UBound(arrValues) - LBound(arrValues) + 1)
1359	iCandidates = 0
1360	for each strValue in arrValues
1361	arrStrings = RegGetMultiString("HKCU\" & strValue)
1362	if UBound(arrStrings) >= 0 then
1363	cStrings = UBound(arrStrings) + 1 - LBound(arrStrings)
1364	str = fnCallback(arrStrings, cStrings, objUser)
1365	if str <> "" then
1366	if not ArrayContainsStringI(arrCandidates, str) then
1367	arrCandidates(iCandidates) = str
1368	iCandidates = iCandidates + 1
1369	end if
1370	end if
1371	end if
1372	next
1373	if iCandidates > 0 then
1374	redim preserve arrCandidates(iCandidates - 1)
1375	arrCandidates = ArrayRVerSortStrings(arrCandidates)
1376	for iCandidates = LBound(arrCandidates) to UBound(arrCandidates)
1377	LogPrint "CollectFromProgramItemLinks: #" & iCandidates & ": " & arrCandidates(iCandidates)
1378	next
1379	CollectFromProgramItemLinks = arrCandidates
1380	end if
1381	end function
1382
1383
1384	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1385	' Helpers: Messaging and Output '
1386	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1387
1388	''
1389	' Append text to the log file and echo it to stdout
1390	sub Print(str)
1391	LogPrint str
1392	Wscript.Echo str
1393	end sub
1394
1395
1396	''
1397	' Prints a test header
1398	sub PrintHdr(strTest)
1399	LogPrint "*** Checking for " & strTest & " ***"
1400	Wscript.Echo "Checking for " & StrTest & "..."
1401	end sub
1402
1403
1404	''
1405	' Prints a success message
1406	sub PrintResultMsg(strTest, strResult)
1407	dim cchPad
1408	LogPrint "** " & strTest & ": " & strResult
1409	Wscript.Echo " Found " & RightPad(strTest & ": ", 22) & strPad & strResult
1410	end sub
1411
1412
1413	''
1414	' Prints a successfully detected path
1415	sub PrintResult(strTest, strPath)
1416	strLongPath = PathAbsLong(strPath)
1417	if PathAbs(strPath) <> strLongPath then
1418	LogPrint "** " & strTest & ": " & strPath & " (" & UnixSlashes(strLongPath) & ")"
1419	Wscript.Echo " Found " & RightPad(strTest & ": ", 22) & strPath & " (" & UnixSlashes(strLongPath) & ")"
1420	else
1421	LogPrint "** " & strTest & ": " & strPath
1422	Wscript.Echo " Found " & RightPad(strTest & ": ", 22) & strPath
1423	end if
1424	end sub
1425
1426
1427	''
1428	' Info message.
1429	sub MsgInfo(strMsg)
1430	Print "info: " & strMsg
1431	end sub
1432
1433
1434	''
1435	' Warning message.
1436	sub MsgWarning(strMsg)
1437	Print "warning: " & strMsg
1438	end sub
1439
1440
1441	''
1442	' Fatal error.
1443	sub MsgFatal(strMsg)
1444	Print "fatal error: " & strMsg
1445	Wscript.Quit(1)
1446	end sub
1447
1448
1449	''
1450	' Error message, fatal unless flag to ignore errors is given.
1451	sub MsgError(strMsg)
1452	Print "error: " & strMsg
1453	if g_blnContinueOnError = False then
1454	Wscript.Quit(1)
1455	end if
1456	g_rcScript = 1
1457	end sub
1458
1459	''
1460	' Error message, fatal unless flag to ignore errors is given.
1461	' @note does not return
1462	sub MsgSyntaxError(strMsg)
1463	Print "syntax error: " & strMsg
1464	Wscript.Quit(2)
1465	end sub
1466
1467
1468	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1469	' Helpers: Misc '
1470	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1471
1472	''
1473	' Translate a kBuild / VBox architecture name to a windows one.
1474	function XlateArchitectureToWin(strArch)
1475	strArch = LCase(strArch)
1476	XlateArchitectureToWin = strArch
1477	if strArch = "amd64" then XlateArchitectureToWin = "x64"
1478	end function
1479
1480
1481	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1482	' Testcases '
1483	''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1484
1485	''
1486	' Self test for some of the above routines.
1487	'
1488	sub SelfTest
1489	dim i, str
1490	str = "0123456789"
1491	for i = 1 to Len(str)
1492	if CharIsDigit(Mid(str, i, 1)) <> True then MsgFatal "SelfTest failed: CharIsDigit("&Mid(str, i, 1)&")"
1493	next
1494	str = "abcdefghijklmnopqrstuvwxyz~`!@#$%^&*()_+-=ABCDEFGHIJKLMNOPQRSTUVWXYZ/\[]{}"
1495	for i = 1 to Len(str)
1496	if CharIsDigit(Mid(str, i, 1)) <> False then MsgFatal "SelfTest failed: CharIsDigit("&Mid(str, i, 1)&")"
1497	next
1498
1499	if StrVersionCompare("1234", "1234") <> 0 then MsgFatal "SelfTest failed: StrVersionCompare #1"
1500	if StrVersionCompare("1", "1") <> 0 then MsgFatal "SelfTest failed: StrVersionCompare #2"
1501	if StrVersionCompare("2", "1") <= 0 then MsgFatal "SelfTest failed: StrVersionCompare #3"
1502	if StrVersionCompare("1", "2") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #4"
1503	if StrVersionCompare("01", "1") <> 0 then MsgFatal "SelfTest failed: StrVersionCompare #5"
1504	if StrVersionCompare("01", "001") <> 0 then MsgFatal "SelfTest failed: StrVersionCompare #6"
1505	if StrVersionCompare("12", "123") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #7"
1506	if StrVersionCompare("v123", "123") <= 0 then MsgFatal "SelfTest failed: StrVersionCompare #8"
1507	if StrVersionCompare("v1.2.3", "v1.3.4") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #9"
1508	if StrVersionCompare("v1.02.3", "v1.3.4") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #10"
1509	if StrVersionCompare("v1.2.3", "v1.03.4") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #11"
1510	if StrVersionCompare("v1.2.4", "v1.23.4") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #12"
1511	if StrVersionCompare("v10.0.17163", "v10.00.18363") >= 0 then MsgFatal "SelfTest failed: StrVersionCompare #13"
1512	if StrVersionCompare("n 2.15.0", "2.12.0") <= 0 then MsgFatal "SelfTest failed: StrVersionCompare #14"
1513
1514	if StrGetFirstWord("1") <> "1" then MsgFatal "SelfTest: StrGetFirstWord #1"
1515	if StrGetFirstWord(" 1 ") <> "1" then MsgFatal "SelfTest: StrGetFirstWord #2"
1516	if StrGetFirstWord(" 1 2 ") <> "1" then MsgFatal "SelfTest: StrGetFirstWord #3"
1517	if StrGetFirstWord("1 2") <> "1" then MsgFatal "SelfTest: StrGetFirstWord #4"
1518	if StrGetFirstWord("1234 5") <> "1234" then MsgFatal "SelfTest: StrGetFirstWord #5"
1519	if StrGetFirstWord(" ") <> "" then MsgFatal "SelfTest: StrGetFirstWord #6"
1520
1521	dim arr
1522	arr = ArrayAppend(Array("0", "1"), "2")
1523	if ArraySize(arr) <> 3 then MsgFatal "SelfTest: Array #1: size:" & ArraySize(arr)
1524	if ArrayToString(arr) <> "Array(""0"", ""1"", ""2"")" then MsgFatal "SelfTest: Array #1: " & ArrayToString(arr)
1525
1526	arr = ArrayPrepend(arr, "-1")
1527	if ArraySize(arr) <> 4 then MsgFatal "SelfTest: Array #2: size:" & ArraySize(arr)
1528	if ArrayToString(arr) <> "Array(""-1"", ""0"", ""1"", ""2"")" then MsgFatal "SelfTest: Array #2: " & ArrayToString(arr)
1529
1530	ArrayPrepend arr, "-2"
1531	if ArraySize(arr) <> 5 then MsgFatal "SelfTest: Array #3: size:" & ArraySize(arr)
1532	if ArrayToString(arr) <> "Array(""-2"", ""-1"", ""0"", ""1"", ""2"")" then MsgFatal "SelfTest: Array #3: " & ArrayToString(arr)
1533
1534	ArrayRemove arr, 1
1535	if ArraySize(arr) <> 4 then MsgFatal "SelfTest: Array #4: size:" & ArraySize(arr)
1536	if ArrayToString(arr) <> "Array(""-2"", ""0"", ""1"", ""2"")" then MsgFatal "SelfTest: Array #4: " & ArrayToString(arr)
1537
1538	arr = ArrayRemove(arr, 2)
1539	if ArraySize(arr) <> 3 then MsgFatal "SelfTest: Array #5: size:" & ArraySize(arr)
1540	if ArrayToString(arr) <> "Array(""-2"", ""0"", ""2"")" then MsgFatal "SelfTest: Array #5: " & ArrayToString(arr)
1541
1542	arr = ArrayPrepend(arr, "42")
1543	arr = ArrayAppend(arr, "-42")
1544	if ArraySize(arr) <> 5 then MsgFatal "SelfTest: Array #6: size:" & ArraySize(arr)
1545	if ArrayToString(arr) <> "Array(""42"", ""-2"", ""0"", ""2"", ""-42"")" then MsgFatal "SelfTest: Array #6: " & ArrayToString(arr)
1546
1547	arr = ArraySortStrings(arr)
1548	if ArraySize(arr) <> 5 then MsgFatal "SelfTest: Array #7: size:" & ArraySize(arr)
1549	if ArrayToString(arr) <> "Array(""-2"", ""-42"", ""0"", ""2"", ""42"")" then MsgFatal "SelfTest: Array #7: " & ArrayToString(arr)
1550
1551	arr = ArrayRSortStrings(arr)
1552	if ArraySize(arr) <> 5 then MsgFatal "SelfTest: Array #7: size:" & ArraySize(arr)
1553	if ArrayToString(arr) <> "Array(""42"", ""2"", ""0"", ""-42"", ""-2"")" then MsgFatal "SelfTest: Array #8: " & ArrayToString(arr)
1554
1555	arr = ArrayVerSortStrings(Array("v10", "v1", "v0"))
1556	if ArrayToString(arr) <> "Array(""v0"", ""v1"", ""v10"")" then MsgFatal "SelfTest: Array #9: " & ArrayToString(arr)
1557
1558	arr = ArrayRVerSortStrings(arr)
1559	if ArrayToString(arr) <> "Array(""v10"", ""v1"", ""v0"")" then MsgFatal "SelfTest: Array #10: " & ArrayToString(arr)
1560
1561	if ArrayJoinString(arr, ":") <> "v10:v1:v0" then MsgFatal "SelfTest: Array #11: " & ArrayJoinString(arr, ":")
1562
1563	if PathMatch("c:\", "C:\") <> true then MsgFatal "SelfTest: PathMatch #1"
1564	if PathMatch("c:\\\winDows/sysTem32", "C:\WindowS\.\\.\System32\.") <> true then MsgFatal "SelfTest: PathMatch #2"
1565	if PathMatch("c:\\\winDows/sysTem32", "C:\WindowS\.\\..\System32\.") <> false then MsgFatal "SelfTest: PathMatch #3"
1566	if PathMatch("\\x\", "\\\x\") <> false then MsgFatal "SelfTest: PathMatch #4"
1567	if PathMatch("\\x\", "\\x\") <> true then MsgFatal "SelfTest: PathMatch #5"
1568	if PathMatch("\\", "\\") <> true then MsgFatal "SelfTest: PathMatch #6"
1569	if PathMatch("\\x", "\\x") <> true then MsgFatal "SelfTest: PathMatch #7"
1570
1571	end sub
1572
1573	'
1574	' Run the self tests if we're executed directly.
1575	'
1576	if StrEndsWithI(Wscript.ScriptFullName, "\tools\win\vbscript\helpers.vbs") then
1577	Wscript.echo "helpers.vbs: Running self test..."
1578	SelfTest
1579	Wscript.echo "helpers.vbs: Self test complete."
1580	end if

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format