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 Explicit ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''' SF_SharedMemory ''' =============== ''' Singleton class implementing the "ScriptForge.SharedMemory" service ''' Implemented as a usual Basic module ''' ''' Contains the mechanisms to manage persistent memory storage ''' across Basic and/or Python scripts. ''' ''' When a script stops running, all the variables it uses vanish, ''' except Basic Global variables, which stay in memory until the end ''' of the LibreOffice session. ''' ''' However event-driven scripting can often benefit from having variables ''' still being available when the next script is triggered, probably due ''' to a user action. ''' ''' The SharedMemory service implements interfaces allowing to store both BASIC ''' and PYTHON variables in persistent storage, and to retrieve them later ''' from either BASIC or PYTHON scripts interchangeably. ''' ''' The use of the Basic Global statement is more efficient than the actual service ''' and should be preferred when the variables are created and retrieved in basic ''' scripts only. ''' ''' Service invocation example: ''' Dim memory As Variant ''' memory = CreateScriptService("SharedMemory") ''' ''' Example: ''' Sub CreateDoc() ''' ui = CreateScriptService("UI") ''' doc = ui.CreateDocument("Calc") ''' store = CreateScriptService("SharedMemory") ''' store.StoreValue(doc, "actualdocument") ''' ... ''' ''' def UpdateDoc(): ''' store = CreateScriptService("SharedMemory") ''' doc = store.ReadValue("actualdocument") ''' ... ''' ''' Detailed user documentation: ''' https://help.libreoffice.org/latest/en-US/text/sbasic/shared/03/sf_SharedMemory.html?DbPAR=BASIC ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' REM ================================================================== EXCEPTIONS REM ============================================================ MODULE CONSTANTS REM ===================================================== CONSTRUCTOR/DESTRUCTOR REM ----------------------------------------------------------------------------- Public Function Dispose() As Variant RemoveAll() Set Dispose = Nothing End Function ' ScriptForge.SF_SharedMemory Explicit destructor REM ================================================================== PROPERTIES REM ----------------------------------------------------------------------------- Property Get ObjectType As String ''' Only to enable object representation ObjectType = "SF_SharedMemory" End Property ' ScriptForge.SF_SharedMemory.ObjectType REM ----------------------------------------------------------------------------- Property Get ServiceName As String ''' Internal use ServiceName = "ScriptForge.SharedMemory" End Property ' ScriptForge.SF_SharedMemory.ServiceName REM ============================================================== PUBLIC METHODS REM ----------------------------------------------------------------------------- Public Function GetProperty(Optional ByVal PropertyName As Variant) As Variant ''' Return the actual value of the given property ''' Args: ''' PropertyName: the name of the property as a string ''' Returns: ''' The actual value of the property ''' Exceptions ''' ARGUMENTERROR The property does not exist Const cstThisSub = "SharedMemory.GetProperty" Const cstSubArgs = "PropertyName" If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch GetProperty = Null Check:SharedMemory 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_SharedMemory.GetProperty REM ----------------------------------------------------------------------------- Public Function Methods() As Variant ''' Return the list of public methods of the SharedMemory service as an array Methods = Array( _ "Exists" _ , "ReadValue" _ , "Rename" _ , "Remove" _ , "RemoveAll" _ , "StoreValue" _ ) End Function ' ScriptForge.SF_SharedMemory.Methods REM ----------------------------------------------------------------------------- Public Function Properties() As Variant ''' Return the list or properties as an array Properties = Array( _ ) End Function ' ScriptForge.SF_SharedMemory.Properties REM ----------------------------------------------------------------------------- Public Function Exists(Optional ByVal VariableName As Variant) As Boolean ''' Returns True if the given name exists in the shared and persistent storage. ''' Args: ''' VariableName: a case-sensitive name. ''' Returns: ''' True if VariableName exists. ''' Example: ''' memory = CreateScriptService("SharedMemory") ''' If memory.Exists("ActualDoc") Then ''' ... Dim bExists As Boolean ' Return value Const cstThisSub = "SharedMemory.Exists" Const cstSubArgs = "VariableName" If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bExists = False Check: If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not SF_Utils._Validate(VariableName, "VariableName", V_STRING) Then GoTo Catch End If Try: If Not IsNull(_SF_.GlobalStorage) Then bExists = _SF_.GlobalStorage.Exists(VariableName) Finally: Exists = bExists SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' ScriptForge.SF_SharedMemory.Exists REM ----------------------------------------------------------------------------- Public Function ReadValue(Optional ByVal VariableName As Variant) As Variant ''' Read in the shared and persistent storage area the requested value or array of values. ''' If the returned value is a ScriptForge class instance, the user script can verify if the ''' corresponding interface (dialog, document, ...) is still valid with its IsAlive property. ''' Args: ''' VariableName: the case-sensitive name of the value to retrieve. ''' Returns: ''' A scalar or an array of scalars. ''' If VariableName does not exist, an error is generated. ''' Example: ''' memory = CreateScriptService("SharedMemory") ''' doc = CreateScriptService("Document", ThisComponent) ''' memory.StoreValue("ActualDoc", doc) ''' ... ' The script might be stopped ''' doc2 = memory.ReadValue("ActualDoc") ''' If doc2.IsAlive Then ' Check that the document has not been closed by the user ''' ... Dim vRead As Variant ' Return value Dim vKeys As Variant ' Array of dictionary keys Const cstThisSub = "SharedMemory.ReadValue" Const cstSubArgs = "VariableName" If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch vRead = Empty ' Initialize the dictionary if necessary If IsNull(_SF_.GlobalStorage) Then _SF_.GlobalStorage = CreateScriptService("Dictionary", True) Check: vKeys = _SF_.GlobalStorage.Keys If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not SF_Utils._Validate(VariableName, "VariableName", V_STRING, vKeys, True) Then GoTo Catch End If Try: ' Read the value in the persistent dictionary vRead = _SF_.GlobalStorage.Item(VariableName) Finally: ReadValue = vRead SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' ScriptForge.SF_SharedMemory.ReadValue REM ----------------------------------------------------------------------------- Public Function Remove(Optional ByVal VariableName As Variant) As Boolean ''' Remove the entry in the shared and persistent storage area corresponding with the given name. ''' Args: ''' VariableName: the case-sensitive name to remove. ''' Returns: ''' True when successful. ''' If VariableName does not exist, an error is generated. ''' Example: ''' memory = CreateScriptService("SharedMemory") ''' If memory.Exists("ActualDoc") Then memory.Remove("ActualDoc") ''' ... Dim bRemove As Boolean ' Return value Dim vKeys As Variant ' Array of dictionary keys Const cstThisSub = "SharedMemory.Remove" Const cstSubArgs = "VariableName" If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bRemove = False ' Initialize the dictionary if necessary If IsNull(_SF_.GlobalStorage) Then _SF_.GlobalStorage = CreateScriptService("Dictionary", True) Check: vKeys = _SF_.GlobalStorage.Keys If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not SF_Utils._Validate(VariableName, "VariableName", V_STRING, vKeys, True) Then GoTo Catch End If Try: ' Remove key and item from the persistent dictionary bRemove = _SF_.GlobalStorage.Remove(VariableName) Finally: Remove = bRemove SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' ScriptForge.SF_SharedMemory.Remove REM ----------------------------------------------------------------------------- Public Function RemoveAll() As Boolean ''' Remove the whole content of the shared and persistent storage area. ''' Returns: ''' True when successful. ''' Example: ''' memory = CreateScriptService("SharedMemory") ''' memory.RemoveAll() ''' MsgBox memory.Exists("ActualDoc") ' False ''' ... Dim bRemoveAll As Boolean ' Return value Const cstThisSub = "SharedMemory.RemoveAll" Const cstSubArgs = "" If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bRemoveAll = False Check: SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Try: If Not IsNull(_SF_.GlobalStorage) Then bRemoveAll = _SF_.GlobalStorage.RemoveAll() Finally: RemoveAll = bRemoveAll SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' ScriptForge.SF_SharedMemory.RemoveAll 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 = "SharedMemory.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 SetProperty = True Finally: SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' ScriptForge.SF_SharedMemory.SetProperty REM ----------------------------------------------------------------------------- Public Function StoreValue(Optional ByVal VariableName As Variant _ , Optional ByVal Value As Variant _ ) As Boolean ''' Store in the shared and persistent storage area the given value. ''' Later retrieval will be done thanks to the given variable name. ''' If the given name already exists, its value is replaced without warning. ''' Args: ''' VariableName: the case-sensitive name to retrieve the Value when needed. ''' Value: the value to be stored. ''' The supported variable types are: ''' * Scalar or 1D-array/tuple combining : ''' - Integer/Long or int, within the bounds of the Basic Long type ''' - Single/Double or float, within the bounds of the Basic Double type ''' - String or str ''' - Boolean or bool ''' - Null or None (Empty and Nothing are reset to Null) ''' - Variant embedding one of above types ''' * Date or datetime.datetime ''' * UNO object ''' * ScriptForge class instance ''' Returns: ''' True when successful ''' Example: ''' memory = CreateScriptService("SharedMemory") ''' doc = CreateScriptService("Document", ThisComponent) ''' memory.StoreValue("ActualDoc", doc) Dim bStore As Boolean ' Return value Dim vGlobal As Variant ' A stored value Dim i As Long Const cstThisSub = "SharedMemory.StoreValue" Const cstSubArgs = "VariableName, Value" If SF_Utils._ErrorHandling() Then On Local Error GoTo Catch bStore = False Check: If SF_Utils._EnterFunction(cstThisSub, cstSubArgs) Then If Not SF_Utils._Validate(VariableName, "VariableName", V_STRING) Then GoTo Catch If IsArray(Value) Then If Not SF_Utils._ValidateArray(Value, "Value", 1) Then GoTo Catch End If End If Try: ' Initialize the dictionary if necessary If IsNull(_SF_.GlobalStorage) Then _SF_.GlobalStorage = CreateScriptService("Dictionary", True) ' Size the returned array when the input is an array If IsArray(Value) Then vGlobal = Array() ReDim vGlobal(LBound(Value) To UBound(Value)) For i = LBound(vGlobal) To UBound(vGlobal) vGlobal(i) = _ConvertValue(Value(i), pbArray := True) If IsEmpty(vGlobal(i)) Then vGlobal = Empty Exit For End If Next i Else vGlobal = _ConvertValue(Value, pbArray := False) End If ' Store the value in the persistent dictionary If Not IsEmpty(vGlobal) Then With _SF_.GlobalStorage If .Exists(VariableName) Then bStore = .ReplaceItem(VariableName, vGlobal) Else bStore = .Add(VariableName, vGlobal) End With End If Finally: StoreValue = bStore SF_Utils._ExitFunction(cstThisSub) Exit Function Catch: GoTo Finally End Function ' ScriptForge.SF_SharedMemory.StoreValue REM =========================================================== PRIVATE FUNCTIONS REM ----------------------------------------------------------------------------- Private Function _ConvertValue(pvValue As Variant _ , pbArray As Boolean _ ) As Variant ''' Convert the input value to one of the types applicable ''' to shared memory constraints. ''' Args: ''' pvValue: the input value, must not be an array ''' pbArray: when True, pvValue is an item inside an array ''' Returns: ''' The converted value. ''' Empty when the conversion was not successful. Dim vGlobal As Variant ' Return value Dim iObjectType As Integer ' The object type returned by _VarTypeObj() Try: vGlobal = Empty Select Case VarType(pvValue) Case V_INTEGER, V_LONG, V_BIGINT vGlobal = CLng(pvValue) Case V_SINGLE, V_DOUBLE, V_CURRENCY, V_DECIMAL vGlobal = CDbl(pvValue) Case V_EMPTY, V_NULL vGlobal = Null Case V_STRING, ScriptForge.V_BOOLEAN vGlobal = pvValue Case V_DATE ' No dates in arrays If Not pbArray Then vGlobal = pvValue Case ScriptForge.V_OBJECT If Not pbArray Then ' No objects in arrays iObjectType = SF_Utils._VarTypeObj(pvValue).iVarType Select Case iObjectType Case ScriptForge.V_Nothing vGlobal = Null Case ScriptForge.V_UNOOBJECT, ScriptForge.V_SFOBJECT vGlobal = pvValue Case Else ' V_BASICOBJECT End Select End If Case >= ScriptForge.V_ARRAY ' No subarrays Case Else End Select Finally: _ConvertValue = vGlobal Exit Function End Function ' ScriptForge.SF_SharedMemory._ConvertValue REM =============================================== END OF SCRIPTFORGE.SF_SHAREDMEMORY