VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CDynamicStub"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
' *********************************************************************
'* CLASS Stub di base con chiamate dinamiche funzionante per una qualsiasi classe
'* <BR/>Autore: <B>Giorgio Bernardi</B>
'* E-Mail: <A HREF="mailto:giorgio.bernardi@studio.unibo.it">Giorgio.Bernardi@studio.unibo.it</A>
'* Data  : Settembre 2004
'* <DIV CLASS="ClassDescription">
'*  Questo Stub può essere utilizzato per ogni oggetto in quanto contiene chiamate _
    standard grazie all'utilizzo del costrutto linguistico di Visual Basisc <I>ParamArray</I>.
'*  Creare una istanza di questa classe e chiamare la funzione <B>CallRemoteFunction</B> specificando _
    i parametri necessari.
'*  E' possibile usare la classe indicando di non attendere il risultato delle funzioni e poi _
recuperare il risultato stesso in modalità polling tramite le funzioni <B>IsResultArrived</B> e _
<B>GetResult</B>.
'* </DIV>
' *********************************************************************
Option Explicit

Implements IReceiver    'Necessario per le funzioni
Implements ISender      'Necessario

'* Dispatcher al quale inviare le richieste
Private mDispatcher             As IDispatcher
'* Indirizzo di ricezione del manager remoto
Private mstrRemoteMsgManagerAddress   As String
'* Indirizzo di ricezione dello Skeleton remoto
Private mstrSkeletonObjectID    As String
'* Collezione dei risultati delle funzioni attualmente disponibili
Private Risultati               As Collection
'* Variabile contenente il valore della proprietà omonima
Private mstrObjectID            As String
'* Milli-Secondi dopo il quale scatterà il timeout se non giunge il risultato della chiamata a funzione
Private mlngTimeOutMilliSeconds      As Long

'* TimeOut di default applicato all'inizializzazione della classe
Private Const DEFAULT_TIMEOUT_MILLI_SECONDS = 10000

Private Sub Class_Initialize()
    Set Risultati = New Collection
    Me.TimeOutMilliSeconds = DEFAULT_TIMEOUT_MILLI_SECONDS
End Sub

'* Restituisce l'identificativo univoco all'interno della applicazione remota dello skeleton di destinazione
Public Property Get RemoteSkeletonID() As String
    RemoteSkeletonID = mstrSkeletonObjectID
End Property

'* Restituisce l'identificativo univoco all'interno della applicazione remota dello skeleton di destinazione
Public Property Let RemoteSkeletonID(Value As String)
    mstrSkeletonObjectID = Value
End Property

'* Indirizzo di ricezione del manager remoto
Public Property Get RemoteMsgManagerAddress() As String
    RemoteMsgManagerAddress = mstrRemoteMsgManagerAddress
End Property

'* Indirizzo di ricezione del manager remoto
Public Property Let RemoteMsgManagerAddress(Value As String)
    mstrRemoteMsgManagerAddress = Value
End Property

'* Secondi dopo il quale scatterà il timeout se non giunge il risultato della chiamata a funzione
'* <B>ATTENZIONE:</B> in questa implementazione Visual Basic viene usata una precisione al centesimo di secondo, non al millesimo! Impostare valori multipli di 10!
Public Property Get TimeOutMilliSeconds() As Long
    TimeOutMilliSeconds = mlngTimeOutMilliSeconds
End Property

'* Secondi dopo il quale scatterà il timeout se non giunge il risultato della chiamata a funzione
'* <B>ATTENZIONE:</B> in questa implementazione Visual Basic viene usata una precisione al centesimo di secondo, non al millesimo! Impostare valori multipli di 10!
Public Property Let TimeOutMilliSeconds(Value As Long)
    mlngTimeOutMilliSeconds = Value
End Property

'* Restituisce l'identificativo univoco all'interno di questa applicazione dell'oggetto
Public Property Get StubID() As String
    StubID = mstrObjectID
End Property

'* Restituisce l'identificativo univoco all'interno di questa applicazione dell'oggetto
Public Property Let StubID(Value As String)
    mstrObjectID = Value
End Property

'* Verifica se è arrivato il risultato della richiesta
Public Function IsResultArrived(ProcedureInstanceID As String) As Boolean
On Error GoTo ErrorCatch
    If Not Risultati.Item(ProcedureInstanceID) Is Nothing Then IsResultArrived = True
ErrorCatch:
End Function

'* Restituisce il risultato della invocazione remota.
'* Restituisce Nothing se il risultato non è ancora giunto.
'* Se il risultato è giunto lo restituisce e lo rimuove dalla collezione dei risultati arrivati
Public Function GetResult(ProcedureInstanceID As String) As CFunctionResult
On Error GoTo ErrorCatch
Dim Risultato   As CFunctionResult
    Set GetResult = Nothing 'In caso di errore
    If IsResultArrived(ProcedureInstanceID) Then
        Set Risultato = Risultati.Item(ProcedureInstanceID)
        Call Risultati.Remove(ProcedureInstanceID)
        Set GetResult = Risultato
    End If
ErrorCatch:
End Function

'* Indica che è arrivato il risultato della richiesta
'* Registra il risultato fra quelli disponibili
Private Sub ResultArrived(Result As CFunctionResult)
    Call Risultati.Add(Result, Result.InstanceID)
End Sub

'* Identificativo dell'oggetto che si occuperà di indirizzare i messaggi ai destinatari
Public Property Get Dispatcher() As IDispatcher
    Set Dispatcher = mDispatcher
End Property

'* Identificativo dell'oggetto che si occuperà di indirizzare i messaggi ai destinatari
Public Property Set Dispatcher(dsptchr As IDispatcher)
    Set mDispatcher = dsptchr
End Property

'* Funzione da chiamare per contattare lo Skeleton remoto.
'* Impostare tutti i parametri della funzione da chiamare nella variabile <I>ParamArray</I>
'* E' necessario indicare se attendere o meno il risultato della computazione remota. Questo _
è importante sia nel caso in cui il metodo chiamato sia semplicemente una procedura senza ritorno, _
sia nel caso in cui non si desideri attendere il risultato ma semplicemente andarlo a pescare dopo _
eseguendo un polling sulla funzione IsResultAvailable.
'* <B>Nota:</B> se non si desidera attendere il risultato, la funzione restituisce il nome univoco _
della richiesta di procedura remota necessario per eseguire successivamente il polling del risultato.
Public Function CallRemoteFunction(MethodName As String, HoldOnForResult As Boolean, ParamArray Arguments() As Variant)
Dim Procedure           As New CProcedure
Dim i                   As Long

    'Creazione delle informazioni sul metodo da chiamare
    With Procedure
        .Name = MethodName
        For i = 0 To UBound(Arguments)
            .AddParam Utilities.CreateCValue(Arguments(i))
        Next i
    End With
    'Invio della richiesta
    If Not Dispatcher.Send(Procedure.toEnvelope(Me, RemoteSkeletonID), RemoteMsgManagerAddress) Then
        Call Utilities.RaiseSMomException(UnKnownSMomException, "SMom.CDynamicStub", "Dispatcher couldn't Send message")
        Exit Function
    End If
    'Se devo attendere il risultato...
    If HoldOnForResult Then
        CallRemoteFunction = HoldResult(Procedure.InstanceID, Me.TimeOutMilliSeconds)
    Else    'Restituisco l'InstanceID
        CallRemoteFunction = Procedure.InstanceID
    End If
End Function

'* Chiamare questa procedura se si desidera attendere il risultato della chiamata a funzione remota precedentemente effettuata.
Public Function HoldResult(ByVal ProcedureInstanceID As String, ByVal TimeOutS As Long)
Dim IntialTimer         As Single
Dim Risultato           As CFunctionResult
    'In Vb non riesco a fare altro che attendere con un ciclo
    'NOTA: il controllo sul timeout fallisce (prima) nei pressi della mezzanotte...
    'Uso Abs() proprio per far si che riesca altrimenti non passerebbe mail
    IntialTimer = Timer
    Do Until (Me.IsResultArrived(ProcedureInstanceID) Or (Abs(CLng((Timer - IntialTimer) * 1000)) > TimeOutS))
        DoEvents
    Loop
    Set Risultato = GetResult(ProcedureInstanceID)
    If Not Risultato Is Nothing Then
        If Risultato.IsValid Then   'Raccolgo il risultato e lo restituisco
            HoldResult = Risultato.FunctionResult.toVariant()
        ElseIf Not Risultato.FunctionResult Is Nothing Then
            Call Utilities.RaiseSMomException(RemoteException, "SMom.CDynamicStub", "RemoteException description:" & vbCrLf & _
                Risultato.FunctionResult.getActualValueToString())
        Else    'Errore non specificato!
            Call Utilities.RaiseSMomException(UnKnownRemoteException, "SMom.CDynamicStub")
        End If
    Else    'TimeOut!
        Call Utilities.RaiseSMomException(TimeOutExpiredException, "SMom.CDynamicStub", "Not found Result for Request:" & ProcedureInstanceID)
    End If
End Function

Private Sub Class_Terminate()
Dim Obj As Object
    'Ripulisco tutto
    On Error Resume Next
    For Each Obj In Risultati
        Risultati.Remove Obj
    Next
    Set Obj = Nothing
    'Dispatcher
    Set Dispatcher = Nothing
End Sub

Private Function IReceiver_getObjectID() As String
    IReceiver_getObjectID = StubID
End Function

Private Sub IReceiver_msgArrived(Env As SMom.CEnvelope)
    'Sono arrivati dei risultati
    Dim Risultato   As New CFunctionResult
    If Risultato.fromEnvelope(Env) Then
        Call ResultArrived(Risultato)
    End If
End Sub

Private Function ISender_getObjectID() As String
    ISender_getObjectID = StubID
End Function