Quellcode-Bibliothek SF_Dictionary.xba   Sprache: unbekannt

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="SF_Dictionary" script:language="StarBasic" script:moduleType="normal">REM =======================================================================================================================
REM ===   The ScriptForge library and its associated libraries are part of the LibreOffice project.    ===
REM ===     Full documentation is available on https://help.libreoffice.org/        ===
REM =======================================================================================================================

Option Compatible
Option ClassModule

Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' SF_Dictionary
''' =============
'''  Class for management of dictionaries
'''  A dictionary is a collection of key-item pairs
'''   The key is either a case-sensitive or a not case-sensitive string
'''   Items may be of any type
'''  Keys, items can be retrieved, counted, etc.
'''
'''  The implementation is based on 3 one-column arrays:
'''  1) The keys - sorted
'''  2) The positions in 3) - same sequence as 1)
'''  3) The item contents - stacked up when defined - erased items are set to Empty
'''
'''  Why a Dictionary class beside the builtin Collection class ?
'''   A standard Basic collection does not support the retrieval of the keys
'''   A standard Basic collection does not support the update/removal of entries
'''   No easy conversion to/from json or PropertyValues
'''
'''  Service instantiation example:
'''   Dim myDict As Variant
'''   myDict = CreateScriptService("Dictionary", True)  ' Case-sensitive, default = False
'''
'''  Detailed user documentation:
'''   https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_dictionary.html?DbPAR=BASIC
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

REM ================================================================== EXCEPTIONS

Const DUPLICATEKEYERROR   = "DUPLICATEKEYERROR"  ' Key exists already
Const UNKNOWNKEYERROR   = "UNKNOWNKEYERROR"  ' Key not found
Const INVALIDKEYERROR   = "INVALIDKEYERROR"  ' Key contains only spaces

REM ============================================================= PRIVATE MEMBERS

Private [Me]    As Object
Private [_Parent]   As Object
Private ObjectType   As String  ' Must be "DICTIONARY"
Private ServiceName   As String
Private CaseSensitive  As Boolean  ' Determined at dictionary creation, default = False
Private MapKeys    As Variant  ' Array of keys
Private MapPositions  As Variant  ' Array of indexes in MapItems, sorted as MapKeys
Private MapItems   As Variant  ' Array of ItemMaps
Private _MapSize   As Long   ' Total number of entries in the dictionary
Private _MapRemoved   As Long   ' Number of inactive entries in the dictionary

REM ===================================================== CONSTRUCTOR/DESTRUCTOR

REM -----------------------------------------------------------------------------
Private Sub Class_Initialize()
 Set [Me] = Nothing
 Set [_Parent] = Nothing
 ObjectType = "DICTIONARY"
 ServiceName = "ScriptForge.Dictionary"
 CaseSensitive = False
 MapKeys = Array()
 MapPositions = Array()
 MapItems = Array()
 _MapSize = 0
 _MapRemoved = 0
End Sub  ' ScriptForge.SF_Dictionary Constructor

REM -----------------------------------------------------------------------------
Private Sub Class_Terminate()
 Call Class_Initialize()
End Sub  ' ScriptForge.SF_Dictionary Destructor

REM -----------------------------------------------------------------------------
Public Function Dispose() As Variant
 RemoveAll()
 Set Dispose = Nothing
End Function ' ScriptForge.SF_Dictionary Explicit destructor

REM ================================================================== PROPERTIES

REM -----------------------------------------------------------------------------
Property Get Count() As Long
''' Actual number of entries in the dictionary
''' Example:
'''  myDict.Count

 Count = _PropertyGet("Count")

End Property ' ScriptForge.SF_Dictionary.Count

REM -----------------------------------------------------------------------------
Public Function Item(Optional ByVal Key As Variant) As Variant
''' Return the value of the item related to Key
''' Args:
'''  Key: the key value (string)
''' Returns:
'''  Empty if not found, otherwise the found value
''' Example:
'''  myDict.Item("ThisKey")
''' NB: defined as a function to not disrupt the Basic IDE debugger

 Item = _PropertyGet("Item", Key)

End Function ' ScriptForge.SF_Dictionary.Item

REM -----------------------------------------------------------------------------
Property Get Items() as Variant
''' Return the list of Items as a 1D array
''' The Items and Keys properties return their respective contents in the same order
'''  The order is however not necessarily identical to the creation sequence
''' Returns:
'''  The array is empty if the dictionary is empty
''' Examples
'''  a = myDict.Items
'''  For Each b In a ...

 Items = _PropertyGet("Items")

End Property ' ScriptForge.SF_Dictionary.Items

REM -----------------------------------------------------------------------------
Property Get Keys() as Variant
''' Return the list of keys as a 1D array
''' The Keys and Items properties return their respective contents in the same order
'''  The order is however not necessarily identical to the creation sequence
''' Returns:
'''  The array is empty if the dictionary is empty
''' Examples
'''  a = myDict.Keys
'''  For each b In a ...

 Keys = _PropertyGet("Keys")

End Property ' ScriptForge.SF_Dictionary.Keys

REM ===================================================================== METHODS

REM -----------------------------------------------------------------------------
Public Function Add(Optional ByVal Key As Variant _
      , Optional ByVal Item As Variant _
      ) As Boolean
''' Add a new key-item pair into the dictionary
''' Args:
'''  Key: must not yet exist in the dictionary
'''  Item: any value, including an array, a Basic object, a UNO object, ...
''' Returns: True if successful
''' Exceptions:
'''  DUPLICATEKEYERROR: such a key exists already
'''  INVALIDKEYERROR: zero-length string or only spaces
''' Examples:
'''  myDict.Add("NewKey", NewValue)

Dim vItemMap As Variant   ' Output of SF_Array._FindItem
Dim lIndex As Long    ' Index in MapKeys and MapPositions
Const cstThisSub = "Dictionary.Add"
Const cstSubArgs = "Key, Item"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 Add = False

Check:
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch
  If IsArray(Item) Then
   If Not SF_Utils._ValidateArray(Item, "Item") Then GoTo Catch
  Else
   If Not SF_Utils._Validate(Item, "Item") Then GoTo Catch
  End If
 End If
 If Key = Space(Len(Key)) Then GoTo CatchInvalid

Try:
 _MapSize = _MapSize + 1
 vItemMap = SF_Array._FindItem(MapKeys, Key, CaseSensitive, "ASC")
 If vItemMap(0) Then GoTo CatchDuplicate  ' Key exists already
 lIndex = vItemMap(1)
 MapKeys = SF_Array.Insert(MapKeys, lIndex, Key)
 MapPositions = SF_Array.Insert(MapPositions, lIndex, _MapSize)
 ReDim Preserve MapItems(1 To _MapSize)
 MapItems(_MapSize) = Item
 Add = True

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
CatchDuplicate:
 SF_Exception.RaiseFatal(DUPLICATEKEYERROR, "Key", Key)
 GoTo Finally
CatchInvalid:
 SF_Exception.RaiseFatal(INVALIDKEYERROR, "Key")
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.Add

REM -----------------------------------------------------------------------------
Public Function ConvertToArray() As Variant
''' Store the content of the dictionary in a 2-columns array:
''' Key stored in 1st column, Item stored in 2nd
''' Args:
''' Returns:
'''  a zero-based 2D array(0:Count - 1, 0:1)
'''  an empty array if the dictionary is empty

Dim vArray As Variant  ' Return value
Dim sKey As String   ' Tempry key
Dim vKeys As Variant  ' Array of keys
Dim lCount As Long   ' Counter
Const cstThisSub = "Dictionary.ConvertToArray"
Const cstSubArgs = ""

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch

Check:
 SF_Utils._EnterFunction(cstThisSub, cstSubArgs)

Try:
 vArray = Array()
 If Count = 0 Then
 Else
  ReDim vArray(0 To Count - 1, 0 To 1)
  lCount = -1
  vKeys = Keys
  For Each sKey in vKeys
   lCount = lCount + 1
   vArray(lCount, 0) = sKey
   vArray(lCount, 1) = Item(sKey)
  Next sKey
 End If
  
Finally:
 ConvertToArray = vArray()
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ConvertToArray

REM -----------------------------------------------------------------------------
Public Function ConvertToJson(ByVal Optional Indent As Variant) As Variant
''' Convert the content of the dictionary to a JSON string
''' JSON = JavaScript Object Notation: https://en.wikipedia.org/wiki/JSON
''' Limitations
'''  Allowed item types: String, Boolean, numbers, Null and Empty
'''  Arrays containing above types are allowed
'''  Dates are converted into strings (not within arrays)
'''  Other types are converted to their string representation (cfr. SF_String.Represent)
''' Args:
'''  Indent:
'''   If indent is a non-negative integer or string, then JSON array elements and object members will be pretty-printed with that indent level.
'''   An indent level <= 0 will only insert newlines.
'''   "", (the default) selects the most compact representation.
'''   Using a positive integer indent indents that many spaces per level.
'''   If indent is a string (such as Chr(9)), that string is used to indent each level.
''' Returns:
'''  the JSON string
''' Example:
'''  myDict.Add("p0", 12.5)
'''  myDict.Add("p1", "a string àé""ê")
'''  myDict.Add("p2", DateSerial(2020,9,28))
'''  myDict.Add("p3", True)
'''  myDict.Add("p4", Array(1,2,3))
'''  MsgBox a.ConvertToJson() ' {"p0": 12.5, "p1": "a string \u00e0\u00e9\"\u00ea", "p2": "2020-09-28", "p3": true, "p4": [1, 2, 3]}

Dim sJson As String    ' Return value
Dim vArray As Variant   ' Array of property values
Dim oPropertyValue As Object ' com.sun.star.beans.PropertyValue
Dim sKey As String    ' Tempry key
Dim vKeys As Variant   ' Array of keys
Dim vItem As Variant   ' Tempry item
Dim iVarType As Integer   ' Extended VarType
Dim lCount As Long    ' Counter
Dim vIndent As Variant   ' Python alias of Indent
Const cstPyHelper = "$" & "_SF_Dictionary__ConvertToJson"

Const cstThisSub = "Dictionary.ConvertToJson"
Const cstSubArgs = "[Indent=Null]"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch

Check:
 If IsMissing(Indent) Or IsEmpty(INDENT) Then Indent = ""
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(Indent, "Indent", Array(V_STRING, V_NUMERIC)) Then GoTo Finally
 End If
 sJson = ""

Try:
 vArray = Array()
 If Count = 0 Then
 Else
  ReDim vArray(0 To Count - 1)
  lCount = -1
  vKeys = Keys
  For Each sKey in vKeys
   ' Check item type
   vItem = Item(sKey)
   iVarType = SF_Utils._VarTypeExt(vItem)
   Select Case iVarType
    Case V_STRING, V_BOOLEAN, V_NUMERIC, V_NULL, V_EMPTY
    Case V_DATE
     vItem = SF_Utils._CDateToIso(vItem)
    Case >= V_ARRAY
    Case Else
     vItem = SF_Utils._Repr(vItem)
   End Select
   ' Build in each array entry a (Name, Value) pair
   Set oPropertyValue = SF_Utils._MakePropertyValue(sKey, vItem)
   lCount = lCount + 1
   Set vArray(lCount) = oPropertyValue
  Next sKey
 End If

 'Pass array to Python script for the JSON conversion
 With ScriptForge.SF_Session
  vIndent = Indent
  If VarType(Indent) = V_STRING Then
   If Len(Indent) = 0 Then vIndent = Null
  End If
  sJson = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, vArray, vIndent)
 End With
  
Finally:
 ConvertToJson = sJson
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ConvertToJson

REM -----------------------------------------------------------------------------
Public Function ConvertToPropertyValues() As Variant
''' Store the content of the dictionary in an array of PropertyValues
''' Key stored in Name, Item stored in Value
''' Args:
''' Returns:
'''  a zero-based 1D array(0:Count - 1). Each entry is a com.sun.star.beans.PropertyValue
'''   Name: the key in the dictionary
'''   Value:
'''    Dates are converted to UNO dates
'''    Empty arrays are replaced by Null
'''  an empty array if the dictionary is empty

Dim vArray As Variant   ' Return value
Dim oPropertyValue As Object ' com.sun.star.beans.PropertyValue
Dim sKey As String    ' Tempry key
Dim vKeys As Variant  ' Array of keys
Dim lCount As Long    ' Counter
Const cstThisSub = "Dictionary.ConvertToPropertyValues"
Const cstSubArgs = ""

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch

Check:
 SF_Utils._EnterFunction(cstThisSub, cstSubArgs)

Try:
 vArray = Array()
 If Count = 0 Then
 Else
  ReDim vArray(0 To Count - 1)
  lCount = -1
  vKeys = Keys
  For Each sKey in vKeys
   ' Build in each array entry a (Name, Value) pair
   Set oPropertyValue = SF_Utils._MakePropertyValue(sKey, Item(sKey))
   lCount = lCount + 1
   Set vArray(lCount) = oPropertyValue
  Next sKey
 End If
  
Finally:
 ConvertToPropertyValues = vArray()
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ConvertToPropertyValues

REM -----------------------------------------------------------------------------
Public Function Exists(Optional ByVal Key As Variant) As Boolean
''' Determine if a key exists in the dictionary
''' Args:
'''  Key: the key value (string)
''' Returns: True if key exists
''' Examples:
'''  If myDict.Exists("SomeKey") Then ' don't add again

Dim vItem As Variant  ' Item part in MapKeys
Const cstThisSub = "Dictionary.Exists"
Const cstSubArgs = "Key"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 Exists = False

Check:
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch
 End If

Try:
 Exists = SF_Array.Contains(MapKeys, Key, CaseSensitive, SortOrder := "ASC")

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.Exists

REM -----------------------------------------------------------------------------
Public Function GetProperty(Optional ByVal PropertyName As Variant _
        , Optional ByVal Key As Variant _
        ) As Variant
''' Return the actual value of the given property
''' Args:
'''  PropertyName: the name of the property as a string
'''  Key: mandatory if PropertyName = "Item", ignored otherwise
''' Returns:
'''  The actual value of the property
''' Exceptions:
'''  ARGUMENTERROR  The property does not exist
''' Examples:
'''  myDict.GetProperty("Count")

Const cstThisSub = "Dictionary.GetProperty"
Const cstSubArgs = "PropertyName, [Key]"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 GetProperty = Null

Check:
 If IsMissing(Key) Or IsEmpty(Key) Then Key = ""
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
 End If

Try:
 GetProperty = _PropertyGet(PropertyName, Key)

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.GetProperty

REM -----------------------------------------------------------------------------
Public Function ImportFromJson(Optional ByVal InputStr As Variant _
           , Optional ByVal Overwrite As Variant _
           ) As Boolean
''' Adds the content of a Json string into the current dictionary
''' JSON = JavaScript Object Notation: https://en.wikipedia.org/wiki/JSON
''' Limitations
'''  The JSON string may contain numbers, strings, booleans, null values and arrays containing those types
'''  It must not contain JSON objects, i.e. sub-dictionaries
''' An attempt is made to convert strings to dates if they fit one of next patterns:
'''  YYYY-MM-DD, HH:MM:SS or YYYY-MM-DD HH:MM:SS
''' Args:
'''  InputStr: the json string to import
'''  Overwrite: when True entries with same name may exist in the dictionary and their values are overwritten
'''   Default = False
''' Returns:
'''  True if successful
''' Exceptions:
'''  DUPLICATEKEYERROR: such a key exists already
'''  INVALIDKEYERROR: zero-length string or only spaces
''' Example:
'''  Dim s As String
'''  s = "{'firstName': 'John','lastName': 'Smith','isAlive': true,'age': 66, 'birth':  '1954-09-28 20:15:00'" _
'''   & ",'address': {'streetAddress': '21 2nd Street','city': 'New York','state': 'NY','postalCode': '10021-3100'}" _
'''   & ",'phoneNumbers': [{'type': 'home','number': '212 555-1234'},{'type': 'office','number': '646 555-4567'}]" _
'''   & ",'children': ['Q','M','G','T'],'spouse': null}"
'''  s = Replace(s, "'", """")
'''  myDict.ImportFromJson(s, OverWrite := True)
'''   ' The (sub)-dictionaries "address" and "phoneNumbers(0) and (1) are reduced to Empty 

Dim bImport As Boolean   ' Return value
Dim vArray As Variant   ' JSON string converted to array
Dim vArrayEntry As Variant  ' A single entry in vArray
Dim vKey As Variant    ' Tempry key
Dim vItem As Variant   ' Tempry item
Dim bExists As Boolean   ' True when an entry exists
Dim dDate As Date    ' String converted to Date
Const cstPyHelper = "$" & "_SF_Dictionary__ImportFromJson"

Const cstThisSub = "Dictionary.ImportFromJson"
Const cstSubArgs = "InputStr, [Overwrite=False]"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 bImport = False

Check:
 If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(InputStr, "InputStr", V_STRING) Then GoTo Finally
  If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoYo Finally
 End If

Try:
 With ScriptForge.SF_Session
  vArray = .ExecutePythonScript(.SCRIPTISSHARED, _SF_.PythonHelper & cstPyHelper, InputStr)
 End With
 If Not IsArray(vArray) Then GoTo Finally ' Conversion error or nothing to do

 ' vArray = Array of subarrays = 2D DataArray (cfr. Calc)
 For Each vArrayEntry In vArray
  vKey = vArrayEntry(0)
  If VarType(vKey) = V_STRING Then ' Else skip
   vItem = vArrayEntry(1)
   If Overwrite Then bExists = Exists(vKey) Else bExists = False
   ' When the item matches a date pattern, convert it to a date
   If VarType(vItem) = V_STRING Then
    dDate = SF_Utils._CStrToDate(vItem)
    If dDate > -1 Then vItem = dDate
   End If
   If bExists Then
    ReplaceItem(vKey, vItem)
   Else
    Add(vKey, vItem) ' Key controls are done in Add
   End If
  End If
 Next vArrayEntry

 bImport = True

Finally:
 ImportFromJson = bImport
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ImportFromJson

REM -----------------------------------------------------------------------------
Public Function ImportFromPropertyValues(Optional ByVal PropertyValues As Variant _
           , Optional ByVal Overwrite As Variant _
           ) As Boolean
''' Adds the content of an array of PropertyValues into the current dictionary
''' Names contain Keys, Values contain Items
''' UNO dates are replaced by Basic dates
''' Args:
'''  PropertyValues: a zero-based 1D array. Each entry is a com.sun.star.beans.PropertyValue
'''  Overwrite: when True entries with same name may exist in the dictionary and their values are overwritten
'''   Default = False
''' Returns:
'''  True if successful
''' Exceptions:
'''  DUPLICATEKEYERROR: such a key exists already
'''  INVALIDKEYERROR: zero-length string or only spaces

Dim bImport As Boolean   ' Return value
Dim oPropertyValue As Object ' com.sun.star.beans.PropertyValue
Dim vItem As Variant   ' Tempry item
Dim sObjectType As String  ' UNO object type of dates
Dim bExists As Boolean   ' True when an entry exists
Const cstThisSub = "Dictionary.ImportFromPropertyValues"
Const cstSubArgs = "PropertyValues, [Overwrite=False]"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 bImport = False

Check:
 If IsMissing(Overwrite) Or IsEmpty(Overwrite) Then Overwrite = False
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If IsArray(PropertyValues) Then
   If Not SF_Utils._ValidateArray(PropertyValues, "PropertyValues", 1, V_OBJECT, True) Then GoTo Finally
  Else
   If Not SF_Utils._Validate(PropertyValues, "PropertyValues", V_OBJECT) Then GoTo Finally
  End If
  If Not SF_Utils._Validate(Overwrite, "Overwrite", V_BOOLEAN) Then GoYo Finally
 End If

Try:
 If Not IsArray(PropertyValues) Then PropertyValues = Array(PropertyValues)
 For Each oPropertyValue In PropertyValues
  With oPropertyValue
   If Overwrite Then bExists = Exists(.Name) Else bExists = False
   If SF_Session.UnoObjectType(oPropertyValue) = "com.sun.star.beans.PropertyValue" Then
    If IsUnoStruct(.Value) Then
     sObjectType = SF_Session.UnoObjectType(.Value)
     Select Case sObjectType
      Case "com.sun.star.util.DateTime" : vItem = CDateFromUnoDateTime(.Value)
      Case "com.sun.star.util.Date"  : vItem = CDateFromUnoDate(.Value)
      Case "com.sun.star.util.Time"  : vItem = CDateFromUnoTime(.Value)
      Case Else       : vItem = .Value
     End Select
    Else
     vItem = .Value
    End If
    If bExists Then
     ReplaceItem(.Name, vItem)
    Else
     Add(.Name, vItem) ' Key controls are done in Add
    End If
   End If
  End With
 Next oPropertyValue
 bImport = True

Finally:
 ImportFromPropertyValues = bImport
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ImportFromPropertyValues

REM -----------------------------------------------------------------------------
Public Function Methods() As Variant
''' Return the list or methods of the Dictionary class as an array

 Methods = Array( _
     "Add" _
     , "ConvertToArray" _
     , "ConvertToJson" _
     , "ConvertToPropertyValues" _
     , "Exists" _
     , "ImportFromJson" _
     , "ImportFromPropertyValues" _
     , "Remove" _
     , "RemoveAll" _
     , "ReplaceItem" _
     , "ReplaceKey" _
     )

End Function ' ScriptForge.SF_Dictionary.Methods

REM -----------------------------------------------------------------------------
Public Function Properties() As Variant
''' Return the list or properties of the Dictionary class as an array

 Properties = Array( _
     "Count" _
     , "Item" _
     , "Items" _
     , "Keys" _
     )

End Function ' ScriptForge.SF_Dictionary.Properties

REM -----------------------------------------------------------------------------
Public Function Remove(Optional ByVal Key As Variant) As Boolean
''' Remove an existing dictionary entry based on its key
''' Args:
'''  Key: must exist in the dictionary
''' Returns: True if successful
''' Exceptions:
'''  UNKNOWNKEYERROR: the key does not exist
''' Examples:
'''  myDict.Remove("OldKey")

Dim vItemMap As Variant   ' Output of SF_Array._FindItem
Dim lIndex As Long    ' Index in MapKeys and MapPositions
Const cstThisSub = "Dictionary.Remove"
Const cstSubArgs = "Key"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 Remove = False

Check:
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch
 End If
Try:
 vItemMap = SF_Array._FindItem(MapKeys, Key, CaseSensitive, "ASC")
 If Not vItemMap(0) Then GoTo CatchUnknown
 lIndex = vItemMap(1)
 MapKeys(lIndex) = ""
 MapKeys = SF_Array.TrimArray(MapKeys)
 Erase MapItems(MapPositions(lIndex))
 MapPositions(lIndex) = Null
 MapPositions = SF_Array.TrimArray(MapPositions)
 _MapRemoved = _MapRemoved + 1
 Remove = True

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
CatchUnknown:
 SF_Exception.RaiseFatal(UNKNOWNKEYERROR, "Key", Key)
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.Remove

REM -----------------------------------------------------------------------------
Public Function RemoveAll() As Boolean
''' Remove all the entries from the dictionary
''' Args:
''' Returns: True if successful
''' Examples:
'''  myDict.RemoveAll()

Dim vKeys As Variant   ' Array of keys
Dim sColl As String    ' A collection key in MapKeys
Const cstThisSub = "Dictionary.RemoveAll"
Const cstSubArgs = ""

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 RemoveAll = False

Check:
 SF_Utils._EnterFunction(cstThisSub, cstSubArgs)

Try:
 vKeys = Keys
 For Each sColl In vKeys
  Remove(sColl)
 Next sColl
 Erase MapKeys
 Erase MapItems
 ' Make dictionary ready to receive new entries
 Call Class_Initialize()
 RemoveAll = True

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.RemoveAll

REM -----------------------------------------------------------------------------
Public Function ReplaceItem(Optional ByVal Key As Variant _
       , Optional ByVal Value As Variant _
       ) As Boolean
''' Replace the item value
''' Args:
'''  Key: must exist in the dictionary
''' Returns: True if successful
''' Exceptions:
'''  UNKNOWNKEYERROR: the  old key does not exist
''' Examples:
'''  myDict.ReplaceItem("Key", NewValue)

Dim vItemMap As Variant   ' Output of SF_Array._FindItem
Dim lIndex As Long    ' Entry in the MapItems array
Const cstThisSub = "Dictionary.ReplaceItem"
Const cstSubArgs = "Key, Value"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 ReplaceItem = False

Check:
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch
  If IsArray(Value) Then
   If Not SF_Utils._ValidateArray(Value, "Value") Then GoTo Catch
  Else
   If Not SF_Utils._Validate(Value, "Value") Then GoTo Catch
  End If
 End If

Try:
 ' Find entry in MapItems and update it with the new value
 vItemMap = SF_Array._FindItem(MapKeys, Key, CaseSensitive, "ASC")
 If Not vItemMap(0) Then GoTo CatchUnknown
 lIndex = vItemMap(1)
 MapItems(MapPositions(lIndex)) = Value
 ReplaceItem = True

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
CatchUnknown:
 SF_Exception.RaiseFatal(UNKNOWNKEYERROR, "Key", Key)
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ReplaceItem

REM -----------------------------------------------------------------------------
Public Function ReplaceKey(Optional ByVal Key As Variant _
       , Optional ByVal Value As Variant _
       ) As Boolean
''' Replace existing key
''' Args:
'''  Key: must exist in the dictionary
'''  Value: must not exist in the dictionary
''' Returns: True if successful
''' Exceptions:
'''  UNKNOWNKEYERROR: the  old key does not exist
'''  DUPLICATEKEYERROR: the new key exists
''' Examples:
'''  myDict.ReplaceKey("OldKey", "NewKey")

Const cstThisSub = "Dictionary.ReplaceKey"
Const cstSubArgs = "Key, Value"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 ReplaceKey = False

Check:
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(Key, "Key", V_STRING) Then GoTo Catch
  If Not SF_Utils._Validate(Value, "Value", V_STRING) Then GoTo Catch
 End If
 If Not Exists(Key) Then GoTo CatchUnknown
 If Value = Space(Len(Value)) Then GoTo CatchInvalid
 If Exists(Value) Then GoTo CatchDuplicate

Try:
 ' Remove the Key entry and create a new one
 Add(Value, Item(Key))
 Remove(Key)
 ReplaceKey = True

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
CatchUnknown:
 SF_Exception.RaiseFatal(UNKNOWNKEYERROR, "Key", Key)
 GoTo Finally
CatchDuplicate:
 SF_Exception.RaiseFatal(DUPLICATEKEYERROR, "Value", Value)
 GoTo Finally
CatchInvalid:
 SF_Exception.RaiseFatal(INVALIDKEYERROR, "Key")
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.ReplaceKey

REM -----------------------------------------------------------------------------
Public Function SetProperty(Optional ByVal PropertyName As Variant _
        , Optional ByRef Value As Variant _
        ) As Boolean
''' Set a new value to the given property
''' Args:
'''  PropertyName: the name of the property as a string
'''  Value: its new value
''' Exceptions
'''  ARGUMENTERROR  The property does not exist

Const cstThisSub = "Dictionary.SetProperty"
Const cstSubArgs = "PropertyName, Value"

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch
 SetProperty = False

Check:
 If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then
  If Not SF_Utils._Validate(PropertyName, "PropertyName", V_STRING, Properties()) Then GoTo Catch
 End If

Try:
 Select Case UCase(PropertyName)
  Case Else
 End Select

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary.SetProperty

REM =========================================================== PRIVATE FUNCTIONS

REM -----------------------------------------------------------------------------
Private Function _PropertyGet(Optional ByVal psProperty As String _
        , Optional pvKey As Variant _
        )
''' Return the named property
''' Args:
'''  psProperty: the name of the property
'''  pvKey: the key to retrieve, numeric or string

Dim vItemMap As Variant   ' Output of SF_Array._FindItem
Dim lIndex As Long    ' Entry in the MapItems array
Dim vArray As Variant   ' To get Keys or Items
Dim i As Long
Dim cstThisSub As String
Dim cstSubArgs As String

 If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch

 cstThisSub = "SF_Dictionary.get" & psProperty
 If IsMissing(pvKey) Then cstSubArgs = "" Else cstSubArgs = "[Key]"

 SF_Utils._EnterFunction(cstThisSub, cstSubArgs)

 Select Case UCase(psProperty)
  Case UCase("Count")
   _PropertyGet = _MapSize - _MapRemoved
  Case UCase("Item")
   If Not SF_Utils._Validate(pvKey, "Key", V_STRING) Then GoTo Catch
   vItemMap = SF_Array._FindItem(MapKeys, pvKey, CaseSensitive, "ASC")
   lIndex = vItemMap(1)
   If vItemMap(0) Then _PropertyGet = MapItems(MapPositions(lIndex)) Else _PropertyGet = Empty
  Case UCase("Keys"), UCase("Items")
   vArray = Array()
   If UBound(MapKeys) >= 0 Then
    ReDim vArray(0 To UBound(MapKeys))
    For i = 0 To UBound(MapKeys)
     Select Case UCase(psProperty)
      Case "KEYS"  : vArray(i) = MapKeys(i)
      Case "ITEMS" : vArray(i) = MapItems(MapPositions(i))
     End Select
    Next i
   End If
   _PropertyGet = vArray
 End Select

Finally:
 SF_Utils._ExitFunction(cstThisSub)
 Exit Function
Catch:
 GoTo Finally
End Function ' ScriptForge.SF_Dictionary._PropertyGet

REM -----------------------------------------------------------------------------
Private Function _Repr() As String
''' Convert the Dictionary instance to a readable string, typically for debugging purposes (DebugPrint ...)
''' Args:
''' Return:
'''  "[Dictionary] (key1:value1, key2:value2, ...)

Dim sDict As String   ' Return value
Dim vKeys As Variant  ' Array of keys
Dim sKey As String   ' Tempry key
Dim vItem As Variant  ' Tempry item
Const cstDictEmpty = "[Dictionary] ()"
Const cstDict = "[Dictionary]"
Const cstMaxLength = 50 ' Maximum length for items
Const cstSeparator = ", "

 _Repr = ""

 If Count = 0 Then
  sDict = cstDictEmpty
 Else
  sDict = cstDict & " ("
  vKeys = Keys
  For Each sKey in vKeys
   vItem = Item(sKey)
   sDict = sDict & sKey & ":" & SF_Utils._Repr(vItem, cstMaxLength) & cstSeparator
  Next sKey
  sDict = Left(sDict, Len(sDict) - Len(cstSeparator)) & ")" ' Suppress last comma
 End If

 _Repr = sDict

End Function ' ScriptForge.SF_Dictionary._Repr

REM ============================================ END OF SCRIPTFORGE.SF_DICTIONARY
</script:module>