VBScript++.txt

Option Explicit '*********************************************************** ' aggregating q:\utils\libs\extensionsbase.vbs '############################################################################### ' Library: ExtensionsBase.vbs ' ' About: ' Basic extensions to VBScript/QTP ' Things that *should* have been in VBScript but aren't ' (Except for strings, files and dates... this file got too big so they got moved) ' ' Copyright (C) 2008, 2009, 2010 Akien MacIain ' ' This program is free software: you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation, either version 3 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program. If not, see . ' ' Function/Dependencies: ReadPrefsFileIntoDict/class-lists.vbs ' '############################################################################### 'Option Explicit '=============================================================================== ' Section: Public Functions ' Functions that are exported by the library '=============================================================================== '------------------------------------------------------------------------------- ' Function: FrameworkDetectExtensionsBase ' Utility function for the Framework Compilation checking utility ' ' Returns: ' (integer) always returns 1 '------------------------------------------------------------------------------- Function FrameworkDetectExtensionsBase() FrameworkDetectExtensionsBase = 1 End Function '============================================================================================================ ' MISCELLANIOUS '------------------------------------------------------------------------------- ' Function: MakeHotTimer ' ' Returns a running timer object ' ' Parameters: ' - TimerName - The name of the timer to create ' ' Returns: ' - object - A MercuryTimer object which has been started (is "hot", which is to say, running) ' ' NOTE: ' In QTP a MercuryTimer is an object who's name is a string. This function adds the ' start time to the string. '------------------------------------------------------------------------------- '<<<-------TIMER GLOBAL SHARED DATA TO INSURE TIMER UNIQUENESS------->>> 'This module global timer assures we get unique timer names for each instance, 'even in the case of threaded code that overlaps calls On Error Resume Next Private vbscript_extensions_timerSinceStartup Set vbscript_extensions_timerSinceStartup = MercuryTimers.Timer("ScriptExecutionDurationTimer") vbscript_extensions_timerSinceStartup.Reset vbscript_extensions_timerSinceStartup.Start On Error Goto 0 Public Function MakeHotTimer(timerName) Dim MyTimer, stringName stringName = timerName & " - " & vbscript_extensions_timerSinceStartup.ElapsedTime Set MyTimer = MercuryTimers.Timer(stringName) 'LogTrace "routine=MakeHotTimer;message=Creating timer: " & stringName On Error Resume Next MyTimer.Start MyTimer.Stop MyTimer.Reset On Error Goto 0 MyTimer.Start Set MakeHotTimer = MyTimer End Function '------------------------------------------------------------------------------- ' Function: WSSHell ' ' Returns a WSSHell object. Uses the GlobalDictionary to store it so it ' doesn't have to recreate it every time ' ' Parameters: ' - None ' ' Returns: ' The WSSHell ' ' Notes: ' Assumes a GlobalDictionary to store it in ' '------------------------------------------------------------------------------- Function WSSHell() If IsEmpty(GlobalDictionary("wsshell")) Then GlobalDictionaryAdd "wsshell",CreateObject("WScript.Shell") End If Set WSSHell = GlobalDictionary("wsshell") End Function '============================================================================================================ ' ASSIGN GROUP '------------------------------------------------------------------------------- ' Sub: Assign ' ' Shortcut that performs an assignment after determining if the value to ' set is an object (and so using the Set keyword) ' ' Parameters: ' - variableToSet - the item to assign the value to ' - valueToSet - the value to assign to the item ' ' Usage: ' Assign foo, bar ' '------------------------------------------------------------------------------- Sub Assign (byref variableToSet, valueToSet) If IsObject(valueToSet) Then Set variableToSet = valueToSet Else variableToSet = valueToSet End If End Sub '------------------------------------------------------------------------------- ' Sub: AssignByPriority ' ' Shortcut that performs an assignment based on several options, some of which ' might be empty or NULL. Uses the first value in the list which is not empty ' or NULL. ' ' Parameters: ' - variableToSet - variable to assign to ' - vopt1 - option 1 ' - vopt2 - option 2 ' - vopt3 - option 3 ' - vopt4 - option 4 ' ' Usage: ' AssignByPriority phoneNumberToUse, cellNumber, homeNumber, workNumber, auntMarthasNumber ' '------------------------------------------------------------------------------- Sub AssignByPriority (byref variableToSet, ByVal opt1, ByVal opt2, ByVal opt3, ByVal opt4) AssignIfNotEmpty variableToSet, opt4 AssignIfNotEmpty variableToSet, opt3 AssignIfNotEmpty variableToSet, opt2 AssignIfNotEmpty variableToSet, opt1 End Sub '------------------------------------------------------------------------------- ' Sub: AssignIfNotEmpty ' ' Shortcut that performs an assignment after determining if the valueToSet ' variable is set to something OTHER THAN Empty, "", or NULL. If valueToSet ' is set to any of those values, variableToSet will be unchanged on exit ' ' Parameters: ' - variableToSet - the item to assign the value to ' - valueToSet - the value to assign to the item ' ' Usage: ' AssignIfNotEmpty foo, bar ' '------------------------------------------------------------------------------- Sub AssignIfNotEmpty (byref variableToSet, ByVal valueToSet) ' Assigns IF THE *valueToSet* IS NOT EMPTY If (IsEmpty(valueToSet) OR (valueToSet = "") OR IsNull(valueToSet)) = False Then variableToSet = valueToSet End If End Sub '------------------------------------------------------------------------------- ' Sub: AssignIfNull ' ' Part of the Assign family, AssignIfNull assigns "valueToSet" to the passed "variableToSet" ' if "variableToSet" is NULL on entry ' ' Parameters: ' - variableToSet - the item to assign the value to ' - valueToSet - the value to assign to the item ' ' Usage: ' AssignIfNull foo, bar ' '------------------------------------------------------------------------------- Sub AssignIfNull(ByRef variableToSet, valueToSet) If IsNull(variableToSet) Then Assign variableToSet, valueToSet End If End Sub '------------------------------------------------------------------------------- ' Sub: AssignIfEmpty ' ' Part of the Assign family, AssignIfEmpty assigns "variableToSet" to the passed "valueToSet" ' if "variableToSet" is NULL or Empty or "" on entry ' ' Parameters: ' - variableToSet - the item to assign the value to ' - valueToSet - the value to assign to the item ' ' Usage: ' AssignIfNull foo, bar ' '------------------------------------------------------------------------------- Sub AssignIfEmpty(byRef variableToSet, valueToSet) ' ASSIGNS IF THE CONTAINER IS EMPTY If IsNull(variableToSet) Then Assign variableToSet, valueToSet End If If IsEmpty(variableToSet) Then Assign variableToSet, valueToSet End If If NOT IsObject(variableToSet) Then If (variableToSet = "") Then Assign variableToSet, valueToSet End If End If End Sub '------------------------------------------------------------------------------- ' Sub: AssignIf ' ' If the condition is true, do the assignment of the resultIfTrue, else resultIfFalse ' see Notes for additional details ' ' Parameters: ' - variableToAssign - the variable to assign to ' - condition - the condition to evaluate ' - resultIfTrue - the value to assign if the condition evaluates to true ' - resultIfFalse - the value to assign if the condition evaluates to false ' ' Notes: ' This shortcut replaces steps for checking both the result of the condition ' AND whether the values to be assigned is an object or not '------------------------------------------------------------------------------- Sub AssignIf (ByRef variableToAssign, condition, resultIfTrue, resultIfFalse) On Error Resume Next Err.Clear Assign variableToAssign, Iif(condition, resultIfTrue, resultIfFalse) If Err.Number > 0 Then variableToAssign = False End If On Error Goto 0 End Sub '============================================================================================================ ' LOGIC '------------------------------------------------------------------------------- ' Function: Iif ' ' A simplistic replacement for the ternary operater for in C or Perl ' ' Parameters: ' - condition - The boolean condition to evaluate ' - trueValue - Return this if the condition is true ' - falseValue - Return this if the condition is false ' ' Returns: ' - variant - trueValue or falseValue depending on condition '------------------------------------------------------------------------------- Function Iif (condition, trueValue, falseValue) If condition Then Iif = trueValue Else Iif = falseValue End If End Function '============================================================================================================ ' TYPING AND CONVERSION '------------------------------------------------------------------------------- ' Function: IsAllBlank ' ' Returns true if all the values in the array are NULL, Empty or "" ' ' Parameters: ' - arrayOfValuesToCheck ' ' Returns: ' true if all the values in the array are NULL, Empty or "" ' '------------------------------------------------------------------------------- Function IsAllBlank(arrayOfValuesToCheck) Dim result, loopResult result = False Dim i For i = 0 to UBound(arrayOfValuesToCheck) loopResult = True If (arrayOfValuesToCheck(i) = "") OR IsNull(arrayOfValuesToCheck(i)) OR IsEmpty(arrayOfValuesToCheck(i)) Then loopResult = False End If result = loopResult OR result Next IsAllBlank = result ENd Function '------------------------------------------------------------------------------- ' Sub: VerifyNotEmpty ' ' if the variableToCheck is empty or NULL, logs a FATAL error ' ' Parameters: ' - variableToCheck - the variable to check the value of ' - routineReporting - routine that's reporting the error if this fails ' - errorMessageToReport - the message to post in the event of it not being empty ' '------------------------------------------------------------------------------- Sub VerifyNotEmpty(variableToCheck,routineReporting, errorMessageToReport) If IsEmpty(variableToCheck) OR IsNull(variableToCheck) Then LogFatal "routine=>" & routineReporting & "|message=>" & errorMessageToReport End If End Sub '------------------------------------------------------------------------------- ' Sub: VerifyDataValue ' ' if the variableToCheck is empty or NULL, logs a FATAL error ' ' Parameters: ' - expressionToCheck - the expression, should evaluate to either True or False ' - routineReporting - routine that's reporting the error if this fails ' - errorMessageToReport - the message to post in the event of the expression evaluating to false ' '------------------------------------------------------------------------------- Sub VerifyDataValue (expressionToCheck, routineReporting, errorMessageToReport) If NOT expressionToCheck Then LogFatal "routine=>" & routineReporting & "|message=>" & errorMessageToReport End If End Sub '------------------------------------------------------------------------------- ' Sub: VerifyValueNotEmpty ' ' if the variableToCheck is empty or NULL, logs a FATAL error ' ' Parameters: ' - expressionToCheck - the expression, should evaluate to either True or False ' - routineReporting - routine that's reporting the error if this fails ' - errorMessageToReport - the message to post in the event of the expression evaluating to false ' '------------------------------------------------------------------------------- Sub VerifyValueNotEmpty(valueToCheck,errorNumber,errorMessageToReport) If isReallyEmpty(valueToCheck) Then LogFatal "routine=>VerifyValueNotEmpty|message=>" & errorNumber & " - " & errorMessageToReport End If End Sub '------------------------------------------------------------------------------- ' Function: MakeBool ' ' Takes a string value and makes a boolean ' ' Parameters: ' - incomingValue - value to be rendered as a boolean ' ' Returns: ' True or False, depending on the input value (see notes) ' ' Notes: ' Conditions that will generate a true result are anything EXCEPT: ' False, Null, Empty, "", 0, "Off", "No", "False", "Blank", "0" '------------------------------------------------------------------------------- Function MakeBool(ByVal incomingValue) Dim result result = True AssignIf result, IsNull(incomingValue), False, result AssignIf result, incomingValue = False, False, result AssignIf result, incomingValue = Empty, False, result AssignIf result, Trim(incomingValue) = "", False, result If IsNumeric(incomingValue) Then AssignIf result, incomingValue = 0, False, result End If AssignIf result, Contains("OFF NO FALSE UNCHECKED 0 BLANK",UCase(incomingValue)), False, result MakeBool = result End Function '------------------------------------------------------------------------------- ' Function: CastAs ' ' Let's me forget about all these functions to convert thing to thing ' and you just give it the data and the target type as a string. ' ' Parameters: ' - typeOfThingAsString - the string of the type you wanna make, such as "boolean" ' - thingToCast - the thing you wanna convert ' ' Returns: ' - the converted thing ' ' Usage: ' foo = CastAs("boolean",myVariable) ' '------------------------------------------------------------------------------- Function CastAs(typeOfThingAsString, thingToCast) Dim result Select Case LCase(typeOfThingAsString) Case "string" result = CStr(thingToCast) Case "s" result = CStr(thingToCast) Case "integer" result = CInt(thingToCast) Case "i" result = CInt(thingToCast) Case "int" result = CInt(thingToCast) Case "bool" result = MakeBool(thingToCast) Case "boolean" result = MakeBool(thingToCast) Case "b" result = MakeBool(thingToCast) Case Else End Select CastAs = result End Function '------------------------------------------------------------------------------- ' Function: IsDict ' ' Returns true if item is an object and is a dictionary ' ' Parameters: ' - incoming - item to test ' ' Returns: ' True/False ' ' Usage: ' ' If IsDict(widget) Then ' ... ' '------------------------------------------------------------------------------- Function IsDict(incoming) Dim result result = False If IsObject(incoming) Then If NOT IsEmpty(incoming.Count) AND _ NOT IsEmpty(incoming.Keys) AND _ NOT IsEmpty(incoming.Items) Then result = True End If End If IsDict = result End Function '------------------------------------------------------------------------------- ' Function: IsReallyEmpty ' ' Returns true if the valueToCheck is NULL, Empty or "" ' ' Parameters: ' - valueToCheck - the value to check ' ' Returns: ' True if the thing is really empty ' '------------------------------------------------------------------------------- Function IsReallyEmpty(valueToCheck) Dim result result = FALSE On Error Resume Next If IsNull(valueToCheck) Then result = TRUE End If If IsEmpty(valueToCheck) Then result = TRUE End If If valueToCheck="" Then result = TRUE End If On Error Goto 0 IsReallyEmpty = result End Function '------------------------------------------------------------------------------- ' Function: IsDefined ' ' Returns true if the valueToCheck is NULL or Empty ' ' Parameters: ' - valueToCheck - the value to check ' ' Returns: ' True if the thing is really empty ' '------------------------------------------------------------------------------- Function IsDefined(valueToCheck) Dim result result = True If IsEmpty(valueToCheck) Then result = False End If If IsNull(valueToCheck) Then result = False End If IsDefined = result End Function '------------------------------------------------------------------------------- ' Function: MakeArrayIntoString ' ' Takes the data in an array and attempts to render it as a string of human ' readable characters. For instance and object gets replaced with "Object". ' The intent is that this is used for debugging. ' ' Parameters: ' - theArray ' ' Returns: ' A best guess string representation of the array ' '------------------------------------------------------------------------------- Function MakeArrayIntoString(theArray) MakeArrayIntoString = MakeItemPrintable(theArray) ' this is for backwards compatibility End Function '============================================================================================================ ' "SMART DICT" SPECIFIC EXTENSIONS '------------------------------------------------------------------------------- ' Sub: DictMake ' ' Renders incoming data into a dictionary. Takes arguments in the form of key/value ' pairs, seperated by => (key/value) or | (K/V pairs). Also takes arrays in the form ' Array(key1,value1,key2,value2...) ' ' Parameters: ' - Array or string of key/value pairs, as described above. ' - Modifiers (also in dict format) or NULL ' ' Returns: ' - Passed item is rendered as a dictionary ' ' Exceptions: ' - None ' ' Usage: ' MyRoutine "key1=>value1|key2=>value2" ' MyRoutine Array("key3",objectToPassIn,"key4",Array(1,2,3)) ' Sub MyRoutine args ' DictMake args, NULL ' print args("key1") ' ' Notes: ' items prefaced with are passed to an eval function before being assigned, like so: ' "boolean_thingie=>True|array_thingie=>Array(""A"",""B"")" ' NOTE: THIS THING WILL ONLY WORK WITH LITERALS! To pass in an object, you have to ' use the array version of the calling convention '------------------------------------------------------------------------------- Sub DictMake (byref newDict, args) If NOT IsNull(args) AND NOT ISEmpty(args) Then DictMake args, NULL ' this has to be null to prevent the thing from recursing forever Else Set args = CreateObject("Scripting.Dictionary") End If Dim passedStringArgs, passedArrayArgs, temp1, temp2 ' were we passed an undefined item? if so, make it a dict If IsNull(newDict) OR IsEmpty(newDict) Then If args.Exists ("dict_make.new_object_call") Then Set newDict = Eval(args("dict_make.new_object_call")) Else Set newDict = CreateObject("Scripting.Dictionary") newDict.CompareMode = vbTextCompare End If Else If NOT IsObject(newDict) Then ' if it's an object by the time we get here, we're done If NOT IsString(newDict) AND NOT IsArray(newDict) Then newDict = Array("item",newDict) End If ' were we passed a string? if so, make it an array If NOT IsObject(newDict) AND NOT IsArray(newDict) Then ' then it must be string ' does it have a seperator in it? If InStr(1, newDict, "=>") = 0 Then newDict = "item=>" & newDict End If ' PAIR SEPS IS |, and KEY/VALUE SEPS ARE => passedStringArgs = newDict newDict = Replace(newDict,"=>","|") ' we're just going to convert it into a key/pair array newDict = Split(newDict,"|") End If ' and now we either have a dict, and nothing more to do ' OR we have an array, and need to make a dict. Sooo.... If IsArray(newDict) Then ' The assumption is that even items in the array are keys, odd items are values passedArrayArgs = newDict Dim max max = UBound(newDict) If max => 0 Then ' do we have any items? Dim i, result Set result = CreateObject("Scripting.Dictionary") For i = 0 to max step 2 If i+1 <= max Then ' do we have an odd number of items? If IsObject(newDict(i+1)) Then ' we have to deal with obejcts with Set Set result(trim(newDict(i))) = newDict(i+1) Else ' one more test, is this a string which should be eval'd? If IsString(newDict(i+1)) Then ' basic eval If Left(CStr(newDict(i+1)),6)="" Then newDict(i+1) = Eval(Mid(newDict(i+1),7)) End If ' check for casting If Left(CStr(newDict(i+1)),6)="<CAST:" temp1="Mid(newDict(i+1),7)" Then")-1) temp2 = Mid(temp2,InStr(1,temp,">")+1) newDict(i+1) = CastAs(temp1,temp2) End If End If result(Trim(newDict(i))) = newDict(i+1) End If Else ' yes, we have an odd number of items, render the value of the last one null result(trim(newDict(i))) = NULL End If Next End If Set newDict = result ' now we stash the raw data for debugging newDict("dictmake.rawarray") = passedArrayArgs If NOT IsEmpty(passedStringArgs) Then newDict("dictmake.rawstring") = passedStringArgs End If End If Else ' this code is to deal with the wacky case where you're debugging, and ' some of the debugging code has made a temporary dict for you, which will ' go out of scope as soon as the subroutine ends. If newDict.Count = 0 Then If NOT (DictGet(args,"dict_make.skip_create_on_blank") = True) Then If args.Exists ("dict_make.new_object_call") Then Set newDict = Eval(args("dict_make.new_object_call")) Else Set newDict = CreateObject("Scripting.Dictionary") newDict.CompareMode = vbTextCompare End If End If End If End If End If End Sub '------------------------------------------------------------------------------- ' Sub: DictMakeExpectItem ' ' Renders incoming data into a dictionary. Takes arguments in the form of key/value ' pairs, seperated by => (key/value) or | (K/V pairs). Also takes arrays in the form ' Array(key1,value1,key2,value2...) ' ' NOTE: This function will return a dict containing the key:item. ' ' By calling this function, the caller is saying that what they want is a set ' of args that contain a key:item. If the passed dict, after initial processing ' by DictMake DOES NOT contain a key:item, then the whole dict will be placed ' inside of another dict, and labelled as item. ' ' THIS SHOULD ONLY BE USED BY ROUTINES EXPECTING A key:item ' ' Parameters: ' - Array or string of key/value pairs, as described above. ' - Modifiers (also in dict format) or NULL ' ' Returns: ' - Passed item is rendered as a dictionary ' ' Notes: ' See DictMake '------------------------------------------------------------------------------- Function DictMakeExpectItem (byref newDict, args) Dim result, temp DictMake newDict, args set result = newDict If NOT newDict.Exist("item") Then Set temp = DictCreate(NULL) Set temp("item") = result temp("this_object_auto_generated") = True Set result = temp End If Set newDict = result Set DictMakeExpectItem = result End Function '------------------------------------------------------------------------------- ' Function: DictUnwrapItemIfExists ' ' Undoes DictMakeExpectItem ' ' THIS SHOULD ONLY BE USED BY ROUTINES EXPECTING A key:item ' ' Parameters: ' - dict which was processed by DictMakeExpectItem ' ' Returns: ' - args("item") ' ' Notes: ' See DictMakeExpectItem '------------------------------------------------------------------------------- Function DictUnwrapItemIfExists (args) If args.Exist("this_object_auto_generated") Then Set args = args("item") End If Set DictUnwrapItemIfExists = args End Function '------------------------------------------------------------------------------- ' Function: DictCreate ' ' Returns a dict from some passed args ' ' Parameters: ' - args - a DictMake compatible input ' ' Returns: ' - a dictionary with the keys/values added ' ' Usage: ' Dim foo ' Set foo = DictCreate("key1=>value1|key2=>value2") ' '------------------------------------------------------------------------------- Function DictCreate(args) DictMake args, NULL Set DictCreate = args End Function '------------------------------------------------------------------------------- ' Sub: DictCopy ' ' Copies keys from one dict to another. performs shallow copy. ' ' Parameters (required): ' - args - a DictMake compatible input ' - key:from - dictionary: to copy from ' - key:to - dictionary: to copy to ' ' Parameters (allowed): ' - key:keys_to_copy - array: if null, just copy all the keys from the source dict ' - key:keys_to_avoid - array: avoid copying these keys ' ' Returns: ' - renders both dicts as dicts via DictMake ' ' Usage: ' DictCopy Array("to",dictToCopyTo,"from",dictToCopyFrom) ' DictCopy Array("to",dictToCopyTo,"from",dictToCopyFrom, "keys_to_copy",Array("key1","key2","key3")) ' '------------------------------------------------------------------------------- Sub DictCopy (copyFrom, copyTo, args) DictMake args, NULL DictMake copyFrom, NULL DictMake copyTo, NULL Dim keysToCopy Dim keysToAvoid Dim passedKeysToAvoid ' were we given a list of keys to copy? keysToCopy = DictWithdraw (args, "keys_to_copy") If IsEmpty(keysToCopy) Then KeysToCopy = copyFrom.Keys End If If IsString(KeysToCopy) Then KeysToCopy = Array(KeysToCopy) End If Set keysToAvoid = CreateObject("Scripting.Dictionary") keysToAvoid.CompareMode = vbTextCompare keysToAvoid("dictmake.rawarray") = True keysToAvoid("dictmake.rawstring") = True passedKeysToavoid = DictWithdraw(args, "keys_to_avoid") If IsString(passedKeysToAvoid) Then passedKeysToAvoid = Array(passedKeysToAvoid) End If If IsArray(passedKeysToAvoid) Then If UBound(passedKeysToAvoid) => 0 Then Dim j For j = 0 to UBound(passedKeysToAvoid) keysToAvoid(passedKeysToAvoid(j)) = True Next End If End If If UBound(KeysToCopy) => 0 Then Dim i, selectedKey For i = 0 to UBound(KeysToCopy) ' TBD: ADD CODE HERE TO REJECT ITEMS FROM THE KEYS TO AVOID Assign selectedKey, KeysToCopy(i) If NOT keysToAvoid(selectedKey) = True Then If IsObject(copyFrom(selectedKey)) Then Set copyTo(selectedKey) = copyFrom(selectedKey) Else copyTo(selectedKey) = copyFrom(selectedKey) End If End If Next End If End Sub '------------------------------------------------------------------------------- ' Function: DictGet ' ' Fetches a value from a dictionary if the value already exists. Will not ' create an empty key on access the way dict("foo") does. ' ' Parameters: ' - dictionaryToUse - the dictionary to attempt to fetch a value from ' - keyToCheckFor - the key to check existance of/fetch value from ' ' Returns: ' Either Empty or the value found in the dictionary ' ' Usage: ' myValue = DictGet(theDict, "foo") ' ' Notes: ' We need this because the simply using if dict("key") results in an empty key being created. ' '------------------------------------------------------------------------------- Function DictGet(dictionaryToUse, keyToCheckFor) DictGet = Empty If dictionaryToUse.Exists (keyToCheckFor) Then If IsObject(dictionaryToUse(keyToCheckFor)) Then Set DictGet = dictionaryToUse(keyToCheckFor) Else DictGet = dictionaryToUse(keyToCheckFor) End If End If End Function '------------------------------------------------------------------------------- ' Function: DictWithdraw ' ' Returns the specified value, and deletes the value from the dictionary. ' Non existant keys return empty and do not create empty keys. ' ' Parameters: ' - dictionaryTouse - Must *ALREADY* be a dictionary ' - keyToCheckFor - Key to select ' ' Returns: ' The item found at that key or Empty if no key found ' ' Usage: ' DictMake args, NULL ' mySSN = DictWithdraw args, "SSN" ' theOtherDict.ApplyKeys (args) ' copies everything *still* in args to theOtherDict ' '------------------------------------------------------------------------------- Function DictWithdraw(dictionaryTouse, keyToCheckFor) DictWithdraw = Empty If dictionaryToUse.Exists (keyToCheckFor) Then If IsObject(dictionaryToUse(keyToCheckFor)) Then Set DictWithdraw = dictionaryToUse(keyToCheckFor) Else DictWithdraw = dictionaryToUse(keyToCheckFor) End If dictionaryTouse.Remove keyToCheckFor End If End Function '------------------------------------------------------------------------------- ' Function: MakeDictIntoArray ' ' Render a Dictionary into an Array. Form is key,value,key,value... ' ' Parameters: ' - inDictionary - the dictionary to render as an array ' ' Returns: ' An arry with the contents of the dict in the form key,value,key,value... '------------------------------------------------------------------------------- Function MakeDictIntoArray(inDictionary) dim result(), loopi, keyArray, itemArray redim result( (inDictionary.count *2) - 1 ) dim aKey, anItem if inDictionary.count = 0 then MakeDictIntoArray = empty exit Function '<<< end if keyArray = inDictionary.keys itemArray = inDictionary.items for loopi = 0 to inDictionary.count-1 result(loopi*2) = keyArray(loopi) assign result(loopi*2 + 1), itemArray(loopi) next MakeDictIntoArray = result end function '------------------------------------------------------------------------------- ' Sub: GlobalDictionaryAdd ' ' This function is here because I don't want to have to always be checking existance ' in order to set defaults... Like TestName. Reduces 4 lines of code to 1 ' ' Parameters: ' - KeyName - String - Name of the key to add or overwrite ' - KeyValue - anytype - Data to add ' '------------------------------------------------------------------------------- Sub GlobalDictionaryAdd (KeyName,KeyValue) If GlobalDictionary.Exists(KeyName) Then GlobalDictionary.Remove(KeyName) End If GlobalDictionary.Add KeyName, KeyValue End Sub '------------------------------------------------------------------------------- ' Sub: GlobalDictionaryRemove ' ' If a value is defined, removes it ' ' Parameters: ' - KeyName - String - Name of the key to add or overwrite ' '------------------------------------------------------------------------------- Sub GlobalDictionaryRemove (KeyName) If GlobalDictionary.Exists(KeyName) Then GlobalDictionary.Remove(KeyName) End If End Sub '------------------------------------------------------------------------------- ' Sub: DictionaryAdd ' Adds a value to a dictionary. removes that key first if it's already there ' ' Parameters: ' - dictionaryToUse - the dictionary to add to (can be uninitialized) ' - keyName - the key to add the value under ' - keyValue - the value to add '------------------------------------------------------------------------------- Sub DictionaryAdd (dictionaryToUse,KeyName,KeyValue) DictMake dictionaryToUse, NULL DictionaryRemove dictionaryToUse, KeyName dictionaryToUse.Add KeyName, KeyValue End Sub '------------------------------------------------------------------------------- ' Sub: DictionaryAddConditional ' If the specified key does not already exist, add it. ' If it DOES exist, do nothing ' Creates the dict if the passed dictionaryToUse hasn't been initialized ' ' Used in the creation of complex records-containing-other-records ' where we use the dict as the record ' ' Parameters: ' - dictionaryToUse - the dictionary to use (can be uninitialized) ' - newKey - key to conditionally add ' - newValue - the new value to add ' ' Usage: ' DictionaryAddConditional memberRecord("coverageTypeSpanRecord"), "EnrollmentType", "New Hire" '------------------------------------------------------------------------------- Sub DictionaryAddConditional(dictionaryToUse,newKey,newValue) DictMake dictionaryToUse, NULL If IsNull(dictionaryToUse) OR IsEmpty(dictionaryToUse) Then Set dictionaryToUse = CreateObject("Scripting.Dictionary") End If If NOT dictionaryToUse.Exists(newKey) Then dictionaryToUse.Add newKey, newValue End If End Sub '------------------------------------------------------------------------------- ' Sub: DictionaryRemove ' Removes a value from a dictionary. (trying to remove a key that isn't there ' causes an exception, so this does the check first) ' ' Parameters: ' - dictionaryToUse - the dictionary to use ' - keyName - key to remove '------------------------------------------------------------------------------- Sub DictionaryRemove (dictionaryToUse, KeyName) DictMake dictionaryToUse, NULL If dictionaryToUse.Exists(KeyName) Then dictionaryToUse.Remove(KeyName) End If End Sub '------------------------------------------------------------------------------- ' Function: DictionaryMake ' DictMake is a sub, this is a complimentary function. returns the item ' from the function. same functionality, differnet calling form than DictMake ' ' Parameters: ' - itemsToPopulateWith - a DictMake compatible list of arguments ' ' Returns: ' - Created object ' ' Exceptions: ' - None '------------------------------------------------------------------------------- Function DictionaryMake (itemsToPopulateWith) Dim result Assign result, itemsToPopulateWith DictMake result, NULL if IsNull(result) OR IsEmpty(result) Then Set result = CreateObject("Scripting.Dictionary") End If Set DictionaryMake = result End Function '------------------------------------------------------------------------------- ' Function: ReadPrefsFileIntoDict ' ' reads a unix style preferences file and puts the name/value pairs into a dictionary ' ' Parameters: ' - fileName - name of the file to read from ' ' Returns: ' dictionary of name/value pairs populated from the file ' ' Notes: ' DEPENDENCY ON class-lists.vbs '------------------------------------------------------------------------------- Function ReadPrefsFileIntoDict(fileName) Dim result Set result = CreateObject("Scripting.Dictionary") Dim interimData Set interimData = NewList() interimData.ReadFromFile(fileName) Dim indexIntoPairs, temp For indexIntoPairs = 0 to interimData.MaXindex temp = InStr(1, interimData.Item(indexIntoPairs), "=") DictionaryAdd result, Mid(interimData.Item(indexIntoPairs),1,temp-1), Mid(interimData.Item(indexIntoPairs),temp+1) Next Set ReadPrefsFileIntoDict = result End Function '------------------------------------------------------------------------------- ' Sub: CopyKeysBetweenDicts ' ' used to copy a key or group of keys from one dict to another ' ' Parameters: ' - dictionaryToCopyFrom - the source dictionary ' - dictionaryToCopyTo - the target dictionary ' - arrayOfKeys - the keys to copy '------------------------------------------------------------------------------- Sub CopyKeysBetweenDicts(dictionaryToCopyFrom, dictionaryToCopyTo, arrayOfKeys) Set dictionaryToCopyTo = DictionaryMake(dictionaryToCopyTo) dim i For i = 0 to UBound(arrayOfKeys) dictionaryToCopyTo(arrayOfKeys(i)) = dictionaryToCopyFrom(arrayOfKeys(i)) Next End Sub '------------------------------------------------------------------------------- ' Sub: RecordModify ' ' This is used to modify dictionaries that are used as records, and may contain ' other similar dictionaries. ' ' Parameters: ' - recordToModify - the dictionary object ' - arrayOfRecordParantage - the array of keys to the specific subrecord ' - fieldName - the field name for the key to modify ' - newValue - the new value for that key ' ' Notes: ' This was developed for testing a record management application ' where each record could have many sub records and sub-sub records '------------------------------------------------------------------------------- Sub RecordModify(byRef recordToModify, arrayOfRecordParantage,fieldName,newValue) Dim dq, i, leftitem, rightitem, theRecord dq = chr(34) If IsNull(recordToModify) OR IsEmpty(recordToModify) Then Set recordToModify = CreateObject("Scripting.Dictionary") End If i = 0 leftitem = "recordToModify" ' arrayOfRecordParantage is null? means just add the field to the record If IsNull(arrayOfRecordParantage) Then If recordToModify.Exists(fieldName) Then recordToModify.Remove fieldName End If recordToModify.Add fieldName, newValue Else ' is string? make into array If NOT IsArray(arrayOfRecordParantage) Then arrayOfRecordParantage = Array(arrayOfRecordParantage) End If ' build the tree If UBound(arrayOfRecordParantage) > 0 Then ' arrays of more than one element For i = 0 to UBound(arrayOfRecordParantage) rightitem = dq & arrayOfRecordParantage(i) & dq 'print leftitem & ".Exists(" & rightitem & ") = " & Eval(leftitem & ".Exists(" & rightitem & ")") If NOT Eval(leftitem & ".Exists(" & rightitem & ")") Then Eval(leftitem).Add arrayOfRecordParantage(i), CreateObject("Scripting.Dictionary") End If 'print leftitem & ".Exists(" & rightitem & ") = " & Eval(leftitem & ".Exists(" & rightitem & ")") leftitem = leftitem & "(" & rightitem & ")" 'print "new leftitem = " & leftitem Next Else 'arrays of one element If NOT recordToModify.Exists(arrayOfRecordParantage(0)) Then recordToModify.Add arrayOfRecordParantage(0), CreateObject("Scripting.Dictionary") End If leftitem = "recordToModify" & InPeren(InQuotes(arrayOfRecordParantage(0))) End If Set theRecord = Eval(leftitem) If theRecord.Exists(fieldName) Then theRecord.Remove fieldName End If theRecord.Add fieldName, newValue 'print leftitem & "(" & dq & fieldName & dq & ")=" & theRecord(fieldName) End If End Sub '------------------------------------------------------------------------------- ' Function: MakeCopyOfDict ' ' This does a copy of one dict to another. It does a simple array from the ' keys and values, so in VBScript this is a shallow copy ' ' Parameters: ' - dictionaryToCopy - the dictionary to copy '------------------------------------------------------------------------------- Function MakeCopyOfDict(dictionaryToCopy) Dim result result = MakeDictIntoArray(dictionaryToCopy) DictMake result, NULL Set MakeCopyOfDict = result End Function '------------------------------------------------------------------------------- ' Function: IsAllKeysBlank ' ' Evaluates all the specified entries in a dict to see if they're all blank ' ' Parameters: ' - dictionaryToCheck - the dictionary to copy ' - arrayOfKeys - array of keys to check to see if they're blank ' '------------------------------------------------------------------------------- Function IsAllKeysBlank(dictionaryToCheck,arrayOfKeys) Dim result,i result = True For i = 0 to UBound(arrayOfKeys) If NOT IsReallyEmpty(dictionaryToCheck(arrayOfKeys(i))) Then result = False End If Next IsAllKeysBlank = result End Function '=============================================================================== ' OTHER OBJECT MANIPULATION '------------------------------------------------------------------------------- ' Function: GetClass ' ' Parameters: ' - incomingObject - the object who's class you wish to fetch ' ' Returns: ' The class name for classes which contain a className property ' else an empty string ' '------------------------------------------------------------------------------- Function GetClass(incomingObjectToGetClassOf) ' failed=incomingObject Dim classNameResult, className classNameResult = "" className = Empty On Error Resume Next Err.Clear classNameResult=incomingObjectToGetClassOf.className ' if we defined it, it should have this 'If Err.Number > 0 Then ' LogWarning "routine= Get_cursor;message=Expected error encountered while attempting to fetch class: " & Err.Number & ", " & Err.Description ' Err.Clear 'End If If classNameResult = "" Then ' i guess we didn't... is it a window? If incomingObjectToGetClassOf.Exist(0) Then className = incomingObjectToGetClassOf.GetROProperty("nativeclass") ' If Err.Number > 0 Then ' LogWarning "routine=GetClass;message=Expected error encountered while attempting to fetch nativeclass: " & Err.Number & ", " & Err.Description ' Err.Clear ' End If If NOT IsEmpty(className) Then classNameResult = className End If Else classNameResult = "unable to determine object type" End If End If Err.Clear On Error Goto 0 GetClass=classNameResult End Function '------------------------------------------------------------------------------- ' Function: GetItemIndexFromObjectContent ' ' Searches through the content of an object (as returned by the QTP GetContent ' mthod) for a given search item ' ' Parameters: ' - searchItem: the string we're looking for ' - objectContent: the content of the object as returned by the GetContent method, ' i.e. a single string delimited by vbLf characters ' ' Returns: ' - integer - The index of the item in the content if found, else -1 '------------------------------------------------------------------------------- Public Function GetItemIndexFromObjectContent (searchItem, objectContent) Dim items Dim i GetItemIndexFromObjectContent = -1 items = Split(objectContent, vbLf) For i = 0 to UBound(items) If items(i) = searchItem Then GetItemIndexFromObjectContent = i Exit For End If Next End Function '*********************************************************** ' aggregating q:\utils\libs\extensionsstrings.vbs '############################################################################### ' Library: ExtensionsStrings ' ' About: Basic extensions to VBScript/QTP - Akien MacIain ' Things that *should* have been in VBScript gathered together ' Functions supporting working with strings ' ' Copyright (C) 2008, 2009, 2010 Akien MacIain ' ' This program is free software: you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation, either version 3 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program. If not, see . ' '############################################################################### 'Option Explicit '=============================================================================== ' Section: Public Functions ' Functions that are exported by the library '=============================================================================== '------------------------------------------------------------------------------- ' Function: FrameworkDetectExtensionsStrings ' Utility function for the Framework Compilation checking utility ' ' Returns: ' (integer) always returns 1 '------------------------------------------------------------------------------- Function FrameworkDetectExtensionsStrings() FrameworkDetectExtensionsStrings = 1 End Function '------------------------------------------------------------------------------- ' Sub: QuickSort ' Implements a QuickSort for numeric or string arrays ' ' Parameters: ' - sortArray: (array) A one dimensional array to be sorted ' - loBound: (integer) The lower boundry of the array ' - hiBound: (integer) The upper boundry of the array ' ' Notes: ' the arrya is sorted in place. An example usage would be ' ' (code) ' QuickSort myArray, LBound(myArray), UBound(myArray) ' (end code) ' ' This code is taken from http://4guysfromrolla.com/webtech/012799-2.shtml. ' '------------------------------------------------------------------------------- Sub QuickSort(sortArray,loBound,hiBound) Dim pivot Dim loSwap Dim hiSwap Dim temp 'Two items to sort if hiBound - loBound = 1 then if sortArray(loBound) > sortArray(hiBound) then temp = sortArray(loBound) sortArray(loBound) = sortArray(hiBound) sortArray(hiBound) = temp End If End If 'Three or more items to sort pivot = sortArray(int((loBound + hiBound) / 2)) sortArray(int((loBound + hiBound) / 2)) = sortArray(loBound) sortArray(loBound) = pivot loSwap = loBound + 1 hiSwap = hiBound do 'Find the right loSwap while loSwap < hiSwap and sortArray(loSwap) <= pivot loSwap = loSwap + 1 wend 'Find the right hiSwap while sortArray(hiSwap) > pivot hiSwap = hiSwap - 1 wend 'Swap values if loSwap is less then hiSwap if loSwap < hiSwap then temp = sortArray(loSwap) sortArray(loSwap) = sortArray(hiSwap) sortArray(hiSwap) = temp End If loop while loSwap < hiSwap sortArray(loBound) = sortArray(hiSwap) sortArray(hiSwap) = pivot 'Recursively call function .. the beauty of Quicksort '2 or more items in first section if loBound < (hiSwap - 1) then QuickSort sortArray,loBound,hiSwap-1 '2 or more items in second section if hiSwap + 1 < hibound then QuickSort sortArray,hiSwap+1,hiBound End Sub '------------------------------------------------------------------------------- ' Function: F ' 2008 Akien MacIain ' Formats a string, a la printf [*DEPRECATED* - Replaced by ] ' ' Parameters: ' - theData - string - formatting template ' - passedArgs - array - items to replace with ' ' Returns: ' - string with substitutions ' ' Notes: ' is also aware of \n ' F("%1 is %2",Array("one", 1) ' %1 ' The following are planned, but not yet supported ' %{d=1;w=17;j=l;p=0} ' %{data=1;width=17;justify=l;padchar=0} '------------------------------------------------------------------------------- Function F(byval theData, byref passedArgs) If NOT IsArray(passedArgs) Then passedArgs=Array(passedArgs) End If Dim i If InStr(1,theData,"%") Then For i = 0 to UBound(passedArgs) theData = Replace(theData,"%"&i,passedArgs(i)) Next End If If InStr(1,theData,"\n") Then theData = Replace(theData,"\n",VbCrLf) End If If InStr(1,theData,"\d") Then theData = Replace(theData,"\d",Chr(34)) End If If InStr(1,theData,"%{") Then raise 1, "That's not supported yet!" End If f = theData End Function '------------------------------------------------------------------------------- ' Function: Fmt ' 2008 Akien MacIain ' Formats a string, a la printf ' ' Parameters: ' - theData - string - formatting template ' - passedArgs - array - items to replace with ' ' Returns: ' - string with sustitutions ' ' Notes: ' is also aware of \n ' F("%1 is %2",Array("one", 1) ' %1 ' The following are planned, but not yet supported ' %{d=1;w=17;j=l;p=0} ' %{data=1;width=17;justify=l;padchar=0} '------------------------------------------------------------------------------- Function Fmt(byval formatString, byref passedArgs) If NOT IsArray(passedArgs) Then passedArgs=Array(passedArgs) End If Dim i If InStr(1,formatString,"%") Then For i = 0 to UBound(passedArgs) formatString = Replace(formatString,"%"&i,passedArgs(i)) Next End If If InStr(1,formatString,"\n") Then formatString = Replace(formatString,"\n",VbCrLf) End If If InStr(1,formatString,"\d") Then formatString = Replace(formatString,"\d",Chr(34)) End If If InStr(1,formatString,"%{") Then raise 1, "That's not supported yet!" End If Fmt = formatString End Function '------------------------------------------------------------------------------- ' Function: CArrayOfStringFromDict ' ' takes a dict or a bag_dict and renders them as an array of string ' using the DictMake way of displaying the information. ' ' Primary use is object inspection at run time during debugging ' ' Parameters: ' - dictToReturn - can be a dict or a bag_dict (or anything implementing those interfaces) ' ' Returns: ' array of string in the form Array("key1=>value1","key2=>value2",...) ' ' Exceptions: ' - none. in case of error, returns string with error message (again, for clarity in debugging) ' ' Usage: ' In the debug watch window: CArrayOfStringFromDict(myDict) ' '------------------------------------------------------------------------------- Function CArrayOfStringFromDict(dictToReturn) Dim result, i, theKeys, theValues If NOT IsObject(dictToReturn) Then result = "passed an item which is not a dict" Else Set result = CreateObject("Scripting.Dictionary") theKeys = dictToReturn.Keys theValues = dictToReturn.Items For i = 0 to UBound(theKeys) result( theKeys(i) & "=>" & CString(theValues(i)) ) = True Next result = result.Keys End If CArrayOfStringFromDict = result End Function '------------------------------------------------------------------------------- ' Function: CString ' ' Attempts to take whatever is passed to it and render it as a string ' NULL gets rendered as , Empty gets rendered as ' Arrays are rendered as string representations of arrays. ' ' For objects of any kind, the code uses a series of rules rendered as ' If statements to attempt to determine useful information about the object ' and return class, window, dictionary or bag object information. ' For most of the classes we've defined, we've implemented a ' ClassName property. This will attempt to detect that. ' ' Parameters: ' - itemToRenderAsString ' ' Returns: ' either "" or a string representation of whatever was passed ' ' Exceptions: ' - none in this code, tho in the final else, anything that simply cannot ' be rendered as a string could well cause errors. THOSE ARE ' DELIBERATELY NOT TRAPPED. ' ' Usage: ' myString = CString(someOtherThingie) ' '------------------------------------------------------------------------------- Function CString(byVal itemToRenderAsString) Dim result, i result = "" If IsNull(itemToRenderAsString) Then result = "" ElseIf IsEmpty(itemToRenderAsString) Then result = "" ElseIf IsArray(itemToRenderAsString) Then For i = 0 to UBound(itemToRenderAsString) result = result & ", " & CString(itemToRenderAsString(i)) Next result = "Array(" & Mid(result,2) & ")" ElseIf IsObject(itemToRenderAsString) Then result = "Unknown object" If IsArray(itemToRenderAsString.keys) AND IsArray(itemToRenderAsString.items) Then result = "dictionary object" End If If itemToRenderAsString.Exists("self.is_bag_object") Then result = "bag_object of class " & itemToRenderAsString("self.class_name") End If Else result = "" & itemToRenderAsString & "" End If CString = result End Function '------------------------------------------------------------------------------- ' Function: MakeDictIntoString ' Render a dictionary as a string for debugging [*DEPRECATED* - replaced by ] ' ' Parameters: ' - inDictionary - incoming dictionary ' ' Returns: ' Contents of dictionary rendered as a set of strings ' ' Notes: ' This is an older form of CString (See ExtensionsStrings.vbs) '------------------------------------------------------------------------------- Function MakeDictIntoString(inDictionary) dim result, loopi, keyArray dim aKey, anItem keyArray = inDictionary.keys for each akey in keyArray result = result & akey & "=" assign anItem, inDictionary.item(akey) if isArray(anItem) then for loopi = 0 to ubound(anItem) result = result & anItem(loopi) & "," next result = result & ";" elseif isObject(anItem) then result = result & "is object;" else result = result & anItem & ";" end if next MakeDictIntoString = result end function '------------------------------------------------------------------------------- ' Function: IsString ' ' Returns true if item is a string ' ' Parameters: ' - incoming - item to test ' ' Returns: ' True/False ' ' Usage: ' ' If IsString(foo) Then ' ... ' '------------------------------------------------------------------------------- Function IsString(incoming) IsString = (TypeName(incoming) = "String") End Function '------------------------------------------------------------------------------- ' Function: Between ' returns the string found between two other strings ' ' Parameters: ' - superstring: (string) the string to search ' - leftstring: (string) the left string bounding the string we're looking for ' - rightstring: (string) the right string bounding the string we're looking for '------------------------------------------------------------------------------- Function Between(superstring, leftstring, rightstring) Dim result, iLeftIndex, iRightIndex result = "" iLeftIndex=Instr(1, superstring, leftstring,1)+Len(leftstring) iRightIndex=Instr(iLeftIndex,superstring,rightstring,1) If iRightIndex>iLeftIndex Then result=Mid(superstring,iLeftIndex,iRightIndex-iLeftIndex) End If Between=result End Function '------------------------------------------------------------------------------- ' Function: Contains ' Returns True/False of does the first arg contain the second arg? ' ' Parameters: ' - superItem: The item to check in ' - subItem: the item to check for ' ' Returns: ' - boolean '------------------------------------------------------------------------------- Function Contains(superItem, subItem) Dim result result = False ' currently the only support is for strings. ' here's where we'd add type checking for other data types ' i envision we might need to be able to process a List object ' or date ranges, or validate against lists within the UI of the AUT If InStr(1,superItem,subItem) > 0 Then result = True End If Contains = result End Function '------------------------------------------------------------------------------- ' Function: IsNumbersOnly ' Checks if a string contains only numbers (0-9) ' ' Parameters: ' - Input: (String) The string to check ' ' Returns: ' (Boolean) True if the string contains only numbers, false if it contains ' anything else. ' '------------------------------------------------------------------------------- Function IsNumbersOnly(Input) Dim numbers Dim i numbers="0123456789" IsNumbersOnly = True For i = 1 to Len(Input) If not (InStr(1,numbers,Mid(Input,i,1))>0) Then IsNumbersOnly = False Exit For End If Next End Function '------------------------------------------------------------------------------- ' Function: Digits ' ' Returns the numeric part of a string... $123,456.78 retuens 123456.78 ' because of the special nature of the - and . characters, "extras" are ignored ' so 123-456-7890 becomes -1234567890, and ..1..2..3..4 becomes 1.234 ' ' Parameters: ' - instring - the string to transform ' ' Returns: ' the modified string of digits ' '------------------------------------------------------------------------------- Function Digits(instring) Dim result, fMinus, fDecimal, sMasterList, i, s, iPosition result="" fMinus=FALSE fDecimal=FALSE sMasterList="--0123456789." ' walk the string, character by character... For i = 1 to len(instring) s = Mid(instring,i,1) iPosition=InStr(1,sMasterList,s) If iPosition>0 Then ' does it appear in the valid characters list? If (s="-") Then ' we can only have 1 negetion symbol, and it must go at the beginning If fMinus=FALSE Then fMinus=TRUE result="-"&result End If ElseIf s="." Then ' we can only have one decimal symbol If fDecimal=FALSE Then fDecimal=TRUE result=result&s End If Else result=result&s ' not a - or a . but does appear in the valid list, so add the character! End If End If Next If result="" Then result=0 End If Digits=result End Function '------------------------------------------------------------------------------- ' Function: StrictDigits ' ' returns just the digits (pays no attention to "-" or ".") ' ' Parameters: ' - incomingString - the string to transform ' ' Returns: ' the transofmred string ' '------------------------------------------------------------------------------- Function StrictDigits(incomingString) Dim allowedCharacters Dim resultString Dim i allowedCharacters="0123456789" resultString="" For i = 1 to Len(incomingString) If InStr(1,allowedCharacters,Mid(incomingString,i,1))>0 Then resultString = resultString & Mid(incomingString,i,1) End If Next StrictDigits=resultString End Function '------------------------------------------------------------------------------- ' Function: twoDigits ' ' returns Right("0" + incomingString,2) ' ' Parameters: ' - incomingString - the string to transform ' ' Returns: ' the transofmred string ' '------------------------------------------------------------------------------- Function twoDigits(incomingString) incomingString = "0" & Digits(incomingString) incomingString= Right(incomingString,2) twoDigits=incomingString End Function '------------------------------------------------------------------------------- ' Sub: SimpleSortStringArray ' ' Takes the passed array and returns it sorted ' ' Parameters: ' - sortMe - arry of strings to sort ' ' Returns: ' Modifies the passed array '------------------------------------------------------------------------------- Sub SimpleSortStringArray(ByRef sortMe) Dim keepGoing, changeHappened, tempValue, loopCounter keepGoing = True While keepGoing changeHappened = False For loopCounter = 0 to UBound(sortMe)-1 If (LCase(sortMe(loopCounter)) > LCase(sortMe(loopCounter+1))) OR IsEmpty(sortMe(loopCounter)) OR (sortMe(loopCounter)="") OR IsNull(sortMe(loopCounter))Then tempValue = sortMe(loopCounter) sortMe(loopCounter) = sortMe(loopCounter+1) sortMe(loopCounter+1) = tempValue changeHappened = True End If Next If NOT changeHappened Then keepGoing = False End If Wend End Sub '------------------------------------------------------------------------------- ' Function: InQuotes ' ' shortcut to wrap a string in quotes. (Written before I knew how to escape them) ' ' Parameters: ' - stringToUse - the string to wrap in quotes ' ' Returns: ' The string wrapped in quotes ' '------------------------------------------------------------------------------- Function InQuotes(stringToUse) InQuotes = chr(34) & stringToUse & chr(34) End Function '------------------------------------------------------------------------------- ' Function: InPeren ' ' shortcut to wrap a string in parenthesis ' ' Parameters: ' - stringToUse - the string to wrap in parenthesis ' ' Returns: ' The string wrapped in parenthesis ' '------------------------------------------------------------------------------- Function InPeren(stringToUse) InPeren = "(" & stringToUse & ")" End Function '------------------------------------------------------------------------------- ' Function: RoundString ' ' Used to take a string of text, extract the digits, and round it ' So can take "You will make #123,456.78.9 dollars" and turn it into 123456.79 ' ' Parameters: ' - sIncoming - string to transform ' - iDecPlaces - number of decimal places to round to ' ' Returns: ' The resultant number, after non digits are removed and it's rounded ' ' Notes: ' The last time I (Akien) worked on this function, I realized it was no longer ' being used by any part of the framework. I am leaving it in because it was used ' at one point, it's already here, and is potentially useful in the future '------------------------------------------------------------------------------- Function RoundString(sIncoming, iDecPlaces) RoundString=Round(CDbl(Digits(sIncoming)),iDecPlaces) End Function '------------------------------------------------------------------------------- ' Function: RightOf ' ' Returns all the string in the sSuperString which is to the right of the sSubString ' ' Parameters: ' - sSuperString - the string to check inside of ' - sSubString - the string to search for ' ' Returns: ' Either the complete sSupserString, if not found OR whatever is to the right ' of the sSubString ' ' Usage: ' x = RightOf("123.456",".") ' returns "456" '------------------------------------------------------------------------------- Function RightOf(sSuperString, sSubString) Dim sResult, iIndex sResult=sSuperString iIndex=InStr(1,sSuperString,sSubString) If iIndex > 0 Then sResult=Mid(sSuperString,iIndex+Len(sSubString)) End If RightOf=sResult End Function '------------------------------------------------------------------------------- ' Function: LeftOf ' ' Returns all the string in the sSuperString which is to the left of the sSubString ' ' Parameters: ' - sSuperString - the string to check inside of ' - sSubString - the string to search for ' ' Returns: ' Either the complete sSupserString, if not found OR whatever is to the left ' of the sSubString ' ' Usage: ' x = LeftOf("123.456",".") ' returns "123" '------------------------------------------------------------------------------- Function LeftOf(sSuperString, sSubString) Dim sResult, iIndex sResult=sSuperString iIndex = InStr(1,sSuperString,sSubString) If iIndex > 0 Then sResult=Mid(sSuperString,1,iIndex-1) End If LeftOf=sResult End Function '------------------------------------------------------------------------------- ' Function: PadLeft ' ' Pads the left side of a string with a specified character, and sets the string ' to a specific length ' ' Parameters: ' - incomingString - the starting string ' - padChar - the character to pad the string with ' - totalWidth - the width for the final result ' ' Returns: ' a string with the pad char added to the left, and then reduced to the target length ' ' Usage: ' print PadLeft("123","0",6) ' would print: 000123 ' '------------------------------------------------------------------------------- Function PadLeft(incomingString,padChar,totalWidth) Dim result result = String(totalWidth,padChar) result = result & incomingString result = Right(result,totalWidth) PadLeft = result End Function '------------------------------------------------------------------------------- ' Function: PadRight ' ' Pads the right side of a string with a specified character, and sets the string ' to a specific length ' ' Parameters: ' - incomingString - the starting string ' - padChar - the character to pad the string with ' - totalWidth - the width for the final result ' ' Returns: ' a string with the pad char added to the right, and then reduced to the target length ' ' Usage: ' print PadRight("123","0",6) ' would print: 123000 ' '------------------------------------------------------------------------------- Function PadRight(incomingString,padChar,totalWidth) Dim result result = String(totalWidth, padChar) result = incomingString & result result = Left(result,totalWidth) PadRight = result End Function '------------------------------------------------------------------------------- ' Function: MakeTextCompareString ' ' Shortcut to return a lower case string containing only letters and numbers ' used in the List object to do fuzzy compares ' ' Parameters: ' - stringToTransform - the string to transform ' ' Returns: ' string of lower case letters and numbers from the stringToTransform ' '------------------------------------------------------------------------------- Function MakeTextCompareString(stringToTransform) Dim CharacterIndex, Result, CurrentChar stringToTransform=LCase(stringToTransform) Result="" For CharacterIndex=1 to Len(stringToTransform) CurrentChar=Mid(stringToTransform,CharacterIndex,1) If (CurrentChar=>"a" AND CurrentChar <="z") OR (CurrentChar=>"0" AND CurrentChar <="9") Then Result=Result&CurrentChar End If Next MakeTextCompareString=Result End Function '------------------------------------------------------------------------------- ' Function: MakeItemPrintable ' ' Used for debugging. Attempts to render the data as a string. For instance, ' renders the array (1,2,3) as "Array(1,2,3)" ' ' Parameters: ' - theItem - the item to render into a printable form ' ' Returns: ' a best guess string representation of the item ' '------------------------------------------------------------------------------- Function MakeItemPrintable(theItem) Dim result, looper, objectType If IsArray(theItem) Then For looper = 0 to UBound(theItem) result = result & ", " & MakeItemPrintable(theItem(looper)) Next result = "Array(" & Mid(result,3) & ")" ElseIf IsNull(theItem) Then result = "*NULL*" ElseIf IsEmpty(theItem) Then result = "*EMPTY*" ElseIf IsObject(theItem) Then objectType = GetClass(theItem) If objectTYpe <> "" Then ' inside this IF is where we'd add processing for any other object types, eg Lists On Error Resume Next If NOT IsEmpty(theItem.ToString) Then result = theItem.ToString Else result = "Object of type " & objectType End If On Error Goto 0 Else result = "Object of unknown type" End If Else result = theItem End If MakeItemPrintable = result End Function '------------------------------------------------------------------------------- ' Function: MakeItemPrintableWithoutExtrernalArray ' ' Used for debugging - see MakeItemPrintable ' I created this because of the space limitations in the debugging window in ' QTP. Removing the "Arrray(" at the beginning let me see more of the data. ' ' Parameters: ' - theArray - Can actually be ANY kind of data. ' ' Returns: ' The string of the data sans any external "Array(" wrapper ' '------------------------------------------------------------------------------- Function MakeItemPrintableWithoutExtrernalArray(theArray) Dim result result = MakeItemPrintable(theArray) If Mid(result,1,6)="Array(" Then result = Mid(result,7,Len(result)-7) End If MakeItemPrintableWithoutExtrernalArray = result End Function '*********************************************************** ' aggregating q:\utils\libs\extensionsfiles.vbs '############################################################################### ' Library: ExtensionsFiles.vbs ' ' About: Basic extensions to VBScript/QTP - Akien MacIain ' Things that *should* have been in VBScript gathered together ' Functions supporting working with files ' ' Copyright (C) 2008, 2009, 2010 Akien MacIain ' ' This program is free software: you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation, either version 3 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program. If not, see . ' '############################################################################### 'Option Explicit '------------------------------------------------------------------------------- ' Function: FrameworkDetectExtensionsFiles ' Utility function for the Framework Compilation checking utility ' ' Returns: ' (integer) always returns 1 '------------------------------------------------------------------------------- Function FrameworkDetectExtensionsFiles() FrameworkDetectExtensionsFiles = 1 End Function '=============================================================================== ' Section: Constants and Globals '=============================================================================== '------------------------------------------------------------------------------- ' Constants: Public Constants ' Constants published by the library ' ' File System Object Constants: ' FSO_OVERWRITE_ON_COPY - Overwrite files or folders when copying ' FSO_DONT_OVERWRITE_ON_COPY - Do not overwrite files or folders when copying ' FSO_OVERWRITE_ON_CREATE - Overwrite files or folders on create ' FSO_DONT_OVERWRITE_ON_CREATE - Do not overwrite files or folders on create ' FSO_FORCE_DELETE - Force delete when the read-only attribute is set ' FSO_DONT_FORCE_DELETE - Do no delete when the read only attribute is set ' FSO_IOMODE_FOR_READING - Open files for reading only ' FSO_IOMODE_FOR_WRITING - Open files for writing ' FSO_IOMODE_FOR_APPENDING - Open files for writing and append ' FSO_IO_CAN_CREATE_NEW_FILE - Create a new text file if it doesn't already exist ' FSO_IO_CANT_CREATE_NEW_FILE - If the specified file doesn't exist, don't create it ' FSO_IO_FORMAT_SYSTEM_DEFAULT - Open file using system default format ' FSO_IO_FORMAT_UNICODE - Open file as Unicode ' FSO_IO_FORMAT_ASCII - Open file as ASCII '------------------------------------------------------------------------------- Public Const FSO_OVERWRITE_ON_COPY = True Public Const FSO_DONT_OVERWRITE_ON_COPY = False Public Const FSO_OVERWRITE_ON_CREATE = True Public Const FSO_DONT_OVERWRITE_ON_CREATE = False Public Const FSO_FORCE_DELETE = True Public Const FSO_DONT_FORCE_DELETE = False Public Const FSO_IOMODE_FOR_READING = 1 Public Const FSO_IOMODE_FOR_WRITING = 2 Public Const FSO_IOMODE_FOR_APPENDING = 8 Public Const FSO_IO_CAN_CREATE_NEW_FILE = True Public Const FSO_IO_CANT_CREATE_NEW_FILE = False Public Const FSO_IO_FORMAT_SYSTEM_DEFAULT = -2 Public Const FSO_IO_FORMAT_UNICODE = -1 Public Const FSO_IO_FORMAT_ASCII = 0 '=============================================================================== ' Section: Public Functions ' Functions that are exported by the library '=============================================================================== '------------------------------------------------------------------------------- ' Function: GetMD5ForFile ' Compute the MD5 hash for a given file ' ' The function makes use of the DotNetFactory to give us access to the .NET ' MD5 hashing algorithms. This is many orders of magnitude faster then a ' native VBScript MD5 algorithm. ' ' Parameters: ' - fileName: (String) The name of the file you want to process. NOTE that the ' function assumes that the file exists. ' ' Returns: ' (String) The MD5 hash for the file '------------------------------------------------------------------------------- Public Function GetMD5ForFile (fileName) Dim FileIO Dim MD5Provider Dim fileBytes Dim hashBytes Dim i Dim hash Dim d ' MercuryTimers.Timer("bft").Start Set FileIO = DotNetFactory.CreateInstance("System.IO.File") Set MD5Provider = DotNetFactory.CreateInstance("System.Security.Cryptography.MD5CryptoServiceProvider") Set fileBytes = FileIO.ReadAllBytes(fileName) Set hashBytes = MD5Provider.ComputeHash(fileBytes) hash = "" For i = 0 to hashBytes.Length - 1 hash = hash & hashBytes.GetValue(CInt(i)).ToString("x2") Next GetMD5ForFile = hash ' d = MercuryTimers.Timer("bft").Stop ' print "MD5 for file " & filename & " took " & d & "ms" Set FileIO = Nothing Set MD5Provider = Nothing Set fileBytes = Nothing Set hashBytes = Nothing End Function '------------------------------------------------------------------------------- ' Function: ValidateManifestFile ' Validates that all the files listed in a manifest have the correct file ' version ' ' It does this by comparing the MD5 hash for the file to the hash stored in the ' manifest. The format for the manifest is ,, one entry per line ' ' Parameters: ' - fileName: (String) The name of the manifest file you want to process. ' ' Returns: ' (Boolean) True if the file validates, false if it does not '------------------------------------------------------------------------------- Public Function ValidateManifestFile (fileName) Dim i Dim checkFailed Dim manifestFile Dim manifest checkFailed = False Set manifestFile = FSO().OpenTextFile(fileName, 1) Do While manifestFile.AtEndOfStream <> True manifest = Split(manifestFile.ReadLine, ",") If GetMD5ForFile(manifest(0)) <> manifest(1) Then checkFailed = True Exit Do End If Loop manifestFile.Close Set manifestFile = Nothing If checkFailed Then ValidateManifestFile = False Else ValidateManifestFile = True End If End Function '------------------------------------------------------------------------------- ' Function: FileNamePortionExtractFromPath ' ' takes C:\foo\bar\babble.txt, .txt returns babble ' ' Parameters: ' - stringFileName - string - full path ' - extension - string - the extension expected at the end ' ' Returns: ' - string with just file name part (assumes Windows directory seperation characters) ' '------------------------------------------------------------------------------- Function FileNamePortionExtractFromPath(stringFileName, extension) Dim c, d c = LeftOf(stringFileName, extension) d = c While Contains(d,"\") d = RightOf(d,"\") Wend FileNamePortionExtractFromPath = d End Function '------------------------------------------------------------------------------- ' Function: FileNameDataExtractor ' ' takes C:\foo\bar\babble.txt, returns a dict with all file data (see below) ' ' Parameters: ' - stringFileName - string - full path ' ' Returns: a dict with these fields: ' - Key:passedFileSpec ' - Key:fullName ' - Key:drive ' - Key:path ' - Key:name ' - Key:extension ' - Key:exists ' - Key:fullPath ' - Key:arrayOfDirectories ' - Key:fso.fileObject ' - Key:fso.parentFolderObject ' - Key:attributes ' - Key:dateCreated ' - Key:dateLastAccessed ' - Key:dateLastModified ' - Key:size ' - Key:type ' '------------------------------------------------------------------------------- Function FileNameDataExtractor(byVal stringFileName) Dim resultDir, temp, i Set resultDir = CreateObject("Scripting.Dictionary") resultDir("passedFileSpec") = stringFileName resultDir("fullPath") = FSO().GetAbsolutePathName(stringFileName) resultDir("exists") = FSO().FileExists(stringFileName) If resultDir("exists") Then ' fetch everything from the disk Dim theFile, theDir stringFileName = resultDir("fullPath") resultDir("fullName") = FSO().GetFileName(stringFileName) Set resultDir("fso.fileObject") = FSO().GetFile(stringFileName) Set resultDir("fso.parentFolderObject") = FSO().GetFile(stringFileName).ParentFolder Set theFile = resultDir("fso.fileObject") Set theDir = resultDir("fso.parentFolderObject") resultDir("name") = FSO().GetBaseName(stringFileName) resultDir("extension") = FSO().GetExtensionName(stringFileName) resultDir("drive") = Left(theFile.Drive,1) resultDir("path") = theDir.Path & "\" If Mid(resultDir("path"),2,1)=":" Then resultDir("path") = Mid(resultDir("path"),3) End If temp = resultDir("path") If Left(temp,1) = "\" Then temp = Mid(temp,2) End If If Right(temp,1) = "\" Then temp = Mid(temp,1,Len(temp)-1) End If resultDir("arrayOfDirectories") = Split(temp,"\") resultDir("attributes") = theFile.Attributes resultDir("dateCreated") = theFile.DateCreated resultDir("dateLastAccessed") = theFile.DateLastAccessed resultDir("dateLastModified") = theFile.DateLastModified resultDir("size") = theFile.Size resultDir("type") = theFile.Type Else ' apperently, we're on our own. the file doesn't actually exist ' on the disk so we only have the file name to go on End If End Function '------------------------------------------------------------------------------- ' Function: FSO() ' ' Returns a file system object. Uses the GlobalDictionary to store it so it ' doesn't have to recreate it every time ' ' Parameters: ' - None ' ' Returns: ' The FSO ' ' Notes: ' Assumes a GlobalDictionary to store it in '------------------------------------------------------------------------------- Function FSO() If IsEmpty(GlobalDictionary("fso")) Then GlobalDictionaryAdd "fso",CreateObject("Scripting.FileSystemObject") End If Set FSO = GlobalDictionary("fso") End Function '------------------------------------------------------------------------------- ' Sub: WriteArray ' ' Writes an array of strings to a file name ' ' Parameters: ' - arrayToWrite - the array of strings to write ' - fileName - the file to write to ' ' Notes: ' Dependency on the List object elsewhere in this library set '------------------------------------------------------------------------------- Sub WriteArray (arrayToWrite, fileName) Dim writeList Set writeList = NewList() If IsObject(arrayToWrite) Then writeList.l = arrayToWrite.l Else writeList.l = arrayToWrite End If writeList.WriteToFile fileName writeList = Empty End Sub '------------------------------------------------------------------------------- ' Sub: MakeFolder ' ' Shortcut that makes the named folder (I got tired of always creating an FSO) ' ' Parameters: ' - folderName - The name of the folder to create ' ' Notes: ' Dependency on the FSO() function elsewhere in this library set '------------------------------------------------------------------------------- Sub MakeFolder(folderName) 'Dim fso 'Set fso = CreateObject("Scripting.FileSystemObject") If FSO().FolderExists(folderName) = False Then FSO().CreateFolder(folderName) End If End Sub '------------------------------------------------------------------------------- ' Sub: Run ' ' Runs a command line ' ' Parameters: ' - commandLine - What to run ' ' Notes: ' Dependency on WSSHell() defined elsewhere in this library set '------------------------------------------------------------------------------- Sub Run (commandLine) WSSHell().Run commandLine,1,False End Sub '------------------------------------------------------------------------------- ' Sub: RunAndWait ' ' Takes a command line, runs it, and waits for it to complete ' ' Parameters: ' - commandLine - the command line to execute ' ' Notes: ' Dependency on WSShell() defined elsewhere in this library set '------------------------------------------------------------------------------- Sub RunAndWait (commandLine) WSSHell().Run commandLine,1,True End Sub '------------------------------------------------------------------------------- ' Function: FileExists ' ' Another FSO related short cut. This one returns file existance ' ' Parameters: ' - sFilespec - the file to check the existance of ' ' Returns: ' True or False based on whether the file could be found ' ' Notes: ' This current incarnation depends on FSO() defined elsewhere in this library set '------------------------------------------------------------------------------- Function FileExists(sFilespec) 'Dim fso 'Set fso = CreateObject("Scripting.FileSystemObject") FileExists = FSO().FileExists(sFilespec) End Function '------------------------------------------------------------------------------- ' Sub: VerifyFileExist ' ' Logs a fatal error if the specified file does not exist ' ' Parameters: ' - fileName ' ' Notes: ' Depends on FileExists defined elsewhere in this library '------------------------------------------------------------------------------- Sub VerifyFileExist(fileName) If not FileExists(fileName) Then LogFatal "routine=>VerifyFileExist|message=>File does not exist: " & fileName End If End Sub '------------------------------------------------------------------------------- ' Sub: FileDelete ' ' Shortcut to delete a file ' ' Parameters: ' - filespec - the file to delete ' ' Notes: ' Another shortcut. this one depends on FSO() defined elsewhere in this library set '------------------------------------------------------------------------------- Sub FileDelete(filespec) 'Dim fso 'Set fso = CreateObject("Scripting.FileSystemObject") If FileExists(sFileSpec) Then FSO().DeleteFile(filespec) End If End Sub '------------------------------------------------------------------------------- ' Function: WriteTestImage [DEPRICATED] ' ' Writes an image of the desktop to a file in the framework logging directory ' fileName = FetchLogDir() & ReturnYYYYMMDDHHMM & "." & TestCase("name") & ".StoredImage.png" ' ' Parameters: ' - None ' ' Returns: ' - No return value ' '------------------------------------------------------------------------------- Function WriteTestImage () Dim fileName fileName = FetchLogDir() & ReturnYYYYMMDDHHMM & "." & TestCase("name") & ".StoredImage.png" Desktop.CaptureBitmap fileName, True End Function '------------------------------------------------------------------------------- ' Function: WriteTestDataFile ' ' Writes an array of data to a file in the framework logging directory ' fileToWriteTo = FetchLogDir() & ReturnYYYYMMDDHHMM & "." & TestCase("name") & ".FoundData.txt" ' ' Parameters: ' - arrayToWrite ' ' Returns: ' - No return value ' '------------------------------------------------------------------------------- Function WriteTestDataFile(arrayToWrite) Dim fileToWriteTo fileToWriteTo = FetchLogDir() & ReturnYYYYMMDDHHMM & "." & TestCase("name") & ".FoundData.txt" WriteArray arrayToWrite, fileToWriteTo LogDebug "routine=>WriteTestDataFile;message=>" & "File:[" & fileToWriteTo ' & "] Data written:[" & arrayToWrite & "]" End Function '*********************************************************** ' aggregating q:\utils\libs\extensionsdates.vbs '############################################################################### ' Library: ExtensionsDates.vbs ' ' About: Basic extensions to VBScript/QTP - Akien MacIain ' Things that *should* have been in VBScript gathered together ' Functions supporting working with dates ' ' Copyright (C) 2008, 2009, 2010 Akien MacIain ' ' This program is free software: you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation, either version 3 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program. If not, see . ' '############################################################################### 'Option Explicit '------------------------------------------------------------------------------- ' Function: FrameworkDetectExtensionsDates ' Utility function for the Framework Compilation checking utility ' ' Returns: ' (integer) always returns 1 '------------------------------------------------------------------------------- Function FrameworkDetectExtensionsDates() FrameworkDetectExtensionsDates = 1 End Function '=============================================================================== ' Section: Public Functions ' Functions that are exported by the library '=============================================================================== ' 1) Assignments ' 2) Typing ' 3) Conversion '------------------------------------------------------------------------------- ' Function: returnyyyymmddhhmm ' ' strips off date time NOW in the form yyyymmddhhmmss ' ' Parameters: ' - none ' ' Returns: ' 'yymmddhhmmss' ' ' Notes: ' Assumes DateTime to be 'yyyymmddhhmmss' (12 digits) '------------------------------------------------------------------------------- Function returnyyyymmddhhmm() 'return 14 digits(yymmddhhmmssxx), last 2-digits is a random number returnyyyymmddhhmm = right(year(Date), 2) returnyyyymmddhhmm = returnyyyymmddhhmm & PrefixWithZeros(Month(Date),2) returnyyyymmddhhmm = returnyyyymmddhhmm & PrefixWithZeros(Day(Date),2) returnyyyymmddhhmm = returnyyyymmddhhmm & PrefixWithZeros(Hour(Time),2) returnyyyymmddhhmm = returnyyyymmddhhmm & PrefixWithZeros(Minute(Time),2) returnyyyymmddhhmm = returnyyyymmddhhmm & PrefixWithZeros(Second(Time),2) Randomize returnyyyymmddhhmm = returnyyyymmddhhmm & PrefixWithZeros(int(rnd*100),2) ' (OR in 1 sentence) ' returnyyyymmddhhmm = year(Date) & PrefixWithZeros(Month(Date),2) & PrefixWithZeros(Day(Date),2) & PrefixWithZeros(Hour(Time),2) & PrefixWithZeros(Minute(Time),2) End Function '------------------------------------------------------------------------------- ' Function: StripOffDateTimeSuffix ' ' strips off date time suffix IF IT is suffixed and returns ' If there is no such suffix, the whole value is returned ' ' Parameters: ' - 'DateTime suffix to be 'yyyyddmmhhmm' (12 digits) ' ' Returns: ' Value stripped of date time suffix ' ' Notes: ' Assumes DateTime suffix to be 'yyyyddmmhhmm' (12 digits) '------------------------------------------------------------------------------- Function StripOffDateTimeSuffix(lastName) Dim dateStr StripOffDateTimeSuffix = lastName If len(lastName) > 12 Then dateStr = right(lastName, 12) If (isNumeric(dateStr)) Then StripOffDateTimeSuffix = mid(lastName, 1, (len(lastName) - 12)) End If End If End Function '------------------------------------------------------------------------------- ' Function: PrefixWithZeros ' ' crude routien to prefix any numeric value < 10 with 0 ' ' Parameters: ' - none ' ' Returns: ' Prefixed value ' ' Notes: ' Lots of work needed if this is to be used as generic function '------------------------------------------------------------------------------- Function PrefixWithZeros(num, places) PrefixWithZeros = num If num < 10 Then PrefixWithZeros = "0" & num End If End Function '------------------------------------------------------------------------------- ' Function: GetDateString ' ' Gets the current date and time in the format YYYYMMDD-HHMI ' ' Parameters: ' - none ' ' Returns: ' - string - containing the current date in time as YYYYMMDD-HHMI '------------------------------------------------------------------------------- Public Function GetDateString Dim formatter Dim timestamp timestamp = Now() Set formatter = NewcvDateFormat GetDateString = formatter.FormatDate(timestamp, "YYYYMMDD") & "-" & formatter.FormatTime(timestamp, "HHMM") End Function '------------------------------------------------------------------------------- ' Function: PadExcelDateString ' ' Given a string taken from an excel spreadsheet and pads out the month and day ' if necessary to ensure the result is in the format MMDDYYY ' ' Parameters: ' - excelDate - The date string as read out of an excel spreadsheet ' ' Returns: ' - string - The date padded out to eight characters ' '------------------------------------------------------------------------------- Public Function PadExcelDateString (excelDate) Dim dateString Dim formatter If (Trim(excelDate) = "") Then PadExcelDateString = "" Exit Function End If excelDate = StrictDigits(excelDate) If Len(excelDate) = 8 and IsNumbersOnly(excelDate) Then PadExcelDateString = excelDate Exit Function End If Set formatter = NewcvDateFormat PadExcelDateString = formatter.FormatDate(excelDate, "MMDDYYYY") End Function '------------------------------------------------------------------------------- ' Function: PrettyPrintTimer ' ' This function takes in a time interval in milliseconds and returns a pretty ' string in the format 'X Hour(s) Y Minute(s) Z second(s) Q millisecond(s)' ' ' The function was originaly developed by Ryan Trudelle-Schwarz for www.mamanze.com ' ' Parameters: ' - delta: (Integer) The interval in milliseconds to format ' ' Returns: ' (String) A pretty printed string representing the time interval ' '------------------------------------------------------------------------------- Function PrettyPrintTimer(byVal delta) Dim intMilliSecond, intSecond, intMinute, intHour Dim strReturn strReturn ="" ' Determine the number of milliseconds. intMilliSecond = delta mod 1000 ' Determine the number of seconds. This is not the second value ' yet, just the number of seconds. intSecond = Int(delta/1000) ' Determine the number of minutes, simply divide the total number ' of seconds by 60 and get the real number result. intMinute = Int(intSecond / 60) ' Now we modulus the seconds by 60 to form the seconds value. intSecond = intSecond mod 60 ' Compute the Hours value by dividing the minutes by 60. intHour = Int(intMinute / 60) ' Compute the actual minute value by getting the modulus of the ' total number of minutes and 60. intMinute = intMinute mod 60 ' If the timer took more then a hour then display the hours. If intHour > 0 Then If intHour = 1 Then strReturn = strReturn & intHour &" Hour " Else strReturn = strReturn & intHour &" Hours " End If End If ' If the timer took more then a minute then display the minutes. If intMinute > 0 Then If intMinute = 1 Then strReturn = strReturn & intMinute &" Minute " Else strReturn = strReturn & intMinute &" Minutes " End If End If ' If the timer took more then a second then display the seconds. If intSecond > 0 Then If intSecond = 1 Then strReturn = strReturn & intSecond &" Second " Else strReturn = strReturn & intSecond &" Seconds " End If End If ' If the timer took more then a millisecond then display the ' milliseconds. Also, if the script took no time then display 0 ' milliseconds. If strReturn ="" OR intMilliSecond > 0 Then If intMilliSecond = 1 Then strReturn = strReturn & intMilliSecond &" MilliSecond" Else strReturn = strReturn & intMilliSecond &" MilliSeconds" End If End If PrettyPrintTimer = strReturn End Function '------------------------------------------------------------------------------- ' Function: GetYesterdaysDate ' ' Get yesterday's date using the format specified by the format parameter ' ' Parameters: ' - Format - a cvDateFormat compliant format string ' ' Returns: ' - string - containing yesterdays date in the format specified by format '------------------------------------------------------------------------------- Function GetYesterdaysDate(format) Dim formatter Set formatter = NewcvDateFormat GetYesterdaysDate = formatter.FormatDate(Date - 1, format) End Function '------------------------------------------------------------------------------- ' Function: targetdate ' ' Get older date using the numberofyears parameter ' ' Parameters: ' - numberofyears ' ' Returns: ' - integer - containing older date. '------------------------------------------------------------------------------- Function targetdate (numberofyears) Dim currentdate,datearray,targetyear currentdate = date If numberofyears = " " Then numberofyears = 0 End If datearray = split (currentdate, "/") targetyear = datearray(2) - numberofyears targetdate = datearray (0) & "/" & datearray(1) & "/" & targetyear End Function '------------------------------------------------------------------------------- ' Function: MMDDYYYY ' Retuns the date formatted as MMDDYYYY ' ' Parameters: ' - aDate - a date, e.g. 7/9/2008 ' ' Returns: ' return date in format: "MMDDYYYY" '------------------------------------------------------------------------------- Function MMDDYYYY(aDate) ' return date in format: "MMDDYYYY" Dim aday, amonth aday = day(aDate) if aday <10 then aday = "0" & aday end if amonth = month(aDate) if amonth <10 then amonth = "0" & amonth end if MMDDYYYY = amonth & aday & year(aDate) End Function '------------------------------------------------------------------------------- ' Function: MMDDYYYY_slash(aDate) ' parameter : a date, e.g. 7/9/2008 or date Function ' Returns: ' return date in format: "MM/DD/YYYY" '------------------------------------------------------------------------------- Function MMDDYYYY_slash(aDate) ' return date in format: "MM/DD/YYYY" Dim aday, amonth aday = day(aDate) if aday <10 then aday = "0" & aday end if amonth = month(aDate) if amonth <10 then amonth = "0" & amonth end if MMDDYYYY_slash = amonth & "/" & aday & "/" & year(aDate) End Function '------------------------------------------------------------------------------- ' Function: DateDiffMMDDYYYY ' Get the difference between two dates formatted as MMDDYYYY ' ' Parameters: ' date1 - date to subtract from ' date2 - the date to subtract ' ' Returns: ' 0 if same; =1 if date1 > date2; =-1 if date1 < data2 '------------------------------------------------------------------------------- function DateDiffMMDDYYYY(date1, date2) date1 = right(date1,4) & left(date1, 4) date2 = right(date2,4) & left(date2, 4) 'if right(date1,4) = right(date2, 4) then if date1 = date2 then DateDiffMMDDYYYY = 0 elseif date1 > date2 then DateDiffMMDDYYYY = 1 else DateDiffMMDDYYYY = -1 end if end function '------------------------------------------------------------------------------- ' Function: DateAddDaysMMDDYYYY ' ' similar to DateAdd, except date format is MMDDYYYY ' ' Parameters: ' - dateIn - the date to add days to ' - number - the number of days to add ' ' Returns: ' a date in format MMDDYYYY ' ' Usage: ' DateAddDaysMMDDYYYY("02132007", -1) would return "02132006" '------------------------------------------------------------------------------- function DateAddDaysMMDDYYYY(dateIn, number) dim yyyy, mm, dd, date2 yyyy = right(dateIn, 4) mm = left(dateIn, 2) dd = mid(dateIn, 3, 2) date2 = mm & "/" & dd & "/" & yyyy DateAddDaysMMDDYYYY = MMDDYYYY( dateAdd("d", number, date2) ) end function '*********************************************************** ' aggregating q:\utils\libs\vbscript++.vbs '############################################################################### ' Library: VBScript++.vbs ' ' THIS IS A KEY ARCHITECTURAL COMPONENT, THE ARCHITECT SHOULD BE NOTIFIED OF ' CHANGES TO THIS FILE. ' ' About: ' True object support for VBScript ' Copyright (C) 2008, 2009, 2010 Akien MacIain ' ' This program is free software: you can redistribute it and/or modify ' it under the terms of the GNU General Public License as published by ' the Free Software Foundation, either version 3 of the License, or ' (at your option) any later version. ' ' This program is distributed in the hope that it will be useful, ' but WITHOUT ANY WARRANTY; without even the implied warranty of ' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ' GNU General Public License for more details. ' ' You should have received a copy of the GNU General Public License ' along with this program. If not, see . ' ' Feature List: ' - Implements Bag object, the substrate for all BagClasses and BagObjects ' - Including the ability to define a class ' - And to create an instance of a class ' - To call methods and properties of a class ' - To determine if an object is a Bag, BagClass or BagInstance ' - To create from a dictionary or from a text string a BagDict ' ' Usage: ' '############################################################################### 'Option Explicit '------------------------------------------------------------------------------- ' Function: FrameworkDetectVBScriptPlusPlus ' Utility function for the Framework Compilation checking utility ' ' Returns: ' (integer) always returns 1 '------------------------------------------------------------------------------- Function FrameworkDetectVBScriptPlusPlus() FrameworkDetectVBScriptPlusPlus = 1 End Function '============================================================================================================ ' OBJECT MODEL SPECIFIC EXTENSIONS - VBScript++.vbs '------------------------------------------------------------------------------- ' Function: IsBag ' ' Returns true if item is an object, and the object is a bag_dict ' ' Parameters: ' - incoming - item to test ' ' Returns: ' True/False ' ' Usage: ' ' If IsBag(foo) Then ' ... ' '------------------------------------------------------------------------------- Function IsBag(incoming) Dim result result = False If IsDict(incoming) Then If incoming.Item("self.is_bag_dict") = True Then result = True End If End If IsBag = result End Function '------------------------------------------------------------------------------- ' Function: BagDictMake ' ' Makes and returns a bag dict. Not a bag class, but the container that makes ' those work. ' ' Parameters: ' - args - A DictMake compatible argument or dictionary ' ' Returns: ' A Bag Dict object with whatever keys have been handed over in args copied to it ' via a shallow copy ' ' Usage: ' Set myDict = BagDictMake("my_string=>Hello world!") ' '------------------------------------------------------------------------------- Function BagDictMake (args, metaArgs) If IsBagDict(args) Then Set BagDictMake = args Else Set BagDictMake = New BagDict BagDictMake.ApplyKeys(args) End If If NOT IsNull(metaArgs) Then BagDictMake.ApplyMetadata(metaArgs) End If End Function '------------------------------------------------------------------------------- ' Sub: BagDictCreate ' ' Like DictMake, alters the incoming args to be the bag dict ' ' Parameters: ' - args - item to be rendered as a dict ' ' Usage: ' foo = "thingie=>hello world" ' DoIt foo ' Sub DoIt(args) ' BagDictCreate args ' myThingie = args("thingie") ' '------------------------------------------------------------------------------- Sub BagDictCreate(args, metaArgs) If NOT IsBagDict(args) Then Set args = BagDictMake(args, metaArgs) End If End Sub '------------------------------------------------------------------------------- ' Function: IsBagDict ' ' Returns true if the passed item is a bag dict ' ' Parameters: ' - args - the item to be checked ' ' Returns: ' True if is a bag dict, else False ' ' Usage: ' If NOT IsBagDict(args) Then ' ... ' '------------------------------------------------------------------------------- Function IsBagDict(args) IsBagDict = False If IsObject(args) Then IsBagDict = (args.Item("self.is_bag_dict") = True) End If End Function '------------------------------------------------------------------------------- ' Function: BagClassMake ' ' Creates a bag class on top of a bag dict. Might be used to hack up a class ' (Was used that way during debugging) ' ' Parameters: ' - nameToUse - the name for the new class. Typically the same name as the variable ' the class is stored in. See usage information for additional information ' - args - DictMake compatible arguments to be added to the dictionary ' ' Returns: ' A Bag Class object ' ' Usage: ' Dim itemToMakeIntoClass ' Set itemToMakeIntoClass = BagClassMake("classFile",null,"self.is_virtual=>False") ' '------------------------------------------------------------------------------- Function BagClassMake (nameToUse, args, metaArgs) Set BagClassMake = BagDictMake(NULL) Set BagClassMake = BagClassMake.MakeClass (nameToUse, args, metaArgs) End Function '============================================================================================================ ' OBJECT MODEL DICTIONARY EXTENSION - VBScript++.vbs '============================================================================================================ '------------------------------------------------------------------------------- ' Class: BagDict ' ' This class serves two purposes, and since VBScript doesn't allow inheritence, ' these two tightly related functions are implemented in one class. You can however ' use one without the other. ' ' Use 1: Add functionality to the Dictionary object. Does things like check to see ' if an item exists before calling Dictionary.Add that should have been built in. ' A whole host of dictionary extensions are implemented this way. See below for specifics. ' This is done by implementing a class which contains a dictionary, and then creating ' "pass through" calls for each piece of Dictionary functionality. These calls are ' modififed as needed to support the changed functionality (for instance, referencing ' any key (even if it does not exist, such as in If IsEmpty(myDict("foo")) Then...) ' causes the dictionary object to create that key. In this implementation, referencing ' a non existant key does not create it. This also implements things like ItemIndex and ' KeyIndex which allow you to reference an item in the item or key arrays by it's index ' number. Detailed documentation is implemented below. ' ' Use 2: Creates a new kind of "object". Since languages like C++ implement objects ' with inheritence and polymorphism, and VBScript does not, and since C++ implements ' it's objects as data structures with "hidden fields" (function pointers to ' method calls and such), I decided to mash those ideas together and implement ' them in VBScript. Dictionary keys prefixed with "method." refer to method calls. ' Property keys are prefixed by "prop." objectMetadata is prefixed with "self." ' ' Properties and methods which are defined to go with the class are defined and ' implemented as follows ' (start example) ' ' this defines the container for the "new bag class" ' Dim classFile ' ' ' this uses the classFileSystemItem bag class object to create a new bag class object ' Set classFile = classFileSystemItem.MakeClass("classFile","self.is_virtual=>False") ' ' ' then we apply a property to the class object: ' classFile.ApplyProp "Exist","get","return_type=>Boolean" ' ' ' and finally we define the code to be called. It is by default named ' ' in the form: classname_propertyname_direction and ALWAYS takes 2 arguemnts: self and args ' Function ClassFile_Exist_Get(self,args) ' ClassFile_Exist_Get = ClassFileSystemItem_FSO.FileExists(self("file_name")) ' End Function ' ' ' creating an instance then looks like this: ' Set myFile = classFile.NewObject ("file_name=>c:\foo.txt", NULL) ' ' ' calling a property then looks like this: ' myResult = myFile.Prop ("Exist", NULL) ' (end example) ' ' The use of DictMake arguments (see Sub DictMake elsewhere) then allows us ' to implement a simple form of polymorphism using conditionals within the ' called routine. ' ' Items implemented using this approach are called Bag Classes or Bag Objects. ' They're both BagDict objects, with different objectMetadata. ' ' The dictionary passthrough code was stolen from Tarun Lalwani, published at: ' http://knowledgeinbox.com/articles/vbscript/extending-dictionary-object/ ' ' IMPORTANT: ' Please note that all keys are lower case. Usually in the form component.word_word_word ' component can refer to any grouping of attributes. In this example: self.foo_bar ' self is the component. For *variable names* using our coding standards, the ' local identifier within the component would be fooBar, but because of the all ' lower case rule, foo_bar is used instead. ' ' All of the classes and instances worked with using this code are intended to be ' dictionaries carrying data conforming to the bag_object model: ' ' key:self.is_bag_object - required for all ' ' key:self.class_name - string: name of the class of self ' key:self.inherits_from - bag_object class ' key:self.inheritence_list - dict: who else does this class inherit from? (grandparents) ' key:self.is_instance - boolean: is this an instance? ' key:self.is_virtual - boolean: is this a virutal class? (in the C++ sense) ' ' key:method. - string: function pointer to a method (subroutine, does not return a value) ' key:prop. - string: function pointer to a property (function, does return a value) ' key:prop..return_type - string: the return type (boolean, string, array, etc) ' key:class. - any type: items shared across members of a class (TBD: NOT YET IMPLEMENTED) ' key:private. - any type: private to this class (TBD: NOT YET IMPLEMENTED) ' key:protected. - any type: protected data (TBD: NOT YET IMPLEMENTED) ' ' key:method.constructor - string: special purpose method, called during ObjCreate ' key:method.destructor - string: special purpose method, called during ObjDestroy ' ' key:self.is_hacked - boolean: special flag that indicates this dict didn't start life as a bag_object ' '------------------------------------------------------------------------------- Class BagDict '============================================================================================================ Public objectMetadata Public localData Private localFSO '------------------------------------------------------------------------------- ' Method: Class_Initialize ' ' Initializes instance. Sets up local data, sets modes on contained dicts. ' Intialize event gets executed whenever a object is created ' ' Parameters: ' - None ' ' Returns: ' - No return value ' ' Usage: ' Called automatically, not called by programmer ' '------------------------------------------------------------------------------- Sub Class_Initialize() Set localFSO = CreateObject("Scripting.FileSystemObject") Set objectMetadata = CreateObject("Scripting.Dictionary") Set localData = CreateObject("Scripting.Dictionary") objectMetadata.CompareMode = vbTextCompare localData.CompareMode = vbTextCompare End Sub '------------------------------------------------------------------------------- ' Method: Class_Terminate ' ' Clears the data from the instance in preperation for destruction. ' Executed when the object is destroyed ' ' Parameters: ' - None ' ' Returns: ' - No return value ' ' Usage: ' Called automatically, not called by programmer ' '------------------------------------------------------------------------------- Sub Class_Terminate() 'call destructor If objectMetadata("self.is_instance") = True Then me.Method "Destroy", NULL End If 'Remove all the keys objectMetadata.RemoveAll localData.RemoveAll 'Destroy the dictionaries Set objectMetadata = Nothing Set localData = Nothing End Sub '============================================================================================================ ' EXTENSIONS TO FUNCTIONALITY BY AKIEN WHICH I WISH ALL DICTS HAD '============================================================================================================ '------------------------------------------------------------------------------- ' Property: ItemIndex ' ' This gets around the inability to do dict.Items(n) (which should have been allowed ' but which the dictionary object tries to treat as a key reference rather than an ' index into the Items array) ' ' Parameters: ' - indexIntoArray - the index into the array of items ' - value - item passed into Let/Set ' ' Returns: ' - (Get) Whatever is storied at that item, or Empty if not found ' ' Exceptions: ' - Will trigger an out of range error if you try to access something past the ' end of the array ' ' Usage: ' n = myDict.ItemIndex(2) ' ' Notes: ' Only interacts with local data, not metadata ' '------------------------------------------------------------------------------- Public Property Get ItemIndex(indexIntoArray) Assign ItemIndex, localData.Item(me.KeyIndex(indexIntoArray)) End Property Public Property Let ItemIndex(indexKey, Value) Dim keyToUse Assign keyToUse, me.KeyIndex(indexKey) Assign localData(keyToUse), Value End Property Public Property Set ItemIndex(indexKey, Value) Dim keyToUse Assign keyToUse, me.KeyIndex(indexKey) Assign localData(keyToUse), Value End Property '------------------------------------------------------------------------------- ' Property: KeyIndex ' ' This gets around the inability to do dict.Keys(n) (which should have been allowed ' but which the dictionary object tries to treat as a key reference rather than an ' index into the key array) ' ' Parameters: ' - indexIntoArray - the index into the array of items ' ' Returns: ' - (Get) Whatever is storied at that item, or Empty if not found ' ' Exceptions: ' - Will trigger an out of range error if you try to access something past the ' end of the array ' ' Usage: ' n = myDict.KeyIndex(2) ' ' Notes: ' Only interacts with local data, not metadata ' '------------------------------------------------------------------------------- Public Property Get KeyIndex(indexIntoKeyArray) Dim theKeys theKeys = localData.Keys Dim resolvedIndex resolvedIndex = ResolveIndex(indexIntoKeyArray) Assign KeyIndex, theKeys(resolvedIndex) End Property '------------------------------------------------------------------------------- ' Method: ResolveIndex (Private) ' ' Allows you to specify indicies that are negative, in order to fetch last or ' items counted from the end. e.g. -1 = the last entry in the list, -2 = second to last ' and so on. ' ' Parameters: ' - oldIndex - the number we start with, positives are returned unchanged ' ' Returns: ' - the resolved index ' ' Usage: ' newIndex = me.ResolveIndex(oldIndex) ' '------------------------------------------------------------------------------- Private Function ResolveIndex(oldIndex) If oldIndex < 0 Then oldIndex = (localData.Count - 1) + (oldIndex + 1) End If ResolveIndex = oldIndex End Function '------------------------------------------------------------------------------- ' Property: SetIfUndefined ' ' Will push the value into the dict if a value with that key does not already exist ' ' Parameters: ' - keyToUse - the key (not the keyindex) to check for ' - value - the value to set if the key does not already exist ' ' Returns: ' - No return value ' ' Usage: ' myObject.SetIfUndefined("foo") = "bar" ' ' Notes: ' Only interacts with local data, not metadata ' '------------------------------------------------------------------------------- Public Property Let SetIfUndefined(keyToUse, Value) If NOT localData.Exists(keyToUse) Then If IsObject(Value) Then Set localData(keyToUse) = Value Else localData(keyToUse) = Value End If End If End Property Public Property Set SetIfUndefined(keyToUse, Value) If IsObject(Value) Then Set localData(keyToUse) = Value Else localData(keyToUse) = Value End If End Property '------------------------------------------------------------------------------- ' Method: MakeBag ' ' Createes a new bag, and performs a shallow copy of the content of args onto it ' ' Parameters: ' - args - DictMake compatible arguments to be added to the resulting bag dict ' - metaArgs - DictMake compatible metadata arguments to be added to the resulting bag dict ' (may be null) ' ' Returns: ' - a bag dict with the contents of args added to it ' ' Usage: ' Set myNewDict = MakeBag("this_key_gets=>This Value", NULL) ' '------------------------------------------------------------------------------- Function MakeBag (args, metaArgs) Set MakeBag = BagDictMake(args, metaArgs) End Function '------------------------------------------------------------------------------- ' Sub: MakeIntoBagDict ' ' Used to make a set of args into a bag dict. Very much a Bag Dict centric ' version of DictMake ' ' Parameters (required): ' - args - DictMake compatible arguments to be rendered as a bag dict ' - metaArgs - DictMake compatible metadata arguments to be added to the resulting bag dict ' (may be null) ' ' Returns: ' - args as a new bag dict (unless the item is already a bag dict) ' ' Usage: ' Sub foo(args) ' me.MakeBag(args, NULL) ' myItem = args("my_item") ' ' Notes: ' This is intended to be used within the class as a Bag Dict version of DictMake ' '------------------------------------------------------------------------------- Sub MakeIntoBagDict(args, metaArgs) If NOT IsBagDict(args) Then Set args = BagDictMake(args, metaArgs) Else If NOT IsNull(metaArgs) Then args.ApplyMetaData(metaArgs) End If End If End Sub '------------------------------------------------------------------------------- ' Method: Withdraw ' ' Removes a key and returns it's value. Used where you might be passed multiple ' sub items you wish to take action with, then remove from the dict, usually because ' the last action will be to merge that dict into another dict. ' ' Parameters: ' - keyToUse - the key to attept to fetch a value for ' ' Returns: ' - Either Empty or whatever was found for that key ' ' Usage: ' myData = myDict.Withdraw("foo") ' newDict.Merge(myDict) ' ' Notes: ' Only interacts with local data, not metadata ' '------------------------------------------------------------------------------- ' this returns the value and removes it from the dict... sort of "uses it up" Function Withdraw(keyToUse) Withdraw = Empty If localData.Exists (keyToUse) Then If IsObject(localData(keyToUse)) Then Set Withdraw = objectMetadata(keyToUse) Else Withdraw = localData(keyToUse) End If localData.Remove keyToUse End If End Function '------------------------------------------------------------------------------- ' Method: GetKeyOrItem ' ' Returns either the value stored in the specified key, or if that key does not ' exist, and key:item does, use the value stored in key:item. If neither exists ' return nothing. ' ' Parameters: ' - keyToFetch - string, the name of the key to check for ' ' Returns: ' - See description ' ' Usage: ' Assign x, myDict.GetKeyOrItem("foo") ' '------------------------------------------------------------------------------- Function GetKeyOrItem(keyToFetch) If me.Exist("item") Then assign GetKeyOrItem, me("item") End If If me.Exist(keyToFetch) Then assign GetKeyOrItem, me(keyToFetch) End If End Function '------------------------------------------------------------------------------- ' Method: HasKeys ' ' Returns T/F based on whether a bag dict contains all the keys specified. This ' is used to pre check the existance of keys before the code starts trying to ' use them. ' ' Parameters: ' - arrayOfKeysToCheckFor - can be either an array or a single key to check for ' ' Returns: ' - T/F based on whether ALL the keys were found ' ' Usage: ' If NOT myDict.HasKeys("a","b","c") Then ' ' report error here ' ' Notes: ' Checks localData AND objectMetadata ' '------------------------------------------------------------------------------- Function HasKeys(arrayOfKeysToCheckFor) Dim result, i result = True If NOT IsArray(arrayOfKeysToCheckFor) Then arrayOfKeysToCheckFor = Array(arrayOfKeysToCheckFor) End If For i = 0 to UBound(arrayOfKeysToCheckFor) If (localData.Exists(arrayOfKeysToCheckFor(i)) OR objectMetadata.Exists(arrayOfKeysToCheckFor(i))) = False Then result = False Exit For End If Next HasKeys = result End Function '------------------------------------------------------------------------------- ' Method: VerifyHasKeys ' ' If not all keys found, raises an error. Reports class, missing keys, and ' a passed failure message. This allows us to have a single line to verify ' that a routine has the data it needs. ' ' Parameters: ' - arrayOfKeysToCheckFor - can be either an array or a single key to check for ' - failuremessage - message to post in the event of a failure ' ' Returns: ' - No return value ' ' Usage: ' Sub Foo(args) ' me.VerifyHasKeys Array("a","b","c"), "Failed" ' ' Notes: ' Resulting message: FATAL: bag object of type classBase found to be missing needed keys. " & failuremessage ' ' Checks localdata and objectMetadata ' '------------------------------------------------------------------------------- Sub VerifyHasKeys(arrayOfKeysToCheckFor, failuremessage) If NOT me.HasKeys(arrayOfKeysToCheckFor) Then Err.Raise 1,"", "TBD:FATAL: bag object of type " & objectMetadata("self.class_name") & " found to be missing needed keys. " & failuremessage End If End Sub '------------------------------------------------------------------------------- ' Method: CopyTo ' ' Copies keys to a target dictionary or bag dict ' shallow copies the keys/values to another dict ' ' Parameters (required): ' - targetdict - the target dictionary/bag dict to copy to ' ' Parameters (allowed): ' - args key:keys_to_copy - array with the list of keys to copy ' ' Returns: ' - No return value ' ' Usage: ' myDict.CopyTo otherDict, NULL ' myDict.CopyTo otherDict, Array("keys_to_copy",Array("foo","bar")) ' ' Notes: ' Performs a shallow copy. Object references will remain references to the ' same objects ' ' Does NOT copy objectMetadata ' '------------------------------------------------------------------------------- Sub CopyTo(byref targetDict, args) me.CopyKeys localData, targetDict, args End Sub '------------------------------------------------------------------------------- ' Method: CopyFrom ' ' Copies keys from another dictionary or bag dict to this one ' shallow copies the keys/values from another dict ' Parameters (required): ' - sourceDict - the dictionary to copy from ' ' Parameters (allowed): ' - args key:keys_to_copy - array with the list of keys to copy ' ' Returns: ' - No return value ' ' Usage: ' myDict.CopyFrom otherDict, NULL ' myDict.CopyFrom otherDict, Array("keys_to_copy",Array("foo","bar")) ' ' Notes: ' Performs a shallow copy. Object references will remain references to the ' same objects ' ' Does NOT copy objectMetadata '------------------------------------------------------------------------------- Sub CopyFrom (byref sourceDict, args) CopyKeys targetDict, localData, args End Sub '------------------------------------------------------------------------------- ' Method: CopyKeys ' ' Called by the other copy code. shallow copies keys from one dict to another ' ' Parameters: ' - fromDict - dictionary or bag dict to copy from ' - toDict - dictionary or bag dict to copy to ' - args - arguments that may effect the copy. As of this writing, the ' only one that is used is args key:keys_to_copy ' ' Returns: ' - No return value ' ' Usage: ' myDict.CopyKeys dictToCopyFrom, dictToCopyTo, NULL ' myDict.CopyKeys dictToCopyFrom, dictToCopyTo, Array("keys_to_copy",Array("foo","bar")) ' myDict.CopyKeys myDict.objectMetaData, newDict.objectMetaData, NULL <-- use this to copy metadata ' myDict.CopyKeys myDict.objectMetaData, newDict.objectMetaData, Array("keys_to_copy",Array("self.is_instance","self.is_nusance")) ' ' Notes: ' Does NOT copy objectMetadata by default ' '------------------------------------------------------------------------------- Sub CopyKeys(fromDict, toDict, args) If NOT IsNull(fromDict) AND NOT IsEmpty(fromDict) Then On Error Resume Next Set fromDict = fromDict.localData Set toDict = toDict.localData On Error Goto 0 DictCopy fromDict, toDict, args End If End Sub '------------------------------------------------------------------------------- ' Method: RenderAsArray ' ' Returns the contents of this dictionary as an array in the DictMake form: ' Array("key1","value1","key2","value2") ' ' Parameters: ' - None ' ' Returns: ' - DictMake compatible array in the form: Array("key1","value1","key2","value2"...) ' ' Usage: ' MyArray = myObject.RenderAsArray() ' ' Notes: ' Does NOT include objectMetadata ' '------------------------------------------------------------------------------- Function RenderAsArray() ' returns Array("key1","value1") type result Dim result ' BREAKPOINT HERE! Set result = BagDictMake(NULL,NULL) Dim i For i = 0 to me.Count-1 result("K" & i) = me.KeyIndex(i) result("I" & i) = me.ItemIndex(i) Next RenderAsArray = result.Items End Function '------------------------------------------------------------------------------- ' Method: RenderAsString ' ' Returns the contents of this dictionary as string in the DictMake form: ' "key1=>value1|key2=>value2" ' ' Parameters: ' - None ' ' Returns: ' - DictMake compatible string in the form "key1=>value1|key2=>value2" ' ' Usage: ' print "The dictionary contains " & myDict.RenderAsString() ' ' Notes: ' Does NOT include objectMetadata ' '------------------------------------------------------------------------------- Function RenderAsString() ' returns "key1=>value1|key2=>value2" type result Dim theArray, result, i theArray = me.RenderAsArray() result = "" For i = 0 to UBound(theArray) Step 2 result = result & CString(theArray(i)) & "=>" & CString(theArray(i+1)) & "|" Next If Len(result) > 0 Then result = Mid(result,1,Len(result)-1) End If RenderAsString = result End Function '------------------------------------------------------------------------------- ' Method: RenderAsArrayOfString ' ' Returns the contents of this dictionary as an array of strings in the form: ' Array("key1=>value1","key2=>value2"...) - intended use is for debugging, for ' examining dictionary contents in real time. An object inspector, if you will. ' ' Parameters: ' - None ' ' Returns: ' - an array of string in the form Array("key1=>value1","key2=>value2"...) ' ' Usage: ' Place in the variable/expression watch window: myDict.RenderAsArrayOfString() ' ' Notes: ' THIS ROUTINE RETURNS BOTH OBJECT METADATA AND LOCAL DATA!! THIS IS NOT TYPICAL ' OF THE REST OF THIS LIBRARY, AND IS IMPLEMENTED THIS WAY BECAUSE THIS IS ' INTENDED AS A DEBUGGING TOOL ' ' ITEM KEYS WILL BE PREFACED WITH M: or O: TO INDICATE WHETHER AN ITEM IS ' METADATA OR OBJECT DATA ' '------------------------------------------------------------------------------- Function RenderCompleteObjectAsArrayOfString() 'RenderAsArrayOfString = CArrayOfStringFromDict(objectMetadata) Dim result, i, theKeys, theValues Set result = CreateObject("Scripting.Dictionary") theKeys = objectMetadata.Keys theValues = objectMetadata.Items For i = 0 to UBound(theKeys) result( "M:" & theKeys(i) & "=>" & CString(theValues(i)) ) = True Next theKeys = localData.Keys theValues = localData.Items For i = 0 to UBound(theKeys) result( "O:" & theKeys(i) & "=>" & CString(theValues(i)) ) = True Next RenderCompleteObjectAsArrayOfString = result.Keys End Function '------------------------------------------------------------------------------- ' Method: Debug ' ' Shortcut for RenderCompleteObjectAsArrayOfString, used in debugging ' The reason for the shortcut is typing the full name into the debugger was ' slowing us down too much ' '------------------------------------------------------------------------------- Function Debug() Debug = RenderCompleteObjectAsArrayOfString() End Function '------------------------------------------------------------------------------- ' Method: RenderCompleteObjectAsString ' ' Returns the contents of this dictionary as string in the form: ' "key1=>value1|key2=>value2". Intended use is for debugging, for ' examining dictionary contents in real time. An object inspector, if you will. ' ' Parameters: ' - None ' ' Returns: ' - a string in the form "key1=>value1|key2=>value2" ' ' Usage: ' Place in the variable/expression watch window: myDict.RenderCompleteObjectAsString() ' ' Notes: ' THIS ROUTINE RETURNS BOTH OBJECT METADATA AND LOCAL DATA!! THIS IS NOT TYPICAL ' OF THE REST OF THIS LIBRARY, AND IS IMPLEMENTED THIS WAY BECAUSE THIS IS ' INTENDED AS A DEBUGGING TOOL ' ' ITEM KEYS WILL BE PREFACED WITH M: or O: TO INDICATE WHETHER AN ITEM IS ' METADATA OR OBJECT DATA ' '------------------------------------------------------------------------------- Function RenderCompleteObjectAsString() Dim result, i, theKeys, theValues Set result = CreateObject("Scripting.Dictionary") theKeys = objectMetadata.Keys theValues = objectMetadata.Items For i = 0 to UBound(theKeys) result = result & "M:" & CString(theKeys(i)) & "=>" & CString(theValues(i)) & "|" Next theKeys = localData.Keys theValues = localData.Items For i = 0 to UBound(theKeys) result = result & "O:" & CString(theKeys(i)) & "=>" & CString(theValues(i)) & "|" Next RenderCompleteObjectAsString = Mid(result,1,Len(result)-1) End Function '============================================================================================================ ' OBJECT IMPLEMENTATION ON TOP OF THE DICT AND EXTENSIONS '============================================================================================================ '------------------------------------------------------------------------------- ' Method: MakeClass ' ' Used to build a new bag_object class from an existing one. ' ' Parameters: ' - nameToUse - the name for the new class. In practice, usually the same name ' that's given to the global containing object. ' - args - DictMake compatible arguments which will be copied to the new object ' - metaArgs - DictMake compatible arguments which will be copied to the new object's metadata ' ' Returns: ' - a Bag Class object which inherits from the called object ' ' Exceptions: ' - Fatal if the called object is not a bag class ' ' Usage: ' Dim classNew ' Set classNew = classBase.MakeClass "classNew", "self.is_virtual=False" ' '------------------------------------------------------------------------------- Function MakeClass (nameToUse, args, metaArgs) ' verify the right kinds of thingies If NOT objectMetadata("self.is_bag_object") = True Then Err.Raise 1, "", "TBD: FATAL: specified objecct to inherit from is not a bag_object class" End If If objectMetadata("self.is_instance") = True Then Err.Raise 1, "", "TBD: FATAL: specified objecct to inherit from is not a bag_object class" End If ' set up Dim newClassToCreate 'Set args = me.MakeBag(args, metaArgs) ' make the new one Set newClassToCreate = me.MakeBag(NULL, NULL) newClassToCreate.ApplyKeys localData newClassToCreate.ApplyMetadata objectMetadata newClassToCreate.objectMetadata("self.is_bag_object") = True ' put the new name in (overwrites the old one) newClassToCreate.objectMetaData("self.class_name") = nameToUse ' and inheritence Set newClassToCreate.objectMetaData("self.inherits_from") = me Set newClassToCreate.objectMetaData("self.inheritence_list") = MakeBag (NULL, NULL) ' objectMetadata("self.inheritence_list") ' we can't just copy the whole object, because then we'd just have aa pointer to the same object ' so instead we have to do a deeper copy, key by key. If objectMetaData.Exists("self.inheritence_list") Then If NOT IsEmpty(objectMetaData("self.inheritence_list")) Then If objectMetaData("self.inheritence_list").Count > 0 Then objectMetaData("self.inheritence_list").CopyTo newClassToCreate.objectMetaData("self.inheritence_list"), NULL End If End If End If newClassToCreate.objectMetaData("self.inheritence_list")(me) = True newClassToCreate.objectMetaData("self.inheritence_list")(objectMetadata("self.class_name")) = True ' and copy anything else into the new object newClassToCreate.ApplyKeys args newClassToCreate.ApplyMetaData metaArgs Set MakeClass = newClassToCreate End Function '------------------------------------------------------------------------------- ' Method: NewObject ' ' Makes an instance of a bag class ' ' Parameters: ' - args - DictMake compatible input, not required (can be NULL) items passed ' in are simply added to the object ' - metaArgs - DictMake compatible arguments which will be copied to the new object's metadata ' ' Returns: ' - a new bag dict instance of the class ' ' Exceptions: ' - Fatal if this isn't a bag class object ' ' Usage: ' Dim myInstance ' Set myInstance = myClass.NewObject, NULL ' '------------------------------------------------------------------------------- Function NewObject (args, metaArgs) ' verify the right kinds of thingies If NOT objectMetadata("self.is_bag_object") = True Then Err.Raise 1, "", "TBD: FATAL: specified objecct to inherit from is not a bag_object class" End If If objectMetadata("self.is_instance") = True Then Err.Raise 1, "", "TBD: FATAL: specified objecct to inherit from is not a bag_object class" End If If objectMetadata("self.is_virtual") Then Err.Raise 1, "", "FATAL: CANNOT INSTANTIATE VIRTUAL CLASS" End If Dim theNewObject Set theNewObject = me.MakeBag(NULL, NULL) theNewObject.ApplyKeys me.localData theNewObject.ApplyMetadata me.objectMetadata 'Set args = me.MakeBag(args, NULL) theNewObject.ApplyKeys args theNewObject.objectMetadata("self.is_instance") = True If theNewObject.objectMetadata.Exists("method.constructor") Then theNewObject.Method "Constructor", args End If Set NewObject = theNewObject End Function '------------------------------------------------------------------------------- ' Method: ApplyKeys ' ' Applies the keys passed to the contained dictionary, without regard to whether ' those keys already exist ' ' Parameters (required): ' - args - DictMake compatible arguments to be applied ' ' Returns: ' - No return value ' ' Usage: ' newThing.ApplyKeys(oldThing) ' '------------------------------------------------------------------------------- Sub ApplyKeys (args) CopyKeys args, localData, null End Sub '------------------------------------------------------------------------------- ' Method: ApplyMetaData ' ' Applies the keys passed to the objectMetadata dictionary, without regard to whether ' those keys already exist ' ' Parameters (required): ' - args - DictMake compatible arguments to be applied ' ' Returns: ' - No return value ' ' Usage: ' newThing.ApplyKeys(oldThing) ' '------------------------------------------------------------------------------- Sub ApplyMetaData (args) CopyKeys args, objectMetadata, null End Sub '------------------------------------------------------------------------------- ' Method: IsOfClass ' ' Returns True if this is a bag object of the specified class ' ' Parameters: ' - classToCheck - can be class object or string name ' ' Returns: ' - True/False is me inherits from the specified class at any point in it's ' ancestry ' ' Usage: ' myVar = myDict.IsOfClass(classBase) ' ' Notes: ' '------------------------------------------------------------------------------- Function IsOfClass(classToCheck) IsOfClass = False ' verify the right kinds of thingies If objectMetadata("self.is_bag_object") = True Then IsOfClass = (objectMetadata("self.inheritence_list").Item(classToCheck) = True) ' comparison results in a t/f result End If End Function '------------------------------------------------------------------------------- ' Method: ApplyMethod ' ' Used to apply a method to the object. Method keys always start with "method." ' and the value is the string name of the subroutine to call ' ' Parameters (required): ' - nameToUse - the name of the method (will be made lower case before ' applying to the key) ' ' Parameters (allowed): ' - args key:vector - string: full name of the subroutine to call. if not ' provided, one is created (see below) ' - args key:required_keys - string of one or more required keys, comma seperated if ' more than one. IMPORTANT: SEE NOTES BEFORE USING!!! ' ' any other specified keys will be applied to the OBJECT METADATA after the keys for ' this property are created ' ' Returns: ' - No return value ' ' Exceptions: ' - Fatal if not a bag object ' ' Usage: ' MyClass.ApplyMethod "MethodName", NULL ' MyClass.ApplyMethod "MethodName", "vector=>FunctionNameIWantToCall" ' (See also notes section below) ' ' Notes: ' Method keys in the form "method." and default vectors (if none provided) ' are in the form _ ' ' IMPORTANT NOTE ON required_keys READ BEFORE USING: if you send in the key ' required_keys, it will create a "custom signature vector". When the Method() entry point ' is called, the provided keys will be evaluated against the required_keys list ' and if there's a match, the matching vector will be called. This creates a real ' form of polymorphism. So you can do this: ' ' myClass.ApplyMethod "Create", "required_keys=>company_name|vector=>MyClass_Create_Company" ' myClass.ApplyMethod "Create", "required_keys=>last_name|vector=>MyClass_Create_Person" ' ' And when you do a method call, the provided keys will be evaluated against the required ' keys lists and the appropriate vector will be called. If no match is made, and a ' default vector exists, then the default vector will be called. One facility this creates ' is the ability to use the default vector to handle errors. ' ' IT IS RECCOMENDED THAT YOU ALWAYS EXPLICITLY SPECIFY THE VECTOR FOR METHODS ' VECTORED TO BASED ON CUSTOM KEYS. If you don't do this, a new vector will be ' automatically generated, based on the number of custom vectors already existing. ' The custom vector will be in the form: ' ClassName_method__Custom_ ' '------------------------------------------------------------------------------- Sub ApplyMethod (nameToUse, args) VectorSet "method", "", nameToUse, args End Sub '------------------------------------------------------------------------------- ' Method: Method ' ' calls a method (a function associated with a bag_class object) ' ' Parameters (required): ' - nameToUse - string name of the method to call ' - args - DictMake compatible input (can be NULL) ' ' Returns: ' - whatever return value the called method returns ' ' Usage: ' not caring about return value: myObject.Method "MethodToCall", NULL ' capturing non object return: foo = myObject.Method("MethodToCall", "key_to_pass_to_method_code=>foo") ' capturing object return value: Set foo = myObject.Method("MethodToCall", Array("key_to_pass_to_method_code",foo)) ' '------------------------------------------------------------------------------- Function Method(nameToUse, args) Method = NULL BagDictCreate args, NULL If NOT (objectMetadata("self.is_instance") = True) Then Err.Raise 1, "", "TBD: FATAL: CANNOT CALL INTO AN ITEM WHICH IS NOT AN INSTANCE" End If Dim vector, stringCommand, evalResult vector = VectorGet("method", "", nameToUse, args) If vector = "" Then Err.Raise 1, "", "TBD: FATAL: METHOD " & nameToUse & " IS NOT DEFINED" End If stringCommand = vector & " (me, args)" evalResult = VectorCall(stringCommand, args) ' returns an array of 1 element If NOT (IsNull(evalResult) OR IsEmpty(evalResult)) Then If IsObject(evalResult(0)) Then Set Method = evalResult(0) Else Method = evalResult(0) End If End If End Function '------------------------------------------------------------------------------- ' Method: ApplyProp ' ' Used to apply a property to the object. Property keys always start with "prop__" ' and the value is the string name of the function to call ' ' Parameters (required): ' - nameToUse - the name of the property (will be made lower case before ' applying to the key) ' - direction - the string "set", "let", or "get" - the type of function to call ' - args - anything else, DictMake compatible input (can be NULL) ' ' Parameters (allowed in args): ' - args key:vector - string: full name of the function to call. if not ' provided, one is created (see below) ' - args key:return_type - string: indicates the type of data this call returns ' - args key:required_keys - string of one or more required keys, comma seperated if ' more than one. IMPORTANT: SEE NOTES BEFORE USING!!! ' ' any other specified keys will be applied to the OBJECT METADATA after the keys for ' this property are created ' ' Returns: ' - No return value ' ' Exceptions: ' - Fatal if not a bag object ' ' Usage: ' MyClass.ApplyProp "PropertyName", "get", NULL ' MyClass.ApplyProp "PropertyName", "get", "return_type=>string" ' MyClass.ApplyProp "PropertyName", "get", "vector=>FunctionNameIWantToCall" ' MyClass.ApplyProp "PropertyName", "get", "vector=>FunctionNameIWantToCall|return_type=>String" ' ' Notes: ' Prop keys are stored in the form "prop._" and default vectors (if none provided) ' are in the form