1 # debug.tcl --
2 #
3 # FIXME: This file needs a description here.
4 #
5 # Copyright (c) 1993-2002 The Regents of the University of California.
6 # All rights reserved.
7 #
8 # Redistribution and use in source and binary forms, with or without
9 # modification, are permitted provided that the following conditions are met:
10 #
11 # A. Redistributions of source code must retain the above copyright notice,
12 # this list of conditions and the following disclaimer.
13 # B. Redistributions in binary form must reproduce the above copyright notice,
14 # this list of conditions and the following disclaimer in the documentation
15 # and/or other materials provided with the distribution.
16 # C. Neither the names of the copyright holders nor the names of its
17 # contributors may be used to endorse or promote products derived from this
18 # software without specific prior written permission.
19 #
20 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
21 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
22 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
23 # ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR
24 # ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
25 # DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
26 # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
27 # CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
28 # OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
29 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30
31
32 #
33 # tunable debugging
34 #
35 proc DbgOut { args } {
36 mtrace trcMB $args
37 }
38
39 import Callback
40 Class MBDebugDlg -superclass Callback
41
42 MBDebugDlg instproc init {mgr showUI} {
43 $self instvar appmgr_ f_ isActive_ showUI_
44 $self tkvar drop_ cont_
45
46 set appmgr_ $mgr
47 set cont_ 5
48 set drop_ 5
49 set f_ ".__debug"
50 set showUI_ $showUI
51 set isActive_ 0
52
53 $self build
54 wm withdraw $f_
55 }
56
57 MBDebugDlg instproc disable_drop {} {
58 $self change_state 0
59 $self dismiss
60 $self callback disable_drop
61 }
62
63 MBDebugDlg instproc dismiss {} {
64 wm iconify [$self set f_]
65 }
66
67 MBDebugDlg instproc build {} {
68 $self instvar f_ showUI_
69
70 if [winfo exists $f_] {
71 if $showUI_ { wm deiconify $f_ }
72 return
73 }
74 set f_ [toplevel $f_]
75 frame $f_.f1 -borderwidth 2 -relief groove
76 label $f_.f1.drop -text "# pkts to drop: "
77 entry $f_.f1.e -textvariable [$self tkvarname drop_]
78 if $showUI_ {
79 pack $f_.f1.drop $f_.f1.e -side left -fill x
80 }
81 frame $f_.f2 -borderwidth 2 -relief groove
82 label $f_.f2.cont -text "# pkts to receive : "
83 entry $f_.f2.e -textvariable [$self tkvarname cont_]
84 button $f_.d -text "Dismiss" -command "$self dismiss"
85 button $f_.st -text "Disable pkt drop" -command "$self disable_drop"
86 if $showUI_ {
87 pack $f_.f2.cont $f_.f2.e -side left -fill x
88 pack $f_.f2 $f_.f1 -fill x -side top
89 pack $f_.d -side right -fill x
90 pack $f_.st -side left -fill x
91 }
92 }
93
94 MBDebugDlg instproc change_state {onoff} {
95 $self instvar f_ isActive_ activate_ counters_ showUI_
96
97 set isActive_ $onoff
98 if {$isActive_==1} {
99 # restart everything
100 foreach src [array names activate_] {
101 set activate_($src) [expr $counters_($src) + 1]
102 }
103 if {$showUI_} { $self build }
104 } else {
105 if {$showUI_ && [winfo exists $f_]} { wm withdraw $f_ }
106 }
107 }
108
109 MBDebugDlg instproc get_state {} {
110 $self instvar isActive_
111 return $isActive_
112 }
113
114 # called when a packet is received.
115 MBDebugDlg instproc recv {src} {
116 $self instvar counters_ action_ activate_ f_ drop_ cont_ \
117 isActive_
118 $self tkvar drop_ cont_
119
120 if {$isActive_ == 0} {
121 return "cont"
122 }
123 if ![info exists counters_($src)] {
124 set counters_($src) 0
125 set action_($src) "drop"
126 #start asking one the first packet
127 set activate_($src) 1
128 }
129 incr counters_($src)
130 if {$activate_($src)==$counters_($src)} {
131 if {$action_($src)=="drop"} {
132 if {$cont_>0} {
133 incr activate_($src) $cont_
134 set action_($src) "cont"
135 } else {
136 incr activate_($src)
137 }
138 } else {
139 if {$drop_>0} {
140 incr activate_($src) $drop_
141 set action_($src) "drop"
142 } else {
143 incr activate_($src)
144 }
145 }
146 }
147 if {$action_($src) == "drop"} {
148 DbgOut "Drop pkt#=$counters_($src), n_actv=$activate_($src)"
149 return "drop"
150 } else {
151 DbgOut "Recv pkt#:$counters_($src), actv=$activate_($src)"
152 return "cont"
153 }
154 }
155
156 Class DbgInfoWindow
157
158 DbgInfoWindow set id_ 0
159
160 DbgInfoWindow instproc init {title text} {
161 global InfoWindowOK_
162
163 set i [DbgInfoWindow set id_]
164 incr i
165 DbgInfoWindow set id_ $i
166 set w .dbgw$i
167 $self set path_ $w
168 toplevel $w
169 wm title $w $title
170 set InfoWindowOK_ ""
171 set f [frame $w.f]
172 set txt [text $f.text -yscrollcommand "$f.sy set"]
173 scrollbar $f.sy -orient vert -command "$f.text yview"
174 pack $txt -side left -fill both -expand true
175 pack $f.sy -side left -fill both -expand false
176 $txt insert insert $text
177 set dismiss [button $w.dismiss -text "dismiss" \
178 -command "delete $self"]
179 pack $f $dismiss -side top -anchor c -fill both
180 }
181
182 DbgInfoWindow instproc destroy {} {
183 destroy [$self set path_]
184 }
185
186 proc DumpCanvas {canv} {
187 set elements [$canv find withtag all]
188 append result "item#\ttype\tcoords\t text\n"
189 append result "======\t====\t=====\t ====\n"
190 foreach elt $elements {
191 append result "$elt\t"
192 append result [$canv type $elt]\t
193 append result [$canv coords $elt]
194 if {[$canv type $elt]=="text"} {
195 append result \t
196 append result [$canv itemcget $elt -text]
197 }
198 append result \n
199 }
200 return $result
201 }
202
This page was automatically generated by the
LXR engine.
Visit the LXR main site for more
information.