www.pudn.com > choke-ns.rar > ns-compat.tcl, change:2002-01-15,size:28221b
#
# Copyright (c) 1996-1997 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:
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# 2. 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.
# 3. All advertising materials mentioning features or use of this software
# must display the following acknowledgement:
# This product includes software developed by the MASH Research
# Group at the University of California Berkeley.
# 4. Neither the name of the University nor of the Research Group may be
# used to endorse or promote products derived from this software without
# specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE REGENTS 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: /nfs/jade/vint/CVSROOT/ns-2/tcl/lib/ns-compat.tcl,v 1.46 2000/06/27 00:05:01 sfloyd Exp $
#
Class OldSim -superclass Simulator
#
# If the "ns" command is called, set up the simulator
# class to assume backward compat. This creates an instance
# of a backward-compat simulator API with the name "ns"
# (which in turn overrides this proc)
#
proc ns args {
OldSim ns
eval ns $args
}
OldSim instproc default_catch { varName index op } {
if { $index == "" } {
error "ns-1 compat: default change caught, but not a default! (varName: $varName)"
exit 1
}
if { $op == "r" || $op == "u" } {
error "ns-1 compat: default change caught a $op operation"
exit 1
}
set vname ${varName}($index)
upvar $vname var
$self default_assign $varName $index $var
}
OldSim instproc default_assign {aname index newval} {
$self instvar classMap_ queueMap_
if { $index == "" } {
puts "something funny with default traces"
exit 1
}
set obj [string trimleft $aname ns_]
#
# special case the link array
#
if { $obj == "link" } {
if { $index == "queue-limit" } {
Queue set limit_ $newval
return
}
set ivar "$index\_"
if { [lsearch [DelayLink info vars] $ivar] >= 0 } {
DelayLink set $ivar $newval
return
}
error "warning: ns-1 compatibility library cannot set link default ${aname}($index)"
return
}
#
# now everyone else
#
if ![info exists classMap_($obj)] {
if ![info exists queueMap_($obj)] {
puts "error: ns-2 compatibility library cannot set ns-v1 default ${aname}($index)"
exit 1
} else {
set ns2obj "Queue/$queueMap_($obj)"
}
} else {
set ns2obj $classMap_($obj)
}
SplitObject instvar varMap_
if ![info exists varMap_($index)] {
puts "error: ns-2 compatibility library cannot map instvar $index in class $ns2obj"
exit 1
}
$ns2obj set $varMap_($index) $newval
}
#
# see if this array has any elements already set
# if so, arrange for the value to be set in ns-2
# also, add a trace hook so that future changes get
# reflected into ns-2
#
OldSim instproc map_ns_defaults old_arr {
global $old_arr ; # these were all globals in ns-1
SplitObject instvar varMap_
foreach el [array names $old_arr] {
set val [expr "$${old_arr}($el)"]
$self default_assign $old_arr $el $val
}
# arrange to trace any read/write/unset op
trace variable $old_arr rwu "$self default_catch"
}
OldSim instproc trace_old_defaults {} {
# all ns-v1 defaults as of 1.4
$self map_ns_defaults ns_tcp
$self map_ns_defaults ns_tcpnewreno
$self map_ns_defaults ns_trace
$self map_ns_defaults ns_fulltcp
$self map_ns_defaults ns_red
$self map_ns_defaults ns_cbq
$self map_ns_defaults ns_class
$self map_ns_defaults ns_sink
$self map_ns_defaults ns_delsink
$self map_ns_defaults ns_sacksink
$self map_ns_defaults ns_cbr
$self map_ns_defaults ns_rlm
$self map_ns_defaults ns_ivs
$self map_ns_defaults ns_source
$self map_ns_defaults ns_telnet
$self map_ns_defaults ns_bursty
$self map_ns_defaults ns_message
$self map_ns_defaults ns_facktcp
$self map_ns_defaults ns_link
$self map_ns_defaults ns_lossy_uniform
$self map_ns_defaults ns_lossy_patt
$self map_ns_defaults ns_queue
$self map_ns_defaults ns_srm
}
OldSim instproc init args {
eval $self next $args
puts stderr "warning: using backward compatibility mode"
$self instvar classMap_
Simulator set nsv1flag 1
#
# Always use the list scheduler.
$self instvar scheduler_
set scheduler_ [new Scheduler/List]
#
# in CBQ, setting the algorithm_ variable becomes invoking
# the algorithm method
#
# also, there really isn't a limit_ for CBQ, as each queue
# has its own.
#
Queue/CBQ instproc set args {
$self instvar compat_qlim_
if { [lindex $args 0] == "queue-limit" || \
[lindex $args 0] == "limit_" } {
if { [llength $args] == 2 } {
set val [lindex $args 1]
set compat_qlim_ $val
return $val
}
return $compat_qlim_
} elseif { [lindex $args 0] == "algorithm_" } {
$self algorithm [lindex $args 1]
# note: no return here
}
eval $self next $args
}
#
# Catch queue-limit variable which is now "$q limit"
#
Queue/DropTail instproc set args {
if { [llength $args] == 2 &&
[lindex $args 0] == "queue-limit" } {
# this will recursively call ourself
$self set limit_ [lindex $args 1]
return
}
eval $self next $args
}
Queue/RED instproc set args {
if { [llength $args] == 2 &&
[lindex $args 0] == "queue-limit" } {
# this will recursively call ourself
$self set limit_ [lindex $args 1]
return
}
eval $self next $args
}
Queue/RED instproc enable-vartrace file {
$self trace ave_
$self trace prob_
$self trace curq_
$self attach $file
}
# by HNN
Queue/CHOKE instproc set args {
if { [llength $args] == 2 &&
[lindex $args 0] == "queue-limit" } {
# this will recursively call ourself
$self set limit_ [lindex $args 1]
return
}
eval $self next $args
}
Queue/CHOKE instproc enable-vartrace file {
$self trace ave_
$self trace prob_
$self trace curq_
$self attach $file
}
# end HNN
#
# Catch set maxpkts for FTP sources, (needed because Source objects are
# not derived from TclObject, and hence can't use varMap method below)
#
Source/FTP instproc set args {
if { [llength $args] == 2 &&
[lindex $args 0] == "maxpkts" } {
$self set maxpkts_ [lindex $args 1]
return
}
eval $self next $args
}
Source/Telnet instproc set args {
if { [llength $args] == 2 &&
[lindex $args 0] == "interval" } {
$self set interval_ [lindex $args 1]
return
}
eval $self next $args
}
#
# Support for things like "set ftp [$tcp source ftp]"
#
Agent/TCP instproc source type {
if { $type == "ftp" } {
set type FTP
}
if { $type == "telnet" } {
set type Telnet
}
set src [new Source/$type]
$src attach $self
return $src
}
Agent/TCP set restart_bugfix_ false
#
# support for new variable names
# it'd be nice to set up mappings on a per-class
# basis, but this is too painful. Just do the
# mapping across all objects and hope this
# doesn't cause any collisions...
#
SplitObject instproc set args {
SplitObject instvar varMap_
set var [lindex $args 0]
if [info exists varMap_($var)] {
set var $varMap_($var)
set args "$var [lrange $args 1 end]"
}
# xxx: re-implement the code from tcl-object.tcl
$self instvar -parse-part1 $var
if {[llength $args] == 1} {
return [subst $[subst $var]]
} else {
return [set $var [lrange $args 1 end]]
}
}
SplitObject instproc get {var} {
SplitObject instvar varMap_
if [info exists varMap_($var)] {
# puts stderr "TclObject::get $var -> $varMap_($var)."
return [$self set $varMap_($var)]
} else {
return [$self next $var]
}
}
# Agent
TclObject set varMap_(addr) addr_
TclObject set varMap_(dst) dst_
## now gone
###TclObject set varMap_(seqno) seqno_
###TclObject set varMap_(cls) class_
## class -> flow id
TclObject set varMap_(cls) fid_
# Trace
TclObject set varMap_(src) src_
TclObject set varMap_(show_tcphdr) show_tcphdr_
# TCP
TclObject set varMap_(window) window_
TclObject set varMap_(window-init) windowInit_
TclObject set varMap_(window-option) windowOption_
TclObject set varMap_(window-constant) windowConstant_
TclObject set varMap_(window-thresh) windowThresh_
TclObject set varMap_(overhead) overhead_
TclObject set varMap_(tcp-tick) tcpTick_
TclObject set varMap_(ecn) ecn_
TclObject set varMap_(bug-fix) bugFix_
TclObject set varMap_(maxburst) maxburst_
TclObject set varMap_(maxcwnd) maxcwnd_
TclObject set varMap_(dupacks) dupacks_
TclObject set varMap_(seqno) seqno_
TclObject set varMap_(ack) ack_
TclObject set varMap_(cwnd) cwnd_
TclObject set varMap_(awnd) awnd_
TclObject set varMap_(ssthresh) ssthresh_
TclObject set varMap_(rtt) rtt_
TclObject set varMap_(srtt) srtt_
TclObject set varMap_(rttvar) rttvar_
TclObject set varMap_(backoff) backoff_
TclObject set varMap_(v-alpha) v_alpha_
TclObject set varMap_(v-beta) v_beta_
TclObject set varMap_(v-gamma) v_gamma_
# Agent/TCP/NewReno
TclObject set varMap_(changes) newreno_changes_
# Agent/TCP/Fack
TclObject set varMap_(rampdown) rampdown_
TclObject set varMap_(ss-div4) ss-div4_
# Queue
TclObject set varMap_(limit) limit_
# Queue/SFQ
TclObject set varMap_(limit) maxqueue_
TclObject set varMap_(buckets) buckets_
# Queue/RED
TclObject set varMap_(bytes) bytes_
TclObject set varMap_(thresh) thresh_
TclObject set varMap_(maxthresh) maxthresh_
TclObject set varMap_(mean_pktsize) meanPacketSize_
TclObject set varMap_(q_weight) queueWeight_
TclObject set varMap_(wait) wait_
TclObject set varMap_(linterm) linterm_
TclObject set varMap_(setbit) setbit_
TclObject set varMap_(drop-tail) dropTail_
TclObject set varMap_(doubleq) doubleq_
TclObject set varMap_(dqthresh) dqthresh_
TclObject set varMap_(subclasses) subclasses_
# CBQClass
TclObject set varMap_(algorithm) algorithm_
TclObject set varMap_(max-pktsize) maxpkt_
TclObject set varMap_(priority) priority_
TclObject set varMap_(maxidle) maxidle_
TclObject set varMap_(extradelay) extradelay_
# Agent/TCPSinnk, Agent/CBR
TclObject set varMap_(packet-size) packetSize_
TclObject set varMap_(interval) interval_
# Agent/CBR
TclObject set varMap_(random) random_
# IVS
TclObject set varMap_(S) S_
TclObject set varMap_(R) R_
TclObject set varMap_(state) state_
TclObject set varMap_(rttShift) rttShift_
TclObject set varMap_(keyShift) keyShift_
TclObject set varMap_(key) key_
TclObject set varMap_(maxrtt) maxrtt_
Class traceHelper
traceHelper instproc attach f {
$self instvar file_
set file_ $f
}
#
# linkHelper
# backward compat for "[ns link $n1 $n2] set linkVar $value"
#
# unfortunately, 'linkVar' in ns-1 can be associated
# with a link (delay, bandwidth, generic queue requests) or
# can be specific to a particular queue (e.g. RED) which
# has a bunch of variables (see above).
#
Class linkHelper
linkHelper instproc init args {
$self instvar node1_ node2_ linkref_ queue_
set node1_ [lindex $args 0]
set node2_ [lindex $args 1]
set lid [$node1_ id]:[$node2_ id]
set linkref_ [ns set link_($lid)]
set queue_ [$linkref_ queue]
# these will be used in support of link stats
set sqi [new SnoopQueue/In]
set sqo [new SnoopQueue/Out]
set sqd [new SnoopQueue/Drop]
set dsamples [new Samples]
set qmon [new QueueMonitor/Compat]
$qmon set-delay-samples $dsamples
$linkref_ attach-monitors $sqi $sqo $sqd $qmon
$linkref_ set bytesInt_ [new Integrator]
$linkref_ set pktsInt_ [new Integrator]
$qmon set-bytes-integrator [$linkref_ set bytesInt_]
$qmon set-pkts-integrator [$linkref_ set pktsInt_]
}
linkHelper instproc trace traceObj {
$self instvar node1_ node2_
$self instvar queue_
set tfile [$traceObj set file_]
ns trace-queue $node1_ $node2_ $tfile
# XXX: special-case RED queue for var tracing
if { [string first Queue/RED [$queue_ info class]] == 0 } {
$queue_ enable-vartrace $tfile
}
}
linkHelper instproc callback {fn} {
# Reach deep into the guts of the link and twist...
# (This code makes assumptions about how
# SimpleLink instproc trace works.)
# NEEDSWORK: should this be done with attach-monitors?
$self instvar linkref_
foreach part {enqT_ deqT_ drpT_} {
set to [$linkref_ set $part]
$to set callback_ 1
$to proc handle {args} "$fn \$args"
}
}
linkHelper instproc set { var val } {
$self instvar linkref_ queue_
set qvars [$queue_ info vars]
set linkvars [$linkref_ info vars]
set linkdelayvars [[$linkref_ link] info vars]
#
# adjust the string to have a trailing '_'
# because all instvars are constructed that way
#
if { [string last _ $var] != ( [string length $var] - 1) } {
set var ${var}_
}
if { $var == "queue-limit_" } {
set var "limit_"
}
if { [lsearch $qvars $var] >= 0 } {
# set a queue var
$queue_ set $var $val
} elseif { [lsearch $linkvars $var] >= 0 } {
# set a link OTcl var
$linkref_ set $var $val
} elseif { [lsearch $linkdelayvars $var] >= 0 } {
# set a linkdelay object var
[$linkref_ link] set $var $val
} else {
puts stderr "linkHelper warning: couldn't set unknown variable $var"
}
}
linkHelper instproc get var {
$self instvar linkref_ queue_
set qvars [$queue_ info vars]
set linkvars [$linkref_ info vars]
set linkdelayvars [[$linkref_ link] info vars]
#
# adjust the string to have a trailing '_'
# because all instvars are constructed that way
#
if { [string last _ $var] != ( [string length $var] - 1) } {
set var ${var}_
}
if { $var == "queue-limit_" } {
set var "limit_"
}
if { [lsearch $qvars $var] >= 0 } {
# set a queue var
return [$queue_ set $var]
} elseif { [lsearch $linkvars $var] >= 0 } {
# set a link OTcl var
return [$linkref_ set $var]
} elseif { [lsearch $linkdelayvars $var] >= 0 } {
# set a linkdelay object var
return [[$linkref_ link] set $var]
} else {
puts stderr "linkHelper warning: couldn't set unknown variable $var"
return ""
}
return ""
}
#
# gross, but works:
#
# In ns-1 queues were a sublass of link, and this compat
# code carries around a 'linkHelper' as the returned object
# when you do a [ns link $r1 $r2] or a [ns link $r1 $r2 $qtype]
# command. So, operations on this object could have been
# either link ops or queue ops in ns-1. It is possible to see
# whether an Otcl class or object supports certain commands
# but it isn't possible to look inside a C++ implemented object
# (i.e. into it's cmd function) to see what it supports. Instead,
# arrange to catch the exception generated while trying into a
# not-implemented method in a C++ object.
#
linkHelper instproc try { obj operation argv } {
set op [eval list $obj $operation $argv]
set ocl [$obj info class]
set iprocs [$ocl info instcommands]
set oprocs [$obj info commands]
# if it's a OTcl-implemented method we see it in info
# and thus don't need to catch it
if { $operation != "cmd" } {
if { [lsearch $iprocs $operation] >= 0 } {
return [eval $op]
}
if { [lsearch $oprocs $operation] >= 0 } {
return [eval $op]
}
}
#catch the c++-implemented method in case it's not there
#ret will contain error string or return string
# value of catch operation will be 1 on error
if [catch $op ret] {
return -1
}
return $ret
}
# so, try to invoke the op on a queue and if that causes
# an exception (a missing function hopefully) try it on
# the link instead
#
# we need to override 'TclObject instproc unknown args'
# (well, at least we did), because it was coded such that
# if a command() function didn't exist, an exit 1 happened
#
linkHelper instproc unknown { m args } {
# method could be in: queue, link, linkdelay
# or any of its command procedures
# note that if any of those have errors in them
# we can get a general error by ending up at the end here
$self instvar linkref_ queue_
set oldbody [TclObject info instbody unknown]
TclObject instproc unknown args {
if { [lindex $args 0] == "cmd" } {
puts stderr "Can't dispatch $args"
exit 1
}
eval $self cmd $args
}
# try an OTcl queue then the underlying queue object
set rval [$self try $queue_ $m $args]
if { $rval != -1 } {
TclObject instproc unknown args $oldbody
return $rval
}
set rval [$self try $queue_ cmd [list $m $args]]
if { $rval != -1 } {
TclObject instproc unknown args $oldbody
return $rval
}
set rval [$self try $linkref_ $m $args]
if { $rval != -1 } {
TclObject instproc unknown args $oldbody
return $rval
}
set rval [$self try $linkref_ cmd [list $m $args]]
if { $rval != -1 } {
TclObject instproc unknown args $oldbody
return $rval
}
set dlink [$linkref_ link]
set rval [$self try $dlink $m $args]
if { $rval != -1 } {
TclObject instproc unknown args $oldbody
return $rval
}
set rval [$self try $dlink cmd [list $m $args]]
if { $rval != -1 } {
TclObject instproc unknown args $oldbody
return $rval
}
TclObject instproc unknown args $oldbody
puts stderr "Unknown operation $m or subbordinate operation failed"
exit 1
}
linkHelper instproc stat { classid item } {
$self instvar linkref_
set qmon [$linkref_ set qMonitor_]
# note: in ns-1 the packets/bytes stats are counts
# of the number of *departures* at a link/queue
#
if { $item == "packets" } {
return [$qmon pkts $classid]
} elseif { $item == "bytes" } {
return [$qmon bytes $classid]
} elseif { $item == "drops"} {
return [$qmon drops $classid]
} elseif { $item == "mean-qdelay" } {
set dsamp [$qmon get-class-delay-samples $classid]
if { [$dsamp cnt] > 0 } {
return [$dsamp mean]
} else {
return NaN
}
} else {
puts stderr "linkHelper: unknown stat op $item"
exit 1
}
}
linkHelper instproc integral { itype } {
$self instvar linkref_
if { $itype == "qsize" } {
set integ [$linkref_ set bytesInt_]
} elseif { $itype == "qlen" } {
set integ [$linkref_ set pktsInt_]
}
return [$integ set sum_]
}
#
# end linkHelper
#
set classMap_(tcp) Agent/TCP
set classMap_(tcp-reno) Agent/TCP/Reno
set classMap_(tcp-vegas) Agent/TCP/Vegas
set classMap_(tcp-full) Agent/TCP/FullTcp
set classMap_(fulltcp) Agent/TCP/FullTcp
set classMap_(tcp-fack) Agent/TCP/Fack
set classMap_(facktcp) Agent/TCP/Fack
set classMap_(tcp-newreno) Agent/TCP/Newreno
set classMap_(tcpnewreno) Agent/TCP/Newreno
set classMap_(cbr) Agent/CBR
set classMap_(tcp-sink) Agent/TCPSink
set classMap_(tcp-sack1) Agent/TCP/Sack1
set classMap_(sack1-tcp-sink) Agent/TCPSink/Sack1
set classMap_(tcp-sink-da) Agent/TCPSink/DelAck
set classMap_(sack1-tcp-sink-da) Agent/TCPSink/Sack1/DelAck
set classMap_(sink) Agent/TCPSink
set classMap_(delsink) Agent/TCPSink/DelAck
set classMap_(sacksink) Agent/TCPSink ; # sacksink becomes TCPSink here
set classMap_(loss-monitor) Agent/LossMonitor
set classMap_(class) CBQClass
set classMap_(ivs) Agent/IVS/Source
set classMap_(trace) Trace
set classMap_(srm) Agent/SRM
$self instvar queueMap_
set queueMap_(drop-tail) DropTail
set queueMap_(sfq) SFQ
set queueMap_(red) RED
set queueMap_(cbq) CBQ
set queueMap_(wrr-cbq) CBQ/WRR
$self trace_old_defaults
#
# this is a hack to deal with the unfortunate name
# of a CBQ class chosen in ns-1 (i.e. "class").
#
# the "new" procedure in Tcl/tcl-object.tcl will end
# up calling:
# eval class create id ""
# so, catch this here... yuck
global tcl_version
if {$tcl_version < 8} {
set class_name "class"
} else {
set class_name "::class"
}
proc $class_name args {
set arglen [llength $args]
if { $arglen < 2 } {
return
}
set op [lindex $args 0]
set id [lindex $args 1]
if { $op != "create" } {
error "ns-v1 compat: malformed class operation: op $op"
return
}
#
# we need to prevent a "phantom" argument from
# showing up in the argument list to [CBQClass create],
# so, don't pass an empty string if we weren't
# called with one!
#
# by calling through [eval], we suppress any {} that
# might result from the [lrange ...] below
#
eval CBQClass create $id [lrange $args 2 [expr $arglen - 1]]
}
}
#
# links in ns-1 had support for statistics collection...
# $link stat packets/bytes/drops
#
OldSim instproc simplex-link-compat { n1 n2 bw delay qtype } {
set linkhelp [$self link-threeargs $n1 $n2 $qtype]
$linkhelp set bandwidth_ $bw
$linkhelp set delay_ $delay
}
OldSim instproc duplex-link-compat { n1 n2 bw delay type } {
ns simplex-link-compat $n1 $n2 $bw $delay $type
ns simplex-link-compat $n2 $n1 $bw $delay $type
}
OldSim instproc get-queues { n1 n2 } {
$self instvar link_
set n1 [$n1 id]
set n2 [$n2 id]
return "[$link_($n1:$n2) queue] [$link_($n2:$n1) queue]"
}
OldSim instproc create-agent { node type pktClass } {
$self instvar classMap_
if ![info exists classMap_($type)] {
puts stderr \
"backward compat bug: need to update classMap for $type"
exit 1
}
set agent [new $classMap_($type)]
# new mapping old class -> flowid
$agent set fid_ $pktClass
$self attach-agent $node $agent
# This has been replaced by TclObject instproc get. -johnh, 10-Sep-97
#
# $agent proc get var {
# return [$self set $var]
# }
return $agent
}
OldSim instproc agent { type node } {
return [$self create-agent $node $type 0]
}
OldSim instproc create-connection \
{ srcType srcNode sinkType sinkNode pktClass } {
set src [$self create-agent $srcNode $srcType $pktClass]
set sink [$self create-agent $sinkNode $sinkType $pktClass]
$self connect $src $sink
return $src
}
proc ns_connect { src sink } {
return [ns connect $src $sink]
}
#
# return helper object for backward compat of "ns link" command
#
OldSim instproc link args {
set nargs [llength $args]
set arg0 [lindex $args 0]
set arg1 [lindex $args 1]
if { $nargs == 2 } {
return [$self link-twoargs $arg0 $arg1]
} elseif { $nargs == 3 } {
return [$self link-threeargs $arg0 $arg1 [lindex $args 2]]
}
}
OldSim instproc link-twoargs { n1 n2 } {
$self instvar LH_
if ![info exists LH_($n1:$n2)] {
set LH_($n1:$n2) 1
linkHelper LH_:$n1:$n2 $n1 $n2
}
return LH_:$n1:$n2
}
OldSim instproc link-threeargs { n1 n2 qtype } {
# new link with 0 bandwidth and 0 delay
$self simplex-link $n1 $n2 0 0 $qtype
return [$self link-twoargs $n1 $n2]
}
OldSim instproc trace {} {
return [new traceHelper]
}
OldSim instproc random { seed } {
return [ns-random $seed]
}
proc ns_simplex { n1 n2 bw delay type } {
# this was never used in ns-1
puts stderr "ns_simplex: no backward compat"
exit 1
}
proc ns_duplex { n1 n2 bw delay type } {
ns duplex-link-compat $n1 $n2 $bw $delay $type
return [ns get-queues $n1 $n2]
}
#
# Create a source/sink connection pair and return the source agent.
#
proc ns_create_connection { srcType srcNode sinkType sinkNode pktClass } {
ns create-connection $srcType $srcNode $sinkType \
$sinkNode $pktClass
}
#
# Create a source/sink CBR pair and return the source agent.
#
proc ns_create_cbr { srcNode sinkNode pktSize interval fid } {
set s [ns create-connection cbr $srcNode loss-monitor \
$sinkNode $fid]
$s set interval_ $interval
$s set packetSize_ $pktSize
return $s
}
#
# compat code for CBQ
#
proc ns_create_class { parent borrow allot maxidle notused prio depth xdelay } {
set cl [new CBQClass]
#
# major hack: if the prio is 8 (the highest in ns-1) it's
# an internal node, hence no queue disc
if { $prio < 8 } {
set qtype [CBQClass set def_qtype_]
set q [new Queue/$qtype]
$cl install-queue $q
}
set depth [expr $depth + 1]
if { $borrow == "none" } {
set borrowok false
} elseif { $borrow == $parent } {
set borrowok true
} else {
puts stderr "CBQ: borrowing from non-parent not supported"
exit 1
}
$cl setparams $parent $borrowok $allot $maxidle $prio $depth $xdelay
return $cl
}
proc ns_create_class1 { parent borrow allot maxidle notused prio depth xdelay Mb } {
set cl [ns_create_class $parent $borrow $allot $maxidle $notused $prio $depth $xdelay]
ns_class_maxIdle $cl $allot $maxidle $prio $Mb
return $cl
}
proc ns_class_params { cl parent borrow allot maxidle notused prio depth xdelay Mb } {
set depth [expr $depth + 1]
if { $borrow == "none" } {
set borrowok false
} elseif { $borrow == $parent } {
set borrowok true
} else {
puts stderr "CBQ: borrowing from non-parent not supported"
exit 1
}
$cl setparams $parent $borrowok $allot $maxidle $prio $depth $xdelay
ns_class_maxIdle $cl $allot $maxidle $prio $Mb
return $cl
}
#
# If $maxIdle is "auto", set maxIdle to Max[t(1/p-1)(1-g^n)/g^n, t(1-g)].
# For p = allotment, t = packet transmission time, g = weight for EWMA.
# The parameter t is calculated for a medium-sized 1000-byte packet.
#
proc ns_class_maxIdle { cl allot maxIdle priority Mbps } {
if { $maxIdle == "auto" } {
set g 0.9375
set n [expr 8 * $priority]
set gTOn [expr pow($g, $n)]
set first [expr ((1/$allot) - 1) * (1-$gTOn) / $gTOn ]
set second [expr (1 - $g)]
set packetsize 1000
set t [expr ($packetsize * 8)/($Mbps * 1000000) ]
if { $first > $second } {
$cl set maxidle_ [expr $t * $first]
} else {
$cl set maxidle_ [expr $t * $second]
}
} else {
$cl set maxidle_ $maxIdle
}
return $cl
}
#
# backward compat for agent methods that were replaced
# by OTcl instance variables
#
Agent instproc connect d {
$self set dst_ $d
}
# XXX changed call from "handle" to "recv"
Agent/Message instproc recv msg {
$self handle $msg
}
#Renamed variables in Queue/RED and Queue/DropTail
Queue/RED proc set { var {arg ""} } {
if { $var == "queue-in-bytes_" } {
warn "Warning: use `queue_in_bytes_' rather than `queue-in-bytes_'"
set var "queue_in_bytes_"
} elseif { $var == "drop-tail_" } {
warn "Warning: use `drop_tail_' rather than `drop-tail_'"
set var "drop_tail_"
} elseif { $var == "drop-front_" } {
warn "Warning: use `drop_front_' rather than `drop-front_'"
set var "drop_front_"
} elseif { $var == "drop-rand_" } {
warn "Warning: use `drop_rand_' rather than `drop-rand_'"
set var "drop_rand_"
} elseif { $var == "ns1-compat_" } {
warn "Warning: use `ns1_compat_' rather than `ns1-compat_'"
set var "ns1_compat_"
}
eval $self next $var $arg
}
Queue/DropTail proc set { var {arg ""} } {
if { $var == "drop-front_" } {
warn "Warning: use `drop_front_' rather than `drop-front_'"
set var "drop_front_"
}
eval $self next $var $arg
}