ns-compat.tcl

NS-2.28的802.11e协议扩展源代码

		#
		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
}