开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
ns-namsupp.tcl
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：15k
源码类别：

通讯编程

开发平台：

Visual C++

ns-namsupp.tcl：源码内容
  1. # 
  2. #  Copyright (c) 1997 by the University of Southern California
  3. #  All rights reserved.
  4. # 
  5. #  This program is free software; you can redistribute it and/or
  6. #  modify it under the terms of the GNU General Public License,
  7. #  version 2, as published by the Free Software Foundation.
  8. #
  9. #  This program is distributed in the hope that it will be useful,
  10. #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. #  GNU General Public License for more details.
  13. #
  14. #  You should have received a copy of the GNU General Public License along
  15. #  with this program; if not, write to the Free Software Foundation, Inc.,
  16. #  59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
  17. #
  18. #  The copyright of this module includes the following
  19. #  linking-with-specific-other-licenses addition:
  20. #
  21. #  In addition, as a special exception, the copyright holders of
  22. #  this module give you permission to combine (via static or
  23. #  dynamic linking) this module with free software programs or
  24. #  libraries that are released under the GNU LGPL and with code
  25. #  included in the standard release of ns-2 under the Apache 2.0
  26. #  license or under otherwise-compatible licenses with advertising
  27. #  requirements (or modified versions of such code, with unchanged
  28. #  license).  You may copy and distribute such a system following the
  29. #  terms of the GNU GPL for this module and the licenses of the
  30. #  other code concerned, provided that you include the source code of
  31. #  that other code when and as the GNU GPL requires distribution of
  32. #  source code.
  33. #
  34. #  Note that people who make modified versions of this module
  35. #  are not obligated to grant this special exception for their
  36. #  modified versions; it is their choice whether to do so.  The GNU
  37. #  General Public License gives permission to release a modified
  38. #  version without this exception; this exception also makes it
  39. #  possible to release a modified version which carries forward this
  40. #  exception.
  41. # 
  42. # ns trace support for nam
  43. #
  44. # Author: Haobo Yu (haoboy@isi.edu)
  45. #
  46. # $Header: /cvsroot/nsnam/ns-2/tcl/lib/ns-namsupp.tcl,v 1.43 2006/02/22 13:23:15 mahrenho Exp $
  47. #
  49. #
  50. # Support for node tracing
  51. #
  53. # This will only work during initialization. Not possible to change shape 
  54. # dynamically
  55. Node instproc shape { shape } {
  56. $self instvar attr_ 
  57. set attr_(SHAPE) $shape
  58. }
  60. # Returns the current shape of the node
  61. Node instproc get-shape {} {
  62. $self instvar attr_
  63. if [info exists attr_(SHAPE)] {
  64. return $attr_(SHAPE)
  65. } else {
  66. return ""
  67. }
  68. }
  70. Node instproc color { color } {
  71. $self instvar attr_ id_
  73. set ns [Simulator instance]
  75. if [$ns is-started] {
  76. # color must be initialized
  78. $ns puts-nam-config 
  79. [eval list "n -t [format "%.15g" [$ns now]] -s $id_ -S COLOR -c $color -o $attr_(COLOR) -i $color -I $attr_(LCOLOR)"]
  80. set attr_(COLOR) $color
  81.         set attr_(LCOLOR) $color
  82. } else {
  83. set attr_(COLOR) $color
  84.         set attr_(LCOLOR) $color
  85. }
  86. }
  88. Node instproc label { str} {
  89. $self instvar attr_ id_
  91. set ns [Simulator instance]
  93. if [info exists attr_(DLABEL)] {
  94. $ns puts-nam-config "n -t [$ns now] -s $id_ -S DLABEL -l "$str" -L $attr_(DLABEL)"
  95. } else {
  96. $ns puts-nam-config "n -t [$ns now] -s $id_ -S DLABEL -l "$str" -L """
  97. }
  98. set attr_(DLABEL) "$str"
  99. }
  101. Node instproc label-color { str} {
  102.         $self instvar attr_ id_
  104.         set ns [Simulator instance]
  106.         if [info exists attr_(DCOLOR)] {
  107.                 $ns puts-nam-config "n -t [$ns now] -s $id_ -S DCOLOR -e "$str" -E $attr_(DCOLOR)"
  108.         } else {
  109.                 $ns puts-nam-config "n -t [$ns now] -s $id_ -S DCOLOR -e "$str" -E """
  110.         }
  111.         set attr_(DCOLOR) "$str"
  112. }
  114. Node instproc label-at { str } {
  115.         $self instvar attr_ id_
  117.         set ns [Simulator instance]
  119.         if [info exists attr_(DIRECTION)] {
  120.                 $ns puts-nam-config "n -t [$ns now] -s $id_ -S DIRECTION -p "$str" -P $attr_(DIRECTION)"
  121.         } else {
  122.                 $ns puts-nam-config "n -t [$ns now] -s $id_ -S DIRECTION -p "$str" -P """
  123.         }
  124.         set attr_(DIRECTION) "$str"
  125. }
  127. Node instproc dump-namconfig {} {
  128. $self instvar attr_ id_ address_ X_ Y_ Z_
  129. set ns [Simulator instance]
  131. if ![info exists attr_(SHAPE)] {
  132. set attr_(SHAPE) "circle"
  133. } 
  134. if ![info exists attr_(COLOR)] {
  135. set attr_(COLOR) "black"
  136.         set attr_(LCOLOR) "black"
  137. }
  138.         if ![info exists attr_(DCOLOR)] {
  139.                 set attr_(DCOLOR) "black"
  140.         }
  141. if { [info exists X_] && [info exists Y_] } {
  142. if [info exists Z_] {
  143. $ns puts-nam-config 
  144. [eval list "n -t * -a $address_ -s $id_ -S UP -v $attr_(SHAPE) -c $attr_(COLOR) -i $attr_(LCOLOR) -x $X_ -y $Y_ -Z $Z_"]
  145. } else {
  146. $ns puts-nam-config 
  147. [eval list "n -t * -a $address_ -s $id_ -S UP -v $attr_(SHAPE) -c $attr_(COLOR) -i $attr_(LCOLOR) -x $X_ -y $Y_"]
  148. }
  149. } else {
  150. $ns puts-nam-config 
  151. [eval list "n -t * -a $address_ -s $id_ -S UP -v $attr_(SHAPE) -c $attr_(COLOR) -i $attr_(LCOLOR)"]
  152. }
  153. }
  155. Node instproc change-color { color } {
  156. puts "Warning: Node::change-color is obsolete. Use Node::color instead"
  157. $self color $color
  158. }
  160. Node instproc get-attribute { name } {
  161. $self instvar attr_
  162. if [info exists attr_($name)] {
  163. return $attr_($name)
  164. } else {
  165. return ""
  166. }
  167. }
  169. Node instproc get-color {} {
  170. puts "Warning: Node::get-color is obsolete. Please use Node::get-attribute"
  171. return [$self get-attribute "COLOR"]
  172. }
  174. Node instproc add-mark { name color {shape "circle"} } {
  175. $self instvar id_ markColor_ shape_
  176. set ns [Simulator instance]
  178. $ns puts-nam-config "m -t [$ns now] -s $id_ -n $name -c $color -h $shape"
  179. set markColor_($name) $color
  180. set shape_($name) $shape
  181. }
  183. Node instproc delete-mark { name } {
  184. $self instvar id_ markColor_ shape_
  186. # Ignore if the mark $name doesn't exist
  187. if ![info exists markColor_($name)] {
  188. return
  189. }
  191. set ns [Simulator instance]
  192. $ns puts-nam-config 
  193. "m -t [$ns now] -s $id_ -n $name -c $markColor_($name) -h $shape_($name) -X"
  194. }
  196. #
  197. # Support for link tracing
  198. # XXX only SimpleLink (and its children) can dump nam config, because Link
  199. # doesn't have bandwidth and delay.
  200. #
  201. SimpleLink instproc dump-namconfig {} {
  202. # make a duplex link in nam
  203. $self instvar link_ attr_ fromNode_ toNode_
  205. if ![info exists attr_(COLOR)] {
  206. set attr_(COLOR) "black"
  207. }
  209. set ns [Simulator instance]
  210. set bw [$link_ set bandwidth_]
  211. set delay [$link_ set delay_]
  213. if [info exists attr_(ORIENTATION)] {
  214. $ns puts-nam-config 
  215. "l -t * -s [$fromNode_ id] -d [$toNode_ id] -S UP -r $bw -D $delay -c $attr_(COLOR) -o $attr_(ORIENTATION)"
  216. } else {
  217. $ns puts-nam-config 
  218. "l -t * -s [$fromNode_ id] -d [$toNode_ id] -S UP -r $bw -D $delay -c $attr_(COLOR)"
  219. }
  220. }
  222. Link instproc dump-nam-queueconfig {} {
  223. $self instvar attr_ fromNode_ toNode_
  225. if ![info exists attr_(COLOR)] {
  226. set attr_(COLOR) "black"
  227. }
  229. set ns [Simulator instance]
  230. if [info exists attr_(QUEUE_POS)] {
  231. $ns puts-nam-config "q -t * -s [$fromNode_ id] -d [$toNode_ id] -a $attr_(QUEUE_POS)"
  232. } else {
  233. set attr_(QUEUE_POS) ""
  234. }
  235. }
  237. #
  238. # XXX
  239. # This function should be called ONLY ONCE during initialization. 
  240. # The order in which links are created in nam is determined by the calling 
  241. # order of this function.
  242. #
  243. Link instproc orient { ori } {
  244. $self instvar attr_
  245. set attr_(ORIENTATION) $ori
  246. [Simulator instance] register-nam-linkconfig $self
  247. }
  249. Link instproc get-attribute { name } {
  250. $self instvar attr_
  251. if [info exists attr_($name)] {
  252. return $attr_($name)
  253. } else {
  254. return ""
  255. }
  256. }
  258. Link instproc queuePos { pos } {
  259. $self instvar attr_
  260. set attr_(QUEUE_POS) $pos
  261. }
  263. Link instproc color { color } {
  264. $self instvar attr_ fromNode_ toNode_ trace_
  266. set ns [Simulator instance]
  267. if [$ns is-started] {
  268. $ns puts-nam-config 
  269. [eval list "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S COLOR -c $color -o $attr_(COLOR)"]
  270. set attr_(COLOR) $color
  271. } else {
  272. set attr_(COLOR) $color
  273. }
  274. }
  276. # a link doesn't have its own trace file, write it to global trace file
  277. Link instproc change-color { color } {
  278. puts "Warning: Link::change-color is obsolete. Please use Link::color."
  279. $self color $color
  280. }
  282. Link instproc get-color {} {
  283. puts "Warning: Node::get-color is obsolete. Please use Node::get-attribute"
  284. return [$self get-attribute "COLOR"]
  285. }
  287. Link instproc label { label } {
  288.         $self instvar attr_ fromNode_ toNode_ trace_
  289.         set ns [Simulator instance]
  290.         if [info exists attr_(DLABEL)] {
  291.             $ns puts-nam-config 
  292.             "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S DLABEL -l "$label" -L $attr_(DLABEL)"
  293.         } else {
  294.             $ns puts-nam-config 
  295.             "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S DLABEL -l "$label" -L """
  296.         }
  297.         set attr_(DLABEL) "$label"
  298.     }
  300. Link instproc label-color { str } {
  301.         $self instvar attr_ fromNode_ toNode_ trace_
  302.         set ns [Simulator instance]
  303.         if [info exists attr_(DCOLOR)] {
  304.             $ns puts-nam-config 
  305.             "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S DCOLOR -e "$str" -E $attr_(DCOLOR)"
  306.         } else {
  307.             $ns puts-nam-config 
  308.             "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S DCOLOR -e "$str" -E """
  309.         }
  310.         set attr_(DCOLOR) "$str"
  311.     }
  313. Link instproc label-at { str } {
  314.         $self instvar attr_ fromNode_ toNode_ trace_
  315.         set ns [Simulator instance]
  316.         if [info exists attr_(DIRECTION)] {
  317.             $ns puts-nam-config 
  318.             "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S DIRECTION -p "$str" -P $attr_(DIRECTION)"
  319.         } else {
  320.             $ns puts-nam-config 
  321.             "l -t [$ns now] -s [$fromNode_ id] -d [$toNode_ id] -S DIRECTION -p "$str" -P """
  322.         }
  323.         set attr_(DIRECTION) "$str"
  324.     }
  326. #
  327. # Support for nam snapshot
  328. #
  330. Simulator instproc snapshot { } {
  331.     set ns [Simulator instance]
  332.     $ns puts-nam-config 
  333.             "v -t [$self now] take_snapshot"
  334. }
  336. Simulator instproc rewind-nam { } {
  337. set ns [Simulator instance]
  338. $ns puts-nam-config 
  339. "v  -t [$self now] playing_backward"
  340. }
  342. Simulator instproc re-rewind-nam { } {
  343. set ns [Simulator instance]
  344. $ns puts-nam-config 
  345. "v  -t [$self now] playing_forward"
  346. }
  348. Simulator instproc terminate-nam { } {
  349. set ns [Simulator instance]
  350. $ns puts-nam-config 
  351. "v  -t [$self now] terminating_nam"
  352. }
  354. #
  355. # Support for agent tracing
  356. #
  358. # This function records agents being traced, so they will be written into nam
  359. # trace when the simulator starts
  360. Simulator instproc add-agent-trace { agent name {f ""} } {
  361. $self instvar tracedAgents_
  362. set tracedAgents_($name) $agent
  364. set trace [$self get-nam-traceall]
  365. if {$f != ""} {
  366. $agent attach-trace $f
  367. } elseif {$trace != ""} {
  368. $agent attach-trace $trace
  369. }
  370. }
  372. Simulator instproc delete-agent-trace { agent } {
  373. $agent delete-agent-trace
  374. }
  376. Simulator instproc monitor-agent-trace { agent } {
  377. $self instvar monitoredAgents_
  378. lappend monitoredAgents_ $agent
  379. }
  381. #
  382. # Agent trace is added when attaching to a traced node
  383. # we need to keep a file handle in tcl so that var tracing can also be 
  384. # done in tcl by manual inserting update-var-trace{}
  385. #
  386. Agent instproc attach-trace { file } {
  387. $self instvar namTrace_
  388. set namTrace_ $file 
  389. # add all traced var messages
  390. $self attach $file 
  391. }
  393. #
  394. # nam initialization
  395. #
  396. Simulator instproc dump-namagents {} {
  397. $self instvar tracedAgents_ monitoredAgents_
  399. if {![$self is-started]} {
  400. return
  401. }
  402. if [info exists tracedAgents_] {
  403. foreach id [array names tracedAgents_] {
  404. $tracedAgents_($id) add-agent-trace $id
  405. $tracedAgents_($id) cmd dump-namtracedvars
  406. }
  407. unset tracedAgents_
  408. }
  409. if [info exists monitoredAgents_] {
  410. foreach a $monitoredAgents_ {
  411. $a show-monitor
  412. }
  413. unset monitoredAgents_
  414. }
  415. }
  417. Simulator instproc dump-namversion { v } {
  418. $self puts-nam-config "V -t * -v $v -a 0"
  419. }
  421. Simulator instproc dump-namwireless {} {
  422. $self instvar namNeedsW_ namWx_ namWy_
  424. # see if we need to write a W event
  425. if ![info exists namNeedsW_] { set namNeedsW_ 0 }
  426. if {[info exists namWx_] && [info exists namWy_]}  {
  427. set maxX $namWx_
  428. set maxY $namWy_
  429. } else {
  430. set maxX 10
  431. set maxY 10
  433. # get max X and Y coords of nodes
  434. # if any nodes have coordinates set, then flag the need for
  435. # a W event and adjust maxX/maxY as needed
  436. foreach node [Node info instances] {
  437. if {[lsearch -exact [$node info vars] X_] != -1} {
  438. set namNeedsW_ 1
  439. set curX [$node set X_]
  440. if {$curX > $maxX} {set maxX $curX}
  441. }
  442. if {[lsearch -exact [$node info vars] Y_] != -1} {
  443. set namNeedsW_ 1
  444. set curY [$node set Y_]
  445. if {$curY > $maxY} {set maxY $curY}
  446. }
  447. }
  448. }
  450. if $namNeedsW_ {
  451. $self puts-nam-config "W -t * -x $maxX -y $maxY"
  452. }
  453. }
  455. Simulator instproc dump-namcolors {} {
  456. $self instvar color_
  457. if ![$self is-started] {
  458. return 
  459. }
  460. foreach id [array names color_] {
  461. $self puts-nam-config "c -t * -i $id -n $color_($id)"
  462. }
  463. }
  465. Simulator instproc dump-namlans {} {
  466. if ![$self is-started] {
  467. return
  468. }
  469. $self instvar Node_
  470. foreach nn [array names Node_] {
  471. if [$Node_($nn) is-lan?] {
  472. $Node_($nn) dump-namconfig
  473. }
  474. }
  475. }
  477. Simulator instproc dump-namlinks {} {
  478. $self instvar linkConfigList_
  479. if ![$self is-started] {
  480. return
  481. }
  482. if [info exists linkConfigList_] {
  483. foreach lnk $linkConfigList_ {
  484. $lnk dump-namconfig
  485. }
  486. unset linkConfigList_
  487. }
  488. }
  490. Simulator instproc dump-namnodes {} {
  491. $self instvar Node_
  492. if ![$self is-started] {
  493. return
  494. }
  495. foreach nn [array names Node_] {
  496. if ![$Node_($nn) is-lan?] {
  497. $Node_($nn) dump-namconfig
  498. }
  499. }
  500. }
  502. Simulator instproc dump-namqueues {} {
  503. $self instvar link_
  504. if ![$self is-started] {
  505. return
  506. }
  507. foreach qn [array names link_] {
  508. $link_($qn) dump-nam-queueconfig
  509. }
  510. }
  512. # Write hierarchical masks/shifts into trace file
  513. Simulator instproc dump-namaddress {} {
  514. # First write number of hierarchies
  515. $self puts-nam-config 
  516.     "A -t * -n [AddrParams hlevel] -p 0 -o [AddrParams set 
  517. ALL_BITS_SET] -c [AddrParams McastShift] -a [AddrParams McastMask]"
  519. for {set i 1} {$i <= [AddrParams hlevel]} {incr i} {
  520. $self puts-nam-config "A -t * -h $i -m [AddrParams 
  521. NodeMask $i] -s [AddrParams NodeShift $i]"
  522. }
  523. }
  525. Simulator instproc init-nam {} {
  526. $self instvar annotationSeq_ 
  528. set annotationSeq_ 0
  530. # Setting nam trace file version first
  531. $self dump-namversion 1.0a5
  533. # write W event if needed
  534. $self dump-namwireless
  536. # Addressing scheme
  537. $self dump-namaddress
  539. # Color configuration for nam
  540. $self dump-namcolors
  542. # Node configuration for nam
  543. $self dump-namnodes
  545. # Lan and Link configurations for nam
  546. $self dump-namlinks 
  547. $self dump-namlans
  549. # nam queue configurations
  550. $self dump-namqueues
  552. # Traced agents for nam
  553. $self dump-namagents
  555. }
  557. #
  558. # Other animation control support
  559. # 
  560. Simulator instproc trace-annotate { str } {
  561. $self instvar annotationSeq_
  562. $self puts-ns-traceall [format 
  563. "v %s %s {set sim_annotation {%s}}" [$self now] eval $str]
  564. incr annotationSeq_
  565. $self puts-nam-config [format 
  566. "v -t %.15g -e sim_annotation %.15g $annotationSeq_ $str" 
  567. [$self now] [$self now] ]
  568. }
  570. proc trace_annotate { str } {
  571. set ns [Simulator instance]
  573. $ns trace-annotate $str
  574. }
  576. proc flash_annotate { start duration msg } {
  577. set ns [Simulator instance]
  578. $ns at $start "trace_annotate {$msg}"
  579. $ns at [expr $start+$duration] "trace_annotate periodic_message"
  580. }
  582. # rate's unit is second
  583. Simulator instproc set-animation-rate { rate } {
  584. # time_parse defined in tcl/rtp/session-rtp.tcl
  585. set r [time_parse $rate]
  586. # This old nam api (set_rate) works but is quite obscure,
  587. # the new api (set_rate_ext) is simpler.
  588. # $self puts-nam-config "v -t [$self now] set_rate [expr 10*log10($r)] 1"
  589. $self puts-nam-config "v -t [$self now] set_rate_ext $r 1"
  590. }