ns-compat.tcl

CBRP协议（移动adhoc中基于分簇的路由协议）ns2下的源码

#
# 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: /usr/cvs/ns/ns-src/tcl/lib/ns-compat.tcl,v 1.1.1.1 1998/01/13 15:06:19 root 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_

	#
	# 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
	}
		
	#
	# 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...
	#
	TclObject 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]"
		}
		return [eval $self next $args]
	}
	TclObject 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
	}
	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 } {