Open Mash Cross Reference
mash/tcl/net/network.tcl

   # network.tcl --
   #
   #       FIXME: This file needs a description here.
   #
   # Copyright (c) 1996-2002 The Regents of the University of California.
   # All rights reserved.
   #
   # Redistribution and use in source and binary forms, with or without
   # modification, are permitted provided that the following conditions are met:
  #
  # A. Redistributions of source code must retain the above copyright notice,
  #    this list of conditions and the following disclaimer.
  # B. Redistributions in binary form must reproduce the above copyright notice,
  #    this list of conditions and the following disclaimer in the documentation
  #    and/or other materials provided with the distribution.
  # C. Neither the names of the copyright holders nor the names of its
  #    contributors may be used to endorse or promote products derived from this
  #    software without specific prior written permission.
  #
  # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
  # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  # ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
  # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
  # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
  # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  #
  # @(#) $Header: /usr/mash/src/repository/mash/mash-1/tcl/net/network.tcl,v 1.51 2004/01/21 01:09:04 aswan Exp $
  
  
  import AddressBlock MMG/mash ErrorWindow
  #provide Network
  
  
  Network set rtptv_compat_ 0
  
  #FIXME backward compat
  Class Network/IP -superclass Network
  Network/IP instproc init args {
          puts stderr "Network/IP called... change to Network"
          eval $self next $args
  }
  
  proc in_multicast addr {
          return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
  }
  
  Class NetworkLayer
  Class NetworkManager
  
  NetworkManager instproc graphics-init n {
          # some apps may instantiate multiple NetworkManagers.
          # in such a case, build layers window only for real
          # layered sessions and don't try to build more than one.
          if {$n == 1 || [winfo exists .l]} { return }
  
          $self instvar nchan_
          set nchan_ $n
  
          toplevel .l
          set k 0
          while { $k < $nchan_ } {
                  radiobutton .l.b$k -command "$self set-subscription-level $k" \
                                  -text "Level $k" \
                                  -variable nLayers -value $k
                  pack .l.b$k
                  incr k
          }
          wm withdraw .l
          bind . <l> {
                  if [winfo ismapped .l] {
                          wm withdraw .l
                  } else {
                          wm deiconify .l
                  }
          }
  }
  
  #
  # set level of subscription to layers 0 through n (inclusive of n)
  # n must be strictly less than the total number of layers
  #
  NetworkManager instproc set-subscription-level n {
          $self instvar agent_ nchan_ session_ net_
          $agent_ set_maxchannel $n
          $session_ set loopbackLayer_ [expr $n + 1]
  
          set i 0
          while { $i <= $n } {
                  $net_($i) enable
                  incr i
          }
          while { $i < $nchan_ } {
                  $net_($i) disable
                  incr i
          }
 
         #FIXME
         global nLayers
         set nLayers $n
 }
 
 NetworkLayer instproc init { session addr sport rport ttl channel } {
         $self next
         $self instvar session_ addr_ port_ ttl_ dn_ cn_ channel_ active_
         set addr_ $addr
         set port_ $rport
         set sport_ $sport
         set rport_ $rport
         set session_ $session
         set ttl_ $ttl
         set channel_ $channel
 
         # open the data network
         set dn_ [new Network]
         if { [$self get_option rtptvCompat] == 1 } {
                 $dn_ set rtptv_compat_ 1
         }
         
         set result [$dn_ open $addr_ $sport_ $rport_ $ttl_]
         if {$result == {0}} {
                 new ErrorWindow {Cannot open network connection.}
                 exit 1
         }
 
         # for the data sockets only, make sure we have
         # reasonably large send/recv buffers
         $dn_ large_buffers
 
         set bufsize [$self get_option netBufferSize]
         if { $bufsize != "" } {
                 if [catch {$dn_ recv_bufset $bufsize} msg] {
                         #puts stderr $msg
                         puts stderr "Could not set buffer size to $bufsize"
                 }
         }
 
         # open the control network
         set cn_ [new Network]
         if { [$self get_option rtptvCompat] == 1 } {
                 $cn_ set rtptv_compat_ 1
         }
         
         set result [$cn_ open $addr_ [expr $sport_ + 1] [expr $rport_ + 1] $ttl_]
         if {$result == {0}} {
                 new ErrorWindow {Cannot open network connection.}
                 exit 1
         }
 
         #FIXME loop back control messages for local rtp monitor
         $cn_ loopback 1
 
         # report the new Network objects to the Session/RTP/...
         $session_ data-net $dn_ $channel_
         $session_ ctrl-net $cn_ $channel_
 
         #FIXME start out inactive
         set active_ 0
         $dn_ drop-membership
         $cn_ drop-membership
         # when membership is dropped (socket closed), handlers must be unlinked
         $session_ data-net "" $channel_
         $session_ ctrl-net "" $channel_
 
         $self set tloss_ 0
 }
 
 NetworkLayer instproc destroy {} {
         $self instvar dn_ cn_
 
         if [info exists dn_] {
                 delete $dn_
         }
         if [info exists cn_] {
                 delete $cn_
         }
 
         $self next
 }
 
 
 NetworkLayer instproc data-net {} {
         return [$self set dn_]
 }
 
 NetworkLayer instproc ctrl-net {} {
         return [$self set cn_]
 }
 
 NetworkLayer instproc enable-send {} {
         $self instvar dn_ cn_ session_ channel_
         $session_ data-net $dn_ $channel_
         $session_ ctrl-net $cn_ $channel_
 }
 
 NetworkLayer instproc disable-send {} {
         $self instvar dn_ cn_ session_ channel_
         $session_ data-net "" $channel_
         $session_ ctrl-net "" $channel_
 }
 
 
 NetworkLayer instproc enable {} {
         $self instvar active_ dn_ cn_ session_ channel_
         if !$active_ {
                 set active_ 1
                 $dn_ add-membership
                 $cn_ add-membership
                 # FIXME relink the io channel in case the fd changes
                 $session_ data-net $dn_ $channel_
                 $session_ ctrl-net $cn_ $channel_
         }
 }
 
 NetworkLayer instproc disable {} {
         $self instvar dn_ cn_ active_ session_ channel_
         if $active_ {
                 set active_ 0
                 $dn_ drop-membership
                 $cn_ drop-membership
                 # when membership is dropped (socket closed), handlers must be unlinked
                 $session_ data-net "" $channel_
                 $session_ ctrl-net "" $channel_
         }
 }
 
 NetworkLayer instproc notify-loss {src} {
         $self instvar loss_ tloss_
         if ![info exists loss_($src)] {
                 set loss_($src) 0
         }
 
         set nloss [$src missing]
         incr tloss_ [expr $nloss - $loss_($src)]
         set loss_($src) $nloss
 }
 
 NetworkLayer instproc nlost {} {
         $self instvar tloss_
         return $tloss_
 }
 
 NetworkLayer instproc npkts {n} {
         #FIXME
         $self instvar agent_
         set npkts 0
         foreach s [$agent_ set sources_] {
                 set l [lindex [$s set layers_] $n]
                 incr npkts [$l set np_]
         }
         return $npkts
 }
 
 NetworkLayer instproc crypt { dc cc } {
         $self instvar dn_ cn_
         $dn_ crypt $dc
         $cn_ crypt $cc
 }
 
 NetworkManager instproc init { ab session agent } {
         $self next
         $self instvar session_ agent_ encrypt_ key_ fmt_
         set session_ $session
         set agent_ $agent
         set encrypt_ 0
         set key_ ""
         set fmt_ ""
         $self allocate $ab $session
 }
 
 NetworkManager instproc session-info {} {
         set net [$self data-net 0]
 
         set addr [$net addr]
         set rport [$net rport]
         set sport [$net sport]
         set ttl [$net ttl]
 
         if { $rport == $sport } {
                 set port $rport
         } else {
                 set port "$rport:$sport"
         }
 
         return "Dest: $addr   Port: $port   TTL: $ttl"
 }
 
 NetworkManager instproc allocate { ab session } {
         $self instvar nchan_ net_ mmg_
         if [info exists nchan_] {
                 set oldnchan $nchan_
         } else {
                 set oldnchan 0
         }
         set nchan_ 0
         while { $nchan_ < [$ab nchan] } {
                 set addr [$ab addr $nchan_]
                 set sport [$ab sport $nchan_]
                 set rport [$ab rport $nchan_]
                 set ttl [$ab ttl $nchan_]
                 if [info exists net_($nchan_)] {
                         delete $net_($nchan_)
                 }
                 set net_($nchan_) [new NetworkLayer $session $addr \
                                 $sport $rport $ttl $nchan_]
 
                 #FIXME
                 $self instvar agent_
                 $net_($nchan_) set agent_ $agent_
 
                 incr nchan_
         }
         set n $nchan_
         while {$n < $oldnchan} {
                 if [info exists net_($n)] {
                         delete $net_($n)
                 }
                 incr n
         }
 
         #XXX disable rtcp if using ssm
         #XXX if we're the source then we should still send
         # sender reports?
         set addr0 [$ab addr 0]
         if [string match "*@*" $addr0] {
                 $session send-rtcp 0
         }
 
         if [info exists mmg_] {
                 delete $mmg_
         }
 
         #FIXME
         $self set-subscription-level 0
 
         if {$nchan_ == 1} { return }
         if [$self yesno useLayersWindow] {
                 $self graphics-init $nchan_
         }
         if [$self get_option useRLM] {
                 #FIXME
                 set caddr ""
                 set mmg_ [new MMG/mash $self $caddr]
         }
 }
 
 
 NetworkManager instproc nchan {} {
         return [$self set nchan_]
 }
 
 NetworkManager instproc reset ab {
 #puts "$self ($class): reset $spec"
         $self instvar session_
         $self allocate $ab $session_
 }
 
 NetworkManager instproc data-net args {
         if { $args == "" } {
                 set k 0
         } else {
                 set k $args
         }
         $self instvar net_
         return [$net_($k) data-net]
 }
 
 NetworkManager instproc ctrl-net args {
         if { $args == "" } {
                 set k 0
         } else {
                 set k $args
         }
         $self instvar net_
         return [$net_($k) ctrl-net]
 }
 
 NetworkManager public loopback enable {
         $self instvar nchan_ net_
         set i 0
         while { $i < $nchan_ } {
                 set net $net_($i)
                 set dn [$net data-net]
                 set cn [$net ctrl-net]
                 $dn loopback $enable
                 $cn loopback $enable
                 incr i
         }
 }
 
 NetworkManager instproc install-key key {
         return [$self set_key $key]
 }
 
 NetworkManager instproc crypt_all { dc cc } {
         $self instvar net_
         foreach n [array names net_] {
                 $net_($n) crypt $dc $cc
         }
 }
 
 NetworkManager instproc destroy {} {
         $self instvar net_
 
         foreach chan [array names net_] {
                 delete $net_($chan)
         }
         $self next
 }
 
 NetworkManager instproc usingRLM {} {
         $self instvar mmg_
         return [info exists mmg_]
 }
 
 NetworkManager instproc notify-loss {src layer} {
         $self instvar net_
         $net_($layer) notify-loss $src
 }
 
 NetworkManager instproc crypt_format { key } {
         set k [string first / $key]
         if { $k < 0 } {
                 set fmt DES
         } else {
                 set fmt [string range $key 0 [expr $k - 1]]
                 set key [string range $key [expr $k + 1] end]
         }
         return "$fmt $key"
 }
 
 NetworkManager instproc set_key key {
         if { $key == "" } {
                 $self crypt_clear
                 return ""
         }
 
         $self instvar encrypt_
         set L [$self crypt_format $key]
         set fmt [lindex $L 0]
         set key [lindex $L 1]
         $self instvar key_
         set key_ $key
 
         $self instvar dc_ cc_ fmt_
 
         #
         # If the format changes, delete the crypt
         # objects so we reallocate them below.
         #
         if { $fmt_ != $fmt } {
                 if [info exists dc_] {
                         delete $dc_
                         unset dc_
                 }
                 if [info exists cc_] {
                         delete $cc_
                         unset cc_
                 }
                 set fmt_ $fmt
         }
 
         if ![info exists dc_] {
                 set clist [Crypt/Data info subclass]
                 if { [lsearch -exact $clist Crypt/Data/$fmt] < 0 } {
                         return "no $fmt encryption support"
                 }
                 set dc_ [new Crypt/Data/$fmt]
                 set cc_ [new Crypt/Control/$fmt]
         }
         if [$dc_ key $key] {
                 $cc_ key $key
                 $self crypt_all $dc_ $cc_
                 set encrypt_ 1
                 return ""
         } else {
                 $self crypt_clear
                 return "your key is cryptographically weak"
         }
 }
 
 NetworkManager instproc crypt_clear {} {
         $self instvar encrypt_ key_
         $self crypt_all "" ""
         set key_ ""
         set encrypt_ 0
 }