[Résolu][Basic] A propos des mutex et des singletons ...

Discussions et questions sur tout ce qui concerne la programmation tous langages et tous modules confondus.

Modérateur : Vilains modOOs

Règles du forum
:alerte: Balisage obligatoire dans cette section !
Aidez-nous à vous aider au mieux en balisant correctement votre question : reportez-vous sur les règles de cette section avant de poster !
gelinp
Membre OOrganisé
Membre OOrganisé
Messages : 58
Inscription : 12 mars 2011 21:40

[Résolu][Basic] A propos des mutex et des singletons ...

Message par gelinp »

Bonjour,

Deux problèmes récurent dans les macros et transversal à l'ensemble des modules OpenOffice est l'emploi d'un singleton et l'utilisation d'un mutex pour gérer les évènements. Malgré ma consultation de plusieurs livres sur la programmation LibreOffice, OpenOffice je n'ai pas encore trouvé de solution qui s'impose sur ces deux sujets, et rien encore non plus dans le fil de discussion "Suprême de code"...

Je communique ci-dessous mon algorithme pour gérer un mutex, mais je cherche quelque chose de mieux car celui-ci est encore bien perfectible, il a tendance à bloquer l'interface... Surtout si une macro quitte sur une erreur avant de débloquer le mutex... L'exécution suivante est alors complètement bloquée, et il faut redémarrer l'application ...

Module TMutex : Ce module utilise également le module TDictionnaire listé ci-dessous. Le principe du module TMutex est de pouvoir employer plusieurs mutex simultanément pour gérer l'application, chacun associé à une clé dans un pseudo objet TDictionnaire. Le Mutex fonctionne avec une double réservation : un mutex interne pour gérer la concurrence d'accès aux méthodes du pseudo objet TMutex lui même et un mutex extern, répondant à la demande de l'appelant qui demande le verrouillage d'une section de code.

Code : Tout sélectionner

REM  *****  BASIC  *****
Option Compatible
Option ClassModule

Option Explicit

Dim _ChienMax As Long
Dim _Step As Long
DIm _oDictFlags As Object

Rem ===========================================================================
Rem  					CONSTRUCTEUR / DESCTRUCTEUR
Rem ===========================================================================

' #PROCEDURE# ==================================================================
' Name...........: Class_Initialize
' Description ...: 
' Parameters ....: 
' Syntax ........: TransiterEtat(NouvelEtat)
'                  NouvelEtat  - Etat à atteindre
' Return values .: Success - void
'                  Failure - sets @error
'                  |1 - NouvelEtat n'est pas un etat valide
'                  |2 - La transition n'est pas autorisée
' Author ........: Patrick
' Modified.......:  - code cleanup
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......: 
Private Sub Class_Initialize()
	
	On local error goto Erreur
	
	SgtDebug.Trace(Name, "Class_Initialize()", TRACE_FLAG)	
	
	_Step = 80 '80 millisecondes 
	_ChienMax = 100 '100*80 = 8 secondes, une eternité pour l'utilisateur ...	
	_oDictFlags = New TDictionnaire
	_oDictFlags.Ajouter("FlagMutex", false)
	
	SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)", TRACE_FLAG)
	SgtDebug.Assert(Name, _oDictFlags.Contient("FlagMutex"), 12, "Class_Initialize::_oDictFlags.Contient(FlagMutex)", TRACE_FLAG)
	
Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "EstLibre")
	Resume Exit_Sub
End Sub

' #PROCEDURE# ==================================================================
' Name...........: Class_Terminate()
' Description ...: 
' Parameters ....: 
' Syntax ........: TransiterEtat(NouvelEtat)
'                  NouvelEtat  - Etat à atteindre
' Return values .: Success - void
'                  Failure - sets @error
'                  |1 - NouvelEtat n'est pas un etat valide
'                  |2 - La transition n'est pas autorisée
' Author ........: Patrick 
' Modified.......:  - code cleanup
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......: 
Private Sub Class_Terminate()
	SgtDebug.Trace(Name, "Class_Terminate()", TRACE_FLAG)	
	Erase _oDictFlags
End Sub

Rem ===========================================================================
Rem  					PROPRIETES
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: ChienMax
' Description ...: 
' Parameters ....: 
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......:  - code cleanup
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Property Let ChienMax(chienmax As Long)
	_ChienMax = chienmax
End Property

' #PROCEDURE# ==================================================================
' Name...........: StepWait
' Description ...: 
' Parameters ....: 
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......:  - code cleanup
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Property Let StepWait(milliseconds As Long)
	_Step = milliseconds
End Property


' #PROCEDURE# ==================================================================
' Name...........: NBElements
' Description ...: 
' Parameters ....: 
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......:  - code cleanup
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Property Get NBElements As Long

	On local error goto Erreur
	
	NBElements = _oDictFlags.NBElements

Exit_Property:
	On error resume next
	Exit Property
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "NBElements")
	Resume Exit_Property
End Property

Rem ===========================================================================
Rem  					METHODES PRIVEES
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: _Verrouiller
' Portée.........: PRIVE
' Description ...: Verrouille l'utilisation interne de l'objet Mutex (aucune autre 
'					méthode ne peut être appelée, de façon à garantir l'intégrité 
'					de l'état interne du Mutex). Le Mutex est un singleton, donc 
'					une ressource partagée qui ne oblige un accès séquentiel. Le 
'					temps d'attente est fixé par _Step * ChienDeGarde. Pendant le 
'					temps _Step le thread en attente est complètement endormi...
' Parameters ....: label : Un label assoccié au verrouillage (utile pour le fichier 
'					de logs)
' Syntax ........: 
' Author ........: Patrick 
' Modified.......: 30/01/2018
' Remarks .......: En cas d'abandon le trhead est stoppé, ce qui pourrait poser 
'					problème si l'évènement n'est pas reproduit quelques temps 
'					après.
' Related .......: Verouiller : Verouille une méthode externe au mutex.
' Link ..........:
' Example .......: _Verrouiller("blocage par appelant ####")
Private Sub _Verrouiller(Optional Label As String)
	
	Dim ChienDeGarde As  integer
	
	On error goto Erreur
	
	SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)", TRACE_FLAG)
	SgtDebug.Assert(Name, _oDictFlags.Contient("FlagMutex"), 12, "_Verrouiller::_oDictFlags.Contient(FlagMutex)", TRACE_FLAG)
	
	SgtDebug.Trace(Name, "*** DEMANDE BLOQUANTE DU VERROU INTERNE ***", TRACE_EVENT)
	
	'Si FlagMutex = true alors le mutex est verouillé, il faut attendre le retour de FlagMutex = false
	ChienDeGarde = 1
	Dim flagmutex As Boolean
	flagmutex = _oDictFlags.Item("FlagMutex") 
	While flagmutex AND (ChienDeGarde < _ChienMax)
		SgtDebug.Trace(Name, " ... ", TRACE_EVENT)
		Wait(_Step)
		ChienDeGarde = ChienDeGarde + 1
	Wend
	
	If ChienDeGarde = _ChienMax Then 
		SgtDebug.Trace(Name, "*** ABANDON DE LA DEMANDE DU VERROU INTERNE ! (" & Label & ") ***", TRACE_EVENT)
		Stop
	EndIf
	
	_oDictFlags.Actualiser("FlagMutex", true)
	SgtDebug.Trace(Name, "*** VERROU INTERNE ACTIVE (" & Label & ") ***", TRACE_EVENT
	
Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "_Verrouiller()")
	Resume Exit_Sub
End Sub

' #PROCEDURE# ==================================================================
' Name...........: _Liberer
' Portée.........: PRIVE
' Description ...: Libère le verrou interne du Mutex
' Parameters ....: label : Un label assoccié au verrouillage (utile pour le fichier 
'					de logs)
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......: 30/01/2018
' Remarks .......: 
' Related .......:
' Link ..........: voir "_Verrouiller(label As String)"
' Example .......:
Private Sub _Liberer(Optional Label As String)
	
	On error goto Erreur
	
	SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)")
	
	SgtDebug.Trace(Name, "*** VERROU INTERNE LIBERE ***", TRACE_EVENT)
	
	_oDictFlags.Actualiser("FlagMutex", false)
	
Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "_Liberer()")
	Resume Exit_Sub
End Sub

' #PROCEDURE# ==================================================================
' Name...........: Trace
' Portée.........: PUBLIQUE
' Description ...: Trace l'état interne du Mutex dans le flux utilisé par l'objet 
'					TDebug en paramètre.
' Parameters ....: oDebug : TDebug : Un objet Debug
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......: 30/01/2018
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Sub Trace(oDebug As Object)
	
	On error goto Erreur
	
	_oDictFlags.Trace(oDebug)
	
Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "_Trace()")
	Resume Exit_Sub
End Sub


Rem ===========================================================================
Rem  					METHODES PUBLIQUES
Rem ===========================================================================
' #PROCEDURE# ==================================================================
' Name...........: VerrouillerFlag
' Portée.........: PUBLIQUE
' Description ...: Pose d'un verrou pour éviter un appel réentrant sur la méthode 
'					appelante.
' Parameters ....: sFlag : String : Le nom du verrou
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......: 30/01/2018
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Function VerrouillerFlag(sFlag As String, Optional sAppelant As String="") As Boolean
	Dim ChienDeGarde As Integer
	
	On local error goto Erreur
	
	SgtDebug.Trace(Name, "*** DEMANDE BLOQUANTE DU VERROU EXTERNE " &  sFlag & " par " & sAppelant & " ... ***", TRACE_EVENT)
	
	_Verrouiller("FlagMutex")
	
	'Si le flag du verrou n'existe pas alors il est ajouté à la 
	'collection courrante directement en mode réservation.
	SgtDebug.Trace(Name, "Mutex contient " & sFlag & " ? : " & _oDictFlags.Contient(sFlag), TRACE_FLAG)
	If not _oDictFlags.Contient(sFlag) Then
		SgtDebug.Trace(Name, "CREATION DU VERROU " & sFlag, TRACE_EVENT)
		_oDictFlags.Ajouter(sFlag, false)			
		Goto Exit_Function
	EndIf
	
	'Attente de la libération du verrou pour une durée max de _ChienMax * _Step millisecondes ...
	ChienDeGarde = 1
	While _oDictFlags.Item(sFlag) AND (ChienDeGarde <= _ChienMax)
		SgtDebug.Trace(Name, " ... ", TRACE_EVENT)
		wait(_Step)
		ChienDeGarde = ChienDeGarde + 1
	Wend
	
	'Activation du verrou externe si ChienDeGarde < _ChienMax (flag = True)
	If (ChienDeGarde <= _ChienMax) Then
		_oDictFlags.Actualiser(sFlag, true)
		SgtDebug.Assert(Name, not EstFlagLibre(sFlag), 12, TRACE_FLAG)
		SgtDebug.Trace(Name, "*** VERROU " & sFlag & " ACTIVE POUR " & sAppelant & "(" & ChienDeGarde * _Step & " ms) ***", TRACE_EVENT)
	Else
		'On abandonne en laissant le verrou externe bloqué, mais on libère le verrour interne ... 
		'_oDictFlags.Actualiser(sFlag, false)
		SgtDebug.Trace(Name, "*** VERROU " &  sFlag & " ANNULE ET LIBERE. APPELANT ETAIT " & sAppelant & "(" & ChienDeGarde * _Step & " ms) ***", TRACE_EVENT)
		Goto Exit_Function
	EndIf

Exit_Function:
	On error resume next
	'Libération du verrou interne !
	_Liberer("FlagMutex")
	VerrouillerFlag = (ChienDeGarde <= _ChienMax)	
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "ERREUR VerrouillerFlag()")
	Resume Exit_Function
End Function

' #PROCEDURE# ==================================================================
' Name...........: LibererFlag
' Description ...: Libère le verrou nommé en paramètre.
' Parameters ....: sFlag : String : Le nom du verrou
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......: 30/01/2018
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Sub LibererFlag(sFlag As String, Optional sAppelant As String="")
	
	On local error goto Erreur
	
	SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)")
	
	If not _oDictFlags.Contient(sFlag) Then
		Goto Exit_sub
	EndIf
	_oDictFlags.Actualiser(sFlag, false)
	SgtDebug.Trace(Name, "*** VERROU " &  sFlag & " LIBERE. APPELANT ETAIT " & sAppelant & " ***", TRACE_EVENT)
	
Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "LibererFlag()")
	Resume Exit_Sub
End Sub

' #PROCEDURE# ==================================================================
' Name...........: EstFlagLibre
' Description ...: Vrai si le verrou nommé par le Flag est actif, sinon false
' Parameters ....: sFlag : String : Le nom du verrou
' Syntax ........: 
' Return values .: Success - void
' Author ........: Patrick 
' Modified.......: 30/01/2018
' Remarks .......: 
' Related .......:
' Link ..........:
' Example .......:
Public Function EstFlagLibre(sFlag As String) As Boolean
	
	On local error goto Erreur
	
	SgtDebug.Assert(Name, not EstVide(_oDictFlags), 12, "not EstVide(_oDictFlags)")
	SgtDebug.Trace(Name, "EstFlagLibre(" & sFlag & ") ? : Exist : " & _oDictFlags.Contient(sFlag) & ", EstVerrouille : " & _oDictFlags.Item(sFlag), TRACE_FLAG)
	
	
	EstFlagLibre = _oDictFlags.Contient(sFlag) AND (not _oDictFlags.Item(sFlag))
	
Exit_Function:
	On error resume next
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	SgtDebug.Catch(Name, "Flag()")
	Resume Exit_Function
End Function

Sub Main
	
	Dim Mutex As Object
	
	Mutex = getGlobalMutex()
	Mutex.acquire() 	
	Mutex.Release()
	Erase Mutex
	
End Sub
Module TDictionnaire:

Code : Tout sélectionner

REM  *****  BASIC  *****
Option Compatible
Option ClassModule
Option Base  0 ' Important pour le bon foncitonnement des fonctions FMT_***
Option Explicit


Rem Classe TDictionnaire : Tient à jour une liste triée d'étiquette, chacune 
Rem reliée à un objet variant.
Rem Si la clé recherchée n'existe pas alors un exception est déclenchée. De même 
Rem pour l'ajout si la clé existe déjà.

Rem ***************************************************************************
Rem
Rem TYPES / CONSTANTES / VARIABLES PRIVEES ET GLOBALES
Rem
Rem ***************************************************************************
Private _VecteurDict As Object 'Un vecteur d'objets TDuolet : (key, item)

Private const avant = -1
Private const apres = 1
Private const identique = 0
Private const _StepSize = 30

Rem ***************************************************************************
Rem
Rem CONSTRUCTORS / DESCTRUCTORS
Rem
Rem ***************************************************************************
Private Sub Class_Initialize()	
	_VecteurDict = new TVecteur
	_VecteurDict.StepSize = _StepSize
End Sub

Private Sub Class_Terminate()
	Vider()
	Erase _VecteurDict
End Sub

Rem ***************************************************************************
Rem
Rem PROPRIETES
Rem
Rem ***************************************************************************
Public Property Let Titre(ByVal unTitre As String)
	_VecteurDict.Titre  = unTitre
End Property

Public Property Get Titre As String
	Titre  = _VecteurDict.Titre
End Property

Public Property Get AllItems As Variant
	AllItems = _VecteurDict.AllItems
End Property

Public Property Get Vecteur As Object
	Vecteur = _VecteurDict
End Property

Public Property Get Taille As Long
	Taille = _VecteurDict.Taille
End Property

Public Property Get NBElements As Long
	NBElements = _VecteurDict.NBElements
End Property

Public Property Let StepSize(ByVal delta As Long)
	_VecteurDict.StepSize  = delta
End Property

Public Property Get StepSize As Long
	StepSize = _VecteurDict.StepSize
End Property

Public Property Get Iterateur As Object
	Dim _Iterateur As Object
	
	Set _Iterateur = New TIterateurVecteur
	_Iterateur.InitialisePremier(_VecteurDict)
	
	Iterateur = _Iterateur
End Property

Public Property Get Premier As Variant
	Dim v As variant 'Nothing par defaut
	
	If (NBElements > 0) Then
		v = _VecteurDict.getItem(_VecteurDict.IdxMin).Item
	EndIf
	
	Premier = v
End Property

Public Property Get Dernier As Variant
	Dim v As variant 'Nothing par defaut
	
	If (NBElements > 0) Then
		v = _VecteurDict.getItem(_VecteurDict.IdxMax).Item
	EndIf
	
	Premier = v
End Property

Rem ***************************************************************************
Rem
Rem METHODES PRIVEES
Rem
Rem ***************************************************************************
' #FUNCTION# ==================================================================
' Name...........: _TextComp
' Description ...: 
' Parameters ....: 
' Syntax ........: _TextComp(S1,S2,0)
' Return values .: N/A
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Private Function _TextComp(s1 As String, s2 As String, Optional bAvecCasse As Integer) As Integer
	if IsMissing(bAvecCasse) Then bAvecCasse = 0
	_TextComp = StrComp(s1, s2, bAvecCasse)
End Function

  
' #FUNCTION# ==================================================================
' Name...........: _FMT_ArrayHasKey
' Description ...: Determine if an array contains a specific string.Although a 
					'binary search is faster for large arrays, I  expect small 
					'arrays here, so a linear search might be faster.
' Parameters ....: 
' Syntax ........: _FMT_ArrayHasKey(skey)
' Return values .: Boolean
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Private Function _FMT_ArrayHasKey(skey As String) As Boolean
  Dim i   As Integer 
  Dim iUB As Integer
  Dim iLB As Integer

	On local Error Goto Erreur
	
  _FMT_ArrayHasKey() = False
  if _VecteurDict.EstVide Then Exit Function

  iUB = _VecteurDict.IdxMax
  iLB = _VecteurDict.IdxMin
    
  Do 
    i = (iUB + iLB) \ 2
    If _TextComp(_VecteurDict.getItem(i).key, skey) = identique Then
      _FMT_ArrayHasKey() = True
      'iLB = iUB + 1
      Exit Function
    ElseIf _TextComp(_VecteurDict.getItem(i).key, skey) = apres Then
      iUB = i - 1
    Else
      iLB = i + 1
    End If
  Loop While iUB >= iLB
  
Exit_Function:
	On error resume next
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Function
End Function

' #FUNCTION# ==================================================================
' Name...........: _FMT_IndexOfKey
' Description ...: L'index de la clé dans le vecteur trié.
' Parameters ....: 
' Syntax ........: _FMT_IndexOfKey(skey)
' Return values .: Long : 
'					Success : 
'					Error : -1 si la clé n'est pas trouvée
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......: Voir aussi _FMT_IndexInArray qui calcul l'index qu'une clé 
					'devrait avoir pour trouver sa place dans le vecteur.
' Related .......:
' Link ..........:
' Example .......: 
Private Function _FMT_IndexOfKey(skey As String) As Long
  Dim i   As Integer 
  Dim iUB As Integer
  Dim iLB As Integer

	On local Error Goto Erreur
	
  _FMT_IndexOfKey = -1
  if _VecteurDict.EstVide Then Exit Function
  
  iUB = _VecteurDict.IdxMax
  iLB = _VecteurDict.IdxMin
  Do 
    i = (iUB + iLB) \ 2
    If _TextComp(_VecteurDict.getItem(i).key, skey) = identique Then
      _FMT_IndexOfKey() = i
      'iLB = iUB + 1
      Exit Function
    ElseIf _TextComp(_VecteurDict.getItem(i).key, skey) = apres Then
      iUB = i - 1
    Else
      iLB = i + 1
    End If
  Loop While iUB >= iLB
 
Exit_Function:
	On error resume next
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Function
End Function

' #FUNCTION# ==================================================================
' Name...........: _FMT_GetItem
' Description ...: 
' Parameters ....: 
' Syntax ........: _FMT_GetItem(skey)
' Return values .: Variant
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Private Function _FMT_GetItem(sKey As String) As Variant
  Dim i   As Integer 
  Dim iUB As Integer
  Dim iLB As Integer
  
  On local Error goto Erreur
  
  if _VecteurDict.EstVide Then Exit Function
  
  iUB = _VecteurDict.IdxMax
  iLB = _VecteurDict.IdxMin
  Do 
    i = (iUB + iLB) \ 2
    If _TextComp(_VecteurDict.getItem(i).key, sKey) = identique Then
      _FMT_GetItem = _VecteurDict.getItem(i).Item
      'iLB = iUB + 1
      Exit Function
    ElseIf _TextComp(_VecteurDict.getItem(i).key, sKey) = apres Then
      iUB = i - 1
    Else
      iLB = i + 1
    End If
  Loop While iUB >= iLB 
 
 	If (iUB < ILB) Then 
		Err = 960 'Clé introuvable
	EndIf
	
Exit_Function:
	On error resume next	
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)	
	Stop
	Resume Exit_Function 
End Function

' #FUNCTION# ==================================================================
' Name...........: _FMT_InsertSortedArray
' Description ...: Insert a string in an array in formatted order.n% is the number 
					'of items in the array. The array is assumed to have room for 
					'one more item. Return True if s$ is inserted into the array, 
					'and False if the item is not inserted into the array. If it 
					'is not inserted,this means that it was already there 
					'(so it avoids duplicates).
' Parameters ....: 
' Syntax ........: _FMT_InsertSortedArray(v, skey)
' Return values .: Boolean
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Private Function _FMT_InsertSortedArray(ByVal v As Variant, ByVal sKey As String) As Boolean

  Dim duo As Object
  Dim idx As Long
  
  On local Error Goto Erreur
  
  _FMT_InsertSortedArray = false
  If Len(skey) = 0 Then exit Function
  
  duo = New TDuolet
  duo.key = skey
  duo.item = v
  
  'recherche de l'index que devrait avoir le nouvel élement après son insertion
  idx = _FMT_IndexInArray(sKey)
  
  'Cas 1 : Ajout en fin de vecteur
  If (idx >= _VecteurDict.NBElements) Then    
    _VecteurDict.Ajouter(duo)
    _FMT_InsertSortedArray = True
    Exit Function
  End If
  
  'Cas 2 : Nouvel élément doublon, il n'est pas inséré. 
  If _TextComp(_VecteurDict.getItem(idx).key, sKey) = identique Then
    _FMT_InsertSortedArray = False
    Exit Function
  End If
  
  'Cas 3 : Insertion du nouvel élement à l'indice i
  _VecteurDict.Inserer(idx, duo)
  _FMT_InsertSortedArray = True
 
 Exit_Function:
	On error resume next
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Function
End Function


' #FUNCTION# ==================================================================
' Name...........: _FMT_IndexInArray
' Description ...: Find a string in an array. n% is the number of items in the array.
					'Return the index where the string should be.
' Parameters ....: 
' Syntax ........: _FMT_IndexInArray(skey)
' Return values .: Integer
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Private Function _FMT_IndexInArray(sKey) As Integer
  Dim i   As Integer 
  Dim iUB As Integer
  Dim iLB As Integer
 
 On local Error Goto Erreur
 
  _FMT_IndexInArray() = _VecteurDict.Taille
  If _VecteurDict.EstVide Then Exit Function

  iUB = _VecteurDict.IdxMax
  iLB = _VecteurDict.IdxMin
  Do 
    i = (iUB + iLB) \ 2
    If _TextComp(_VecteurDict.getItem(i).key, sKey) = identique Then
      _FMT_IndexInArray() = i
      Exit Function
      'iLB = iUB + 1
    ElseIf _TextComp(_VecteurDict.getItem(i).key, sKey) = apres Then
      iUB = i - 1
    Else
      iLB = i + 1
    End If
  Loop While iUB >= iLB
  
  _FMT_IndexInArray() = iLB
 
Exit_Function:
	On error resume next
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Function
End Function

Rem ***************************************************************************
Rem
Rem METHODES PUBLIQUES
Rem
Rem ***************************************************************************

' #FUNCTION# ==================================================================
' Name...........: RangDe
' Description ...: 
' Parameters ....: 
' Syntax ........: RangDe(skey)
' Return values .: Long
'					-1 si la clé n'est pas trouvée.
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
'Resultat = -1 si l'objet n'est pas trouvé
Public Function RangDe(key As String) As Long
	RangDe = _FMT_IndexOfKey(key)
End Function

' #FUNCTION# ==================================================================
' Name...........: Actualiser
' Description ...: 
' Parameters ....: 
' Syntax ........: Actualiser(skey, false)
' Return values .: Actualise la valeur d'une clé. Si la clé n'est pas trouvée, 
					'la valeur n'est simplement pas actualisée.
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Public Sub Actualiser(key As String, value As Variant)
	Dim Idx As Long
	Dim duo As variant
	
	On local Error Goto Erreur 
	
	Idx = RangDe(key)
	
	If Idx >= 0 Then 
		duo = _VecteurDict.getItem(Idx)
		duo.item = value
	EndIf

Exit_Sub:
	On error resume next
	Exit SUb
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Sub
End Sub

' #FUNCTION# ==================================================================
' Name...........: Contient
' Description ...: 
' Parameters ....: 
' Syntax ........: Contient
' Return values .: Boolean
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Public Function Contient(skey As String) As Boolean
	
	On error goto Erreur
	
	Contient = _FMT_ArrayHasKey(skey) '_FMT_ArrayHasKey(key) 
	
Exit_Function:
	On error resume next
	Exit Function
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Function
End Function

' #FUNCTION# ==================================================================
' Name...........: Item
' Description ...: Recherche un item selon sa clé. Si l'item n'existe pas une 
'					exception est déclenchée et traitée par _FMT_GetItem(key)	
' Parameters ....: 
' Syntax ........: Item(key)
' Return values .: Variant
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Public Function Item(key As String) As Variant
	Item = _FMT_GetItem(key)	
End Function

' #PROCEDURE# ==================================================================
' Name...........: Ajouter
' Description ...: 
' Parameters ....: 
' Syntax ........: Ajouter(key, item)
' Return values .: 
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Public Sub Ajouter(key As String, ByVal item As Variant)
	
	On error goto Erreur
	
	If EstVide(key) Then
		Err = 12
	EndIf
	
	If not _FMT_InsertSortedArray(item, key) Then
		'L'Etiquette est déjà définie
		Err = 959
	EndIf

Exit_Sub:
	On error resume next
	Exit SUb
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Sub
End Sub

' #PROCEDURE# ==================================================================
' Name...........: Retirer
' Description ...: 
' Parameters ....: 
' Syntax ........: Retirer(skey)
' Return values .: 
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Public Sub Retirer(skey As String)
	Dim idx As Long
	Dim duo As Object
	
	On local error goto Erreur
	
	idx = _FMT_IndexOfKey(skey)	
	if idx = -1 Then Exit Sub	
	duo = _VecteurDict.getItem(idx)
	_VecteurDict.Retirer(idx)
	Erase duo

Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	SgtDebug.Catch(Name)
	Resume Exit_Sub
End Sub

' #PROCEDURE# ==================================================================
' Name...........: Trace
' Description ...: 
' Parameters ....: 
' Syntax ........: Trace(oDebug, Visiteur)
' Return values .: 
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Public Function Trace(oDebug As Object)
	_VecteurDict.Trace(oDebug)
End Function

' #PROCEDURE# ==================================================================
' Name...........: Vider
' Description ...: 
' Parameters ....: 
' Syntax ........: Vider()
' Return values .: 
' Author ........: Patrick 
' Modified.......: 01/02/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......:
Public Sub Vider()
	Dim i As Long
	
	'Chaque entrée (item) du dictionnaire est un objet TDuolet créé par la 
	'méthode AJouter du dicitonnaire. Il revient donc au diictionnaire de les 
	'supprimer.
	For i = _VecteurDict.IdxMax to _VecteurDict.IdxMin Step -1
		Erase _VecteurDict.getItem(i)
	Next
	_VecteurDict.Vider()
End Sub

' #FUNCTION# ==================================================================
' Name...........: Main
' Description ...: 
' Parameters ....: 
' Syntax ........: Main
' Return values .: 
' Author ........: Patrick 
' Modified.......: 06/01/2018
' Remarks .......:
' Related .......:
' Link ..........:
' Example .......: 
Sub Main()
	Dim oDict1, oDict2 As TDictionnaire

	On local error goto Erreur
	
	oDict1 = New TDictionnaire
	oDict2 = New TDictionnaire

	MsgBox oDict1.Contient("oDict2.3")
	
	oDict1.Titre = "oDict1"
	oDict2.Titre = "oDict2"
	
	oDict1.Ajouter("oDict1.1", 1)
	oDict1.Ajouter("oDict1.4", 4)
	oDict1.Ajouter("oDict1.2", 2)
	oDict1.Ajouter("oDict1.3", 3)

	oDict2.Ajouter("oDict2.1", 1)
	oDict2.Ajouter("oDict2.2", 4)
	oDict2.Ajouter("oDict2.3", 2)
	oDict2.Ajouter("oDict2.4", 3)
	
	
	MsgBox oDict1.RangDe("oDict1.4")
	MsgBox oDict1.Contient(4034)
	Dim v1, v2 As boolean
	v1 = oDict1.Item("toto")

	
	MsgBox oDict2.Item("oDict2.4")
	MsgBox oDict2.Contient("oDict2.3")	
	oDict2.Retirer("oDict2.3")
	MsgBox oDict2.Contient("oDict2.3")
	MsgBox oDict2.Premier
	MsgBox oDict2.Dernier
	
	Erase oDict1
	Erase oDict2

Exit_Sub:
	On error resume next
	Exit Sub
Erreur:
	TraceError("ERROR", Err, Name, Erl)
	Resume Exit_Sub
End Sub

Dernière modification par micmac le 05 oct. 2018 13:50, modifié 2 fois.
Raison : Ajout de [Résolu]
LibreOffice Version 7.4.6.2
Utilisation sur plusieurs systèmes d'exploitation (nomadisme sous windows et Linux)
Avatar de l’utilisateur
Dude
IdOOle de la suite
IdOOle de la suite
Messages : 25143
Inscription : 03 mars 2006 08:45
Localisation : 127.0.0.1
Contact :

Re: [Basic] A propos des mutex et des singletons ...

Message par Dude »

Salut,

Pourrait-on avoir un exemple concret d'utilisation et surtout avec quelle application ?
Comme que le Basic reste mono-tâche, je ne vois pas l'intérêt de gérer de la synchronisation.
gelinp
Membre OOrganisé
Membre OOrganisé
Messages : 58
Inscription : 12 mars 2011 21:40

Re: [Basic] A propos des mutex et des singletons ...

Message par gelinp »

OO Basic serait monotâche ... Pourquoi pas ... Mais le gestionnaire d'évènement UNo lui ne semble pas l'être, et j'observe bien des problèmes de réentrance sur mes macros OObasic pour gérer les évènements de mes formulaires, et aussi des évènements interrompus et doublés par d'autres évènements !

Par exemple l'extrait de log suivant avec mon Mutex désactivé, qui montre un appel d'évènement interrompu par un autre qui le double... :

Code : Tout sélectionner

======================================================================
ActualiserEtatInterface(DEBUT)"
"09/03/2018 14:58:09 [FormNoticeBibliographiqueImpl] 
////////////////////////////////////////////////////////////////////////////////////////////////////////
ICI L'EVENEMENT "ActualiserEtatInterface" EST INTERROMPU PAR L'EVEMENT "FORMRECORDSApresLeChangementDEnregistrement" (DECALE CI-DESSOUS ...)
////////////////////////////////////////////////////////////////////////////////////////////////////////
			======================================================================
			FORMRECORDSApresLeChangementDEnregistrement(DEBUT)"
			"09/03/2018 14:58:09 [TUnoEvent] 
			............................................................
			Chrono.............. : 09/03/2018 14:58:09
			Source Name......... : FormRecords
			Uno Source Type .... : FormWiew
			A2B Source Type..... : CONTROL
			............................................................"
			"09/03/2018 14:58:09 [FormNoticeBibliographiqueImpl] Evenement redondant : on quitte !"
			"09/03/2018 14:58:09 [FormNoticeBibliographiqueImpl] FORMRECORDSApresLeChangementDEnregistrement(FIN)"
			"09/03/2018 14:58:09 [TUnoEvent] 			
////////////////////////////////////////////////////////////////////////////////////////////////////////
RETOUR A L'EVENEMENT "ActualiserEtatInterface" INTERROMPU ...
////////////////////////////////////////////////////////////////////////////////////////////////////////
............................................................
Chrono.............. : 09/03/2018 14:58:09Remarque : le retour à l'évènement interrompu montre deux chronos bien différents :
Source Name......... : FORM_NOTICES_BIBLIOGRAPHIQUES
Uno Source Type .... : FormWiew
A2B Source Type..... : FORM
............................................................"
"09/03/2018 14:58:11 [FormNoticeBibliographiqueImpl] ActualiserEtatInterface(FIN)"
"09/03/2018 14:58:12 [FormNoticeBibliographiqueImpl] ActualiserEtatInterface(FIN)"
Remarque : le retour à l'évènement interrompu montre deux chronos bien différents :
1. Chrono.............. : 09/03/2018 14:58:09 (7eme ligne en partant du bas)
2. 09/03/2018 14:58:11 [FormNoticeBibliographiqueImpl] ActualiserEtatInterface(FIN)" (2eme ligne en partant du bas)

Il y a 2 secondes entre ces deux évènements qui semblent pourtant apparaître dans une parfaite continuité d'écriture et donc de traitement dans mon fichier de Log.

Mon explication ... : L'évènement n°1 semble bien avoir eu lieu avant l'interruption du premier évènement, mais il n'aurait simplement pas été affiché tout de suite. L'évènement n°2 semble bien avoir eu lieu après l'interruption et il serait affiché immédiatement par la méthode Trace de mon objet TDebug...

Ce que je comprends de ce log c'est qu'une macro OOBasic utilisée comme gestionnaire d'évènement serait une "call-back-function", c'est à dire une fonction rappelée par l'application Uno écrite en C+ (Base), et cette application C++ Uno est bien une application multitâche ... Donc ma macro ne serait pas executée dans le contexte monotâche d'une application purement basic car une telle application ne serait tout simplement pas capable de gérer une application évènementielle graphique. Cela étant dit je ne comprends pas (encore) très bien le contexte de la mémoire car l'appel callback de ma macro donne bien accès aux variables globales de mon application qui est sans doute dans un autre thread... Sans doute cet accès serait géré par l'application Base elle même puisque les threads des évènements et de mon application sont crées et gérés par elle même ...
LibreOffice Version 7.4.6.2
Utilisation sur plusieurs systèmes d'exploitation (nomadisme sous windows et Linux)
Avatar de l’utilisateur
Dude
IdOOle de la suite
IdOOle de la suite
Messages : 25143
Inscription : 03 mars 2006 08:45
Localisation : 127.0.0.1
Contact :

Re: [Basic] A propos des mutex et des singletons ...

Message par Dude »

Ce n'est pas ce que j'appelle :
Dude a écrit :un exemple concret d'utilisation
A savoir :
  1. insérer dans le corps du message le code de la macro exposant le problème
  2. joindre un document explicatif intégrant cette macro avec les données de départ (feuille1) et le résultat à obtenir (feuille2)
  3. fournir un mode pas-à-pas permettant de reproduire ce qui a été fait ou ce cherché à faire pour arriver au problème
  4. ajouter des copies écran (situation avant / après) si cela permet de mieux comprendre
gelinp a écrit : pour gérer les évènements de mes formulaires
Balise de titre à modifier pour [Base] dans ce cas.
gelinp
Membre OOrganisé
Membre OOrganisé
Messages : 58
Inscription : 12 mars 2011 21:40

Re: [Basic] A propos des mutex et des singletons ...

Message par gelinp »

Désolé, je n'ai pas le temps de créer une application spécifique avec une base de donnée pour reproduire ce que tout le monde aura observé comme moi, à savoir que c'est Uno qui génère les évènements, et non le langage Basic...

En particulier il est question des mutex dans la page de présentation de VCL (Visuals Components Library) utilisée pour les formulaires Base comme les autres interfaces. Mais aucune explication pour une utilisation depuis un gestionnaire d'évènement en Basic...

Il existe bien aussi une page dans la documentation de OpenOffice pour présenter le modèle multithreading, mais tout cela est très incomplet en particulier encore pour gérer un mutex avec une macro Basic ...
LibreOffice Version 7.4.6.2
Utilisation sur plusieurs systèmes d'exploitation (nomadisme sous windows et Linux)
Répondre