helpers.vbs@ 96407

Last change on this file since 96407 was 96407, checked in by vboxsync, 2 years ago
scm copyright and license note update
Property svn:eol-style set to `CRLF` Property svn:keywords set to `Id`
File size: 54.8 KB

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

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

Download in other formats:

Original Format