VirtualBox

source: vbox/trunk/tools/win/vbscript/helpers.vbs@ 103068

Last change on this file since 103068 was 98103, checked in by vboxsync, 21 months ago

Copyright year updates by scm.

  • Property svn:eol-style set to CRLF
  • Property svn:keywords set to Id
File size: 54.8 KB
Line 
1' $Id: helpers.vbs 98103 2023-01-17 14:15:46Z 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-2023 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''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
34dim g_objShell
35Set g_objShell = WScript.CreateObject("WScript.Shell")
36
37dim g_objFileSys
38Set g_objFileSys = WScript.CreateObject("Scripting.FileSystemObject")
39
40'' Whether to ignore (continue) on errors.
41dim g_blnContinueOnError
42g_blnContinueOnError = False
43
44'' The script's exit code (for ignored errors).
45dim g_rcScript
46g_rcScript = 0
47
48
49''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
50' Helpers: Paths '
51''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
52
53''
54' Converts to unix slashes
55function UnixSlashes(str)
56 UnixSlashes = replace(str, "\", "/")
57end function
58
59
60''
61' Converts to dos slashes
62function DosSlashes(str)
63 DosSlashes = replace(str, "/", "\")
64end function
65
66
67''
68' Get the path of the parent directory. Returns root if root was specified.
69' Expects abs path.
70function PathParent(str)
71 PathParent = g_objFileSys.GetParentFolderName(DosSlashes(str))
72end function
73
74
75''
76' Strips the filename from at path.
77function PathStripFilename(str)
78 PathStripFilename = g_objFileSys.GetParentFolderName(DosSlashes(str))
79end function
80
81
82''
83' Get the abs path, use the short version if necessary.
84function 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
126end function
127
128
129''
130' Get the abs path, use the long version.
131function 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
157end 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'
165function 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
218end function
219
220'' PathMatch helper
221function 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
236end function
237
238
239''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
240' Helpers: Files and Dirs '
241''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
242
243''
244' Read a file (typically the tmp file) into a string.
245function 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
254end function
255
256
257''
258' Deletes a file
259sub FileDelete(strFilename)
260 if g_objFileSys.FileExists(DosSlashes(strFilename)) then
261 g_objFileSys.DeleteFile(DosSlashes(strFilename))
262 end if
263end sub
264
265
266''
267' Appends a line to an ascii file.
268sub 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()
275end sub
276
277
278''
279' Checks if the file exists.
280function FileExists(strFilename)
281 FileExists = g_objFileSys.FileExists(DosSlashes(strFilename))
282 DbgPrint "FileExists(" & strFilename & ") -> " & FileExists
283end function
284
285
286''
287' Checks if the directory exists.
288function DirExists(strDirectory)
289 DirExists = g_objFileSys.FolderExists(DosSlashes(strDirectory))
290 DbgPrint "DirExists(" & strDirectory & ") -> " & DirExists
291end function
292
293
294''
295' Returns true if there are subfolders starting with the given string.
296function 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
309end function
310
311
312''
313' Returns a sorted array of subfolder names that starts with the given string.
314function 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
340end function
341
342
343''
344' Returns a sorted array of subfolder names that starts with the given string.
345function GetSubdirsStartingWithVerSorted(strFolder, strStartingWith)
346 GetSubdirsStartingWithVerSorted = ArrayVerSortStrings(GetSubdirsStartingWith(strFolder, strStartingWith))
347end function
348
349
350''
351' Returns a reverse version sorted array of subfolder names that starts with the given string.
352function GetSubdirsStartingWithRVerSorted(strFolder, strStartingWith)
353 GetSubdirsStartingWithRVerSorted = ArrayRVerSortStrings(GetSubdirsStartingWith(strFolder, strStartingWith))
354end function
355
356
357''
358' Try find the specified file in the specified path variable.
359function 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 = ""
381end function
382
383
384''
385' Try find the specified file in the path.
386function Which(strFile)
387 Which = WhichEx("Path", strFile)
388end function
389
390
391''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
392' Helpers: Processes '
393''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
394
395''
396' Checks if this is a WOW64 process.
397function IsWow64()
398 if g_objShell.Environment("PROCESS")("PROCESSOR_ARCHITEW6432") <> "" then
399 IsWow64 = 1
400 else
401 IsWow64 = 0
402 end if
403end function
404
405
406''
407' Executes a command in the shell catching output in strOutput
408function 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
434end function
435
436
437''
438' Gets the SID of the current user.
439function 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
460end function
461
462
463''
464' Gets the commandline used to invoke the script.
465function 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
479end function
480
481
482''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
483' Helpers: Environment '
484''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
485
486''
487' Gets an environment variable.
488function EnvGet(strName)
489 EnvGet = g_objShell.Environment("PROCESS")(strName)
490end function
491
492
493''
494' Gets an environment variable with default value if not found.
495function 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
503end 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.
509function 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
520end function
521
522
523''
524' Sets an environment variable.
525sub EnvSet(strName, strValue)
526 g_objShell.Environment("PROCESS")(strName) = strValue
527 LogPrint "EnvSet: " & strName & "=" & strValue
528end sub
529
530
531''
532' Prepends a string to an Path-like environment variable.
533function 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
543end function
544
545
546''
547' Appends a string to an Path-like environment variable,
548function 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
558end function
559
560
561''
562' Generic item remover.
563'
564' fnItemMatcher(strItem1, strItem2)
565'
566function 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
600end function
601
602
603''
604' Generic case-insensitive item matcher.
605' See also PathMatch().
606function EnvItemMatch(strItem1, strItem2)
607 EnvItemMatch = (StrComp(strItem1, strItem2) = 0)
608end function
609
610
611''
612' Prepends an item to an environment variable, after first removing any
613' existing ones (case-insensitive, preserves empty elements).
614function EnvPrependItem(strName, strItem, strSep)
615 EnvPrependItem = EnvPrependItemEx(strName, strItem, strSep, true, GetRef("EnvItemMatch"))
616 LogPrint "EnvPrependItem: " & strName & "=" & EnvPrependPathItem
617end function
618
619
620''
621' Appends an item to an environment variable, after first removing any
622' existing ones (case-insensitive, preserves empty elements).
623function EnvAppendItem(strName, strItem, strSep)
624 EnvAppendItem = EnvAppendItemEx(strName, strItem, strSep, true, GetRef("EnvItemMatch"))
625 LogPrint "EnvAppendItem: " & strName & "=" & EnvPrependPathItem
626end function
627
628
629''
630' Removes a string element from an environment variable, case
631' insensitive but preserving empty elements.
632function EnvRemoveItem(strName, strItem, strSep)
633 EnvRemoveItem = EnvRemoveItemEx(strName, strIten, strSep, true, GetRef("EnvItemMatch"), "EnvRemoveItem")
634end function
635
636
637''
638' Appends a string to an Path-like environment variable,
639function EnvPrependPathItem(strName, strItem, strSep)
640 EnvPrependPathItem = EnvPrependItemEx(strName, strItem, strSep, false, GetRef("PathMatch"))
641 LogPrint "EnvPrependPathItem: " & strName & "=" & EnvPrependPathItem
642end function
643
644
645''
646' Appends a string to an Path-like environment variable,
647function EnvAppendPathItem(strName, strItem, strSep)
648 EnvAppendPathItem = EnvAppendItemEx(strName, strItem, strSep, false, GetRef("PathMatch"))
649 LogPrint "EnvAppendPathItem: " & strName & "=" & EnvAppendPathItem
650end 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.
656function EnvRemovePathItem(strName, strItem, strSep)
657 EnvRemovePathItem = EnvRemoveItemEx(strName, strIten, strSep, false, GetRef("PathMatch"), "EnvRemovePathItem")
658end function
659
660
661''
662' Prepends a string to an environment variable
663sub EnvUnset(strName)
664 g_objShell.Environment("PROCESS").Remove(strName)
665 LogPrint "EnvUnset: " & strName
666end sub
667
668
669''
670' Gets the first non-empty environment variable of the given two.
671function EnvGetFirst(strName1, strName2)
672 EnvGetFirst = g_objShell.Environment("PROCESS")(strName1)
673 if EnvGetFirst = "" then
674 EnvGetFirst = g_objShell.Environment("PROCESS")(strName2)
675 end if
676end function
677
678''
679' Checks if the given enviornment variable exists.
680function EnvExists(strName)
681 EnvExists = g_objShell.Environment("PROCESS")(strName) <> ""
682end function
683
684
685''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
686' Helpers: Strings '
687''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
688
689''
690' Right pads a string with spaces to the given length
691function RightPad(str, cch)
692 if Len(str) < cch then
693 RightPad = str & String(cch - Len(str), " ")
694 else
695 RightPad = str
696 end if
697end function
698
699
700''
701' Checks if the given character is a decimal digit
702function CharIsDigit(ch)
703 CharIsDigit = (InStr(1, "0123456789", ch) > 0)
704end function
705
706''
707' Worker for StrVersionCompare
708' The offset is updated to point to the first non-digit character.
709function 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
735end 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
742function 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)"
819end function
820
821
822''
823' Returns the first list of the given string.
824function 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
833end 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'
841function 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)
858end function
859
860
861''
862' Checks if the string starts with the given prefix (case sensitive).
863function 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
869end function
870
871
872''
873' Checks if the string starts with the given prefix, case insenstive edition.
874function 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
880end function
881
882
883''
884' Checks if the string ends with the given suffix (case sensitive).
885function 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
891end function
892
893
894''
895' Checks if the string ends with the given suffix, case insenstive edition.
896function 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
902end function
903
904
905''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
906' Helpers: Arrays '
907''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
908
909''
910' Returns a reverse array (copy).
911function 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
925end function
926
927
928''
929' Returns a reverse sorted array (strings).
930function 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
944end function
945
946'' Wrapper for StrComp as GetRef("StrComp") fails.
947function WrapStrComp(str1, str2)
948 WrapStrComp = StrComp(str1, str2)
949end function
950
951''
952' Returns a reverse sorted array (strings).
953function ArraySortStrings(arrStrings)
954 ArraySortStrings = ArraySortStringsEx(arrStrings, GetRef("WrapStrComp"))
955end function
956
957
958''
959' Returns a reverse sorted array (strings).
960function ArrayVerSortStrings(arrStrings)
961 ArrayVerSortStrings = ArraySortStringsEx(arrStrings, GetRef("StrVersionCompare"))
962end function
963
964
965'' Wrapper for StrComp as GetRef("StrComp") fails.
966function WrapStrCompNeg(str1, str2)
967 WrapStrCompNeg = -StrComp(str1, str2)
968end function
969
970''
971' Returns a reverse sorted array (strings).
972function ArrayRSortStrings(arrStrings)
973 ArrayRSortStrings = ArraySortStringsEx(arrStrings, GetRef("WrapStrCompNeg"))
974end function
975
976
977''
978' Returns a reverse version sorted array (strings).
979function ArrayRVerSortStrings(arrStrings)
980 ArrayRVerSortStrings = ArrayReverse(ArraySortStringsEx(arrStrings, GetRef("StrVersionCompare")))
981end function
982
983
984''
985' Prints a string array.
986sub ArrayPrintStrings(arrStrings, strPrefix)
987 for i = LBound(arrStrings) to UBound(arrStrings)
988 Print strPrefix & "arrStrings(" & i & ") = '" & arrStrings(i) & "'"
989 next
990end sub
991
992
993''
994' Returns an Array() statement string
995function 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 & ")"
1003end 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.
1009function 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
1019end function
1020
1021
1022''
1023' Returns the input array with the string appended.
1024' @note This works by reference
1025function ArrayAppend(ByRef arr, str)
1026 dim i
1027 redim preserve arr(UBound(arr) + 1)
1028 arr(UBound(arr)) = str
1029 ArrayAppend = arr
1030end function
1031
1032
1033''
1034' Returns the input array with the string prepended.
1035' @note This works by reference
1036function 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
1044end function
1045
1046
1047''
1048' Returns the input array with the string prepended.
1049' @note This works by reference
1050function 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
1057end function
1058
1059
1060''
1061' Checks if the array contains the given string (case sensitive).
1062function 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
1071end function
1072
1073
1074''
1075' Checks if the array contains the given string, using case insensitive compare.
1076function 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
1085end function
1086
1087
1088''
1089' Returns the index of the first occurance of the given string; -1 if not found.
1090function 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
1099end function
1100
1101
1102''
1103' Returns the index of the first occurance of the given string, -1 if not found,
1104' case insensitive edition.
1105function 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
1114end function
1115
1116
1117''
1118' Returns the number of entries in an array.
1119function ArraySize(ByRef arr)
1120 if (UBound(arr) >= 0) then
1121 ArraySize = UBound(arr) - LBound(arr) + 1
1122 else
1123 ArraySize = 0
1124 end if
1125end function
1126
1127
1128''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1129' Helpers: Registry '
1130''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1131
1132'' The registry globals
1133dim g_objReg, g_objRegCtx
1134dim g_blnRegistry
1135g_blnRegistry = false
1136
1137
1138''
1139' Init the register provider globals.
1140function 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
1157end function
1158
1159
1160''
1161' Translates a register root name to a value
1162' This will translate HKCU path to HKEY_USERS and fixing
1163function 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
1188end function
1189
1190
1191''
1192' Gets a value from the registry. Returns "" if string wasn't found / valid.
1193function 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
1220end function
1221
1222
1223''
1224' Gets a multi string value from the registry. Returns array of strings if found, otherwise empty array().
1225function 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
1252end function
1253
1254
1255''
1256' Returns an array of subkey strings.
1257function 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
1282end function
1283
1284
1285''
1286' Returns an array of full path subkey strings.
1287function 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
1294end function
1295
1296
1297''
1298' Returns an rsorted array of subkey strings.
1299function RegEnumSubKeysRVerSorted(strRoot, strKeyPath)
1300 RegEnumSubKeysRVerSorted = ArrayRVerSortStrings(RegEnumSubKeys(strRoot, strKeyPath))
1301end function
1302
1303
1304''
1305' Returns an rsorted array of subkey strings.
1306function RegEnumSubKeysFullRVerSorted(strRoot, strKeyPath)
1307 RegEnumSubKeysFullRVerSorted = ArrayRVerSortStrings(RegEnumSubKeysFull(strRoot, strKeyPath))
1308end function
1309
1310
1311''
1312' Returns an array of value name strings.
1313function 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
1338end function
1339
1340
1341''
1342' Returns an array of full path value name strings.
1343function 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
1350end 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'
1363function 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
1391end function
1392
1393
1394''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1395' Helpers: Messaging and Output '
1396''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1397
1398''
1399' Append text to the log file and echo it to stdout
1400sub Print(str)
1401 LogPrint str
1402 Wscript.Echo str
1403end sub
1404
1405
1406''
1407' Prints a test header
1408sub PrintHdr(strTest)
1409 LogPrint "***** Checking for " & strTest & " *****"
1410 Wscript.Echo "Checking for " & StrTest & "..."
1411end sub
1412
1413
1414''
1415' Prints a success message
1416sub PrintResultMsg(strTest, strResult)
1417 dim cchPad
1418 LogPrint "** " & strTest & ": " & strResult
1419 Wscript.Echo " Found " & RightPad(strTest & ": ", 22) & strPad & strResult
1420end sub
1421
1422
1423''
1424' Prints a successfully detected path
1425sub 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
1434end sub
1435
1436
1437''
1438' Info message.
1439sub MsgInfo(strMsg)
1440 Print "info: " & strMsg
1441end sub
1442
1443
1444''
1445' Warning message.
1446sub MsgWarning(strMsg)
1447 Print "warning: " & strMsg
1448end sub
1449
1450
1451''
1452' Fatal error.
1453sub MsgFatal(strMsg)
1454 Print "fatal error: " & strMsg
1455 Wscript.Quit(1)
1456end sub
1457
1458
1459''
1460' Error message, fatal unless flag to ignore errors is given.
1461sub MsgError(strMsg)
1462 Print "error: " & strMsg
1463 if g_blnContinueOnError = False then
1464 Wscript.Quit(1)
1465 end if
1466 g_rcScript = 1
1467end sub
1468
1469''
1470' Error message, fatal unless flag to ignore errors is given.
1471' @note does not return
1472sub MsgSyntaxError(strMsg)
1473 Print "syntax error: " & strMsg
1474 Wscript.Quit(2)
1475end sub
1476
1477
1478''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1479' Helpers: Misc '
1480''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1481
1482''
1483' Translate a kBuild / VBox architecture name to a windows one.
1484function XlateArchitectureToWin(strArch)
1485 strArch = LCase(strArch)
1486 XlateArchitectureToWin = strArch
1487 if strArch = "amd64" then XlateArchitectureToWin = "x64"
1488end function
1489
1490
1491''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1492' Testcases '
1493''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
1494
1495''
1496' Self test for some of the above routines.
1497'
1498sub 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
1581end sub
1582
1583'
1584' Run the self tests if we're executed directly.
1585'
1586if 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."
1590end if
Note: See TracBrowser for help on using the repository browser.

© 2024 Oracle Support Privacy / Do Not Sell My Info Terms of Use Trademark Policy Automated Access Etiquette