VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CTcpManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
' *********************************************************************
'* CLASS Manager utilizzabile per connettere due applicazioni differenti via IP
'* <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">
'*  Il manager funge da Server su porta TCP per ricevere i messaggi.
'*  Il manager sfrutta l'invio di messaggi TCP per spedire i messaggi.
'*  Il manager stabilisce un metodo per l'identificazione del Manager _
    in modo che il nome <I>getAddress()</I> del Manager consenta di identificarlo in una rete di _
    computer.
'*  Il manager stabilisce altresì un formato di spedizione dei pacchetti TCP in modo che _
    il destinatario possa comprenderlo ricreando a sua volta l'CEnvelope.
'*  Ad ogni richiesta di invio di un messaggio il manager legge la lista di connessioni aperte _
    per verificare se conosce il destinatario, altrimenti crea una nuova connessione.
'*  Ad ogni richiesta di connessione dall'esterno, questa viene recuperata indicando che _
    si conosce già il mittente.
'*  <B>Importante:</B> le socket vanno chiuse esplicitamente altrimenti il GarbageCollector di _
    Visual Basic le lascia aperte indefinitamente causando spiacevoli errori ed inconvenienti!
'*  Usare il metodo <B>Destroy</B> per pulire tutto.
'* </DIV>
' *********************************************************************
Option Explicit
Implements IMsgManager

'* Variabile contenente il valore della proprietà omonima dell'oggetto
Private mDispatcher     As IDispatcher
'* Variabile contenente il valore della proprietà omonima dell'oggetto
Private mManagers       As Collection
'* Variabile contenente il valore della proprietà omonima dell'oggetto
Private mHostData       As CRemoteHost
'* Socket Server usata per accettare le connessioni dall'esterno
Private WithEvents mServerSocket   As CSocket
Attribute mServerSocket.VB_VarHelpID = -1

'*  Porta di default per l'apertura di una nuova Socket server
Private Const mDEFAULT_PORT As Long = 5230
Private mstrLastError           As String

'* Indica che l'indirizzo del manager potrebbe essere cambiato
Public Event OnAddressChange()

'* Descrizione dell'ultimo errore
Public Property Get LastError() As String
    LastError = mstrLastError
End Property
'* Descrizione dell'ultimo errore
Private Property Let LastError(newValue As String)
    mstrLastError = newValue
End Property

'* Gestisce l'errore
Private Sub GenerateError(Description As String, Optional Number As Long = vbObjectError)
    LastError = Description
End Sub

'* Gestisce l'errore
Private Sub GenerateErrorGenerico(Procedure As String)
    Call GenerateError("Errore non previsto in " & Procedure & vbCrLf & Err.Description, Err.Number)
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

'* Indirizzo logico del manager. Identifica il manager specificandolo in maniera univoca
'* L'indirizzo viene generato automaticamente alla creazione dell'oggetto.
Public Function getAddress() As String
    getAddress = mHostData.toString()
End Function

'* Porta di ascolto per il manager
Public Function getPort() As Long
    getPort = mHostData.Port
End Function

'* Porta di ascolto per il manager
Public Function setPort(newValue As Long)
    mHostData.Port = newValue
    RaiseEvent OnAddressChange
End Function

'* Indirizzo IP di ascolto per il manager
Public Function getLocalIpAddress() As String
    getLocalIpAddress = mHostData.IP.toString()
End Function

'* Porta di ascolto per il manager
Public Function setLocalIpAddress(newValue As String)
    mHostData.IP.fromString newValue
    RaiseEvent OnAddressChange
End Function

'* La funzione ignora il MngAddress
'* Restituisce False se il manager non è nell'elenco dei manager registrati.
'* Se il manager destinazione è vuoto o è l'oggetto stesso, restituisce False se il Dispatcher non è stato specificato.
Public Function Send(Env As CEnvelope, ByVal MngAddress As String) As Boolean
Dim Index               As Long
Dim PeerManagerSlave    As CTcpManagerSlave
    
    Send = False
    'Informazioni di dispatching
    If Env.TraceRoute Is Nothing Then Set Env.TraceRoute = New CEnvelopeTrace
    Env.TraceRoute.RemoteMsgManagerAddress = Me.getAddress()
    'Controllo se sono io
    If (MngAddress = vbNullString) Or (MngAddress = getAddress()) Then
        If Not Dispatcher Is Nothing Then
            'Informazioni di dispatching
            Set Env.TraceRoute.LocalMsgManager = Me
            Send = Dispatcher.msgArrived(Env)
        End If
    Else
        Set PeerManagerSlave = FindPeerServer(MngAddress)
        If PeerManagerSlave Is Nothing Then
            'Ne creo uno tentando di connettermi al pari
            Set PeerManagerSlave = New CTcpManagerSlave
            Debug.Print Me.getAddress & " Try to Connect to " & MngAddress
            If Not PeerManagerSlave.StartConnecting(MngAddress, Me) Then
                Debug.Print Me.getAddress & " Cannot Connect to " & MngAddress & "due to " & PeerManagerSlave.LastError
                Call GenerateError("Error in Send:" & vbCrLf & PeerManagerSlave.LastError)
                Exit Function
            End If
            'Lo aggiungo alla lista
            Call mManagers.Add(PeerManagerSlave, MngAddress)
        End If
        'Inviare all'host indicato
        Debug.Print "Socket state=" & PeerManagerSlave.Socket.State
        Debug.Print Me.getAddress & " Send to " & MngAddress
        
        Send = PeerManagerSlave.SendTCPMessage(Env)
    End If
End Function

'* Recupera un elemento da una collection se esiste, altrimenti restituisce Nohting
Private Function FindPeerServer(MngAddress As String) As CTcpManagerSlave
On Error GoTo ErrorCatch
    Set FindPeerServer = mManagers.Item(MngAddress)
Exit Function
ErrorCatch: Set FindPeerServer = Nothing
End Function

'* Funzione chiamata dagli slave in ascolto quando arriva un messaggio
Friend Sub MsgArrivedFromSlave(Env As CEnvelope, RemoteMsgManagerAddress As String)
    If Not Dispatcher Is Nothing Then
        'Informazioni di dispatching
        If Env.TraceRoute Is Nothing Then Set Env.TraceRoute = New CEnvelopeTrace
        Set Env.TraceRoute.LocalMsgManager = Me
        Env.TraceRoute.RemoteMsgManagerAddress = RemoteMsgManagerAddress
        Call Dispatcher.msgArrived(Env)
    End If
End Sub

'* Indica il numero di manager conosciuti.
Public Function getKnownManagerNumber() As Long
    getKnownManagerNumber = mManagers.Size
End Function

'* Permette di cominciare ad ascoltare sulla porta indicata i messaggi in ingresso
Public Function StartListenForMessages() As Boolean
    Set mServerSocket = New CSocket
    mServerSocket.LocalHost.Port = mHostData.Port
    Call mServerSocket.LocalHost.IP.fromString(mHostData.IP.toString())
    StartListenForMessages = mServerSocket.OpenServerConnection()
End Function

'* Permette di cominciare ad ascoltare sulla porta indicata i messaggi in ingresso
Public Sub StopListenForMessages()
    If Not mServerSocket Is Nothing Then
        mServerSocket.CloseSocket
        Set mServerSocket = Nothing
    End If
End Sub

Private Sub Class_Initialize()
    Set mHostData = New CRemoteHost
    mHostData.Port = mDEFAULT_PORT
    Set mManagers = New Collection
End Sub

'* <B>IMPORTANTE</B>: Funzione che distrugge l'oggetto.
'* E' importante chiamare questa funzione perché il Garbage Collector di Visual Basic _
ritarda molto a pulire le risorse non più usate a causa dei riferimenti circolari.
Public Sub Destroy()
Dim PeerServer  As CTcpManagerSlave
    On Error Resume Next
    'Server
    If Not mServerSocket Is Nothing Then mServerSocket.CloseSocket
    Set mServerSocket = Nothing
    'Peers
    If Not mManagers Is Nothing Then
        For Each PeerServer In mManagers
            PeerServer.CloseSocket
            mManagers.Remove PeerServer
            Set PeerServer = Nothing
        Next
        Set mManagers = Nothing
    End If
    'Altro
    Set mDispatcher = Nothing
    Set mHostData = Nothing
End Sub

Private Sub Class_Terminate()
    Call Destroy
End Sub

Private Property Set IMsgManager_Dispatcher(RHS As IDispatcher)
    Set Dispatcher = RHS
End Property

Private Property Get IMsgManager_Dispatcher() As IDispatcher
    Set IMsgManager_Dispatcher = Dispatcher
End Property

Private Function IMsgManager_getAddress() As String
    IMsgManager_getAddress = getAddress()
End Function

Private Function IMsgManager_Send(Env As CEnvelope, MngAddress As String) As Boolean
    IMsgManager_Send = Send(Env, MngAddress)
End Function

Private Sub mServerSocket_OnConnectionRequest(ByVal requestID As Long)
    Dim newSocket   As New CSocket
    Dim PeerManagerSlave    As CTcpManagerSlave
    If newSocket.Accept(requestID) Then
        'Ne creo uno tentando di connettermi al pari
        Set PeerManagerSlave = New CTcpManagerSlave
        Debug.Print newSocket.RemoteHost.toString; " Try to Connect to me = " & Me.getAddress
        Call PeerManagerSlave.StartListening(newSocket, Me, newSocket.RemoteHost.toString())
        'Lo aggiungo alla lista
        Call mManagers.Add(PeerManagerSlave, newSocket.RemoteHost.toString)
    End If
End Sub