« back to all changes in this revision
Viewing changes to ibdiag/src/ibdiagui.tcl
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Benoit Mortier
- Date: 2010-01-11 22:22:00 UTC
- Revision ID: james.westby@ubuntu.com-20100111222200-53kum2et5nh13rv3
Tags: upstream-1.2-OFED-1.4.2
Import upstream version 1.2-OFED-1.4.2
- files added:
- config
- ibdiag
- ibdiag/config
- ibdiag/demo
- ibdiag/doc
- ibdiag/src
- ibdm
- ibdm/Clusters
- ibdm/config
- ibdm/doc
- ibdm/ibdm
- ibdm/ibdm/.deps
- ibdm/ibnl
- ibdm/replace
- ibdm/replace/.deps
- ibdm/src
- ibdm/src/.deps
- ibis
- ibis/config
- ibis/doc
- ibis/src
- ibis/src/.deps
- ibis/tests
- ibmgtsim
- ibmgtsim/config
- ibmgtsim/doc
- ibmgtsim/src
- ibmgtsim/tests
- ibmgtsim/utils
added
removed
ibdiag/src/ibdiagui.tcl
1
# This code should be sourced into ibis through ibdiagui wrapper
2
source [file join [file dirname [info script]] ibdebug.tcl]
3
4
if {[catch {package require ibdm} e]} {
5
puts "-E- ibdiagui depends on a 'IBDM' installation"
6
puts " Your ib_utils installation must be broken. Please reinstall"
7
puts " Error: $e"
8
exit 1
9
}
10
11
if {[catch {package require ibis} e]} {
12
puts "-E- ibdiagui depends on a 'ibis' installation"
13
puts " Your ib_utils installation must be broken. Please reinstall"
14
puts " Error: $e"
15
exit 1
16
}
17
18
##############################################################################
19
#
20
# GENERIC CANVAS ZOOMING UTILITIES
21
#
22
##############################################################################
23
24
#--------------------------------------------------------
25
#
26
# zoomMark
27
#
28
# Mark the first (x,y) coordinate for zooming.
29
#
30
#--------------------------------------------------------
31
proc zoomMark {c x y} {
32
global zoomArea
33
set zoomArea(x0) [$c canvasx $x]
34
set zoomArea(y0) [$c canvasy $y]
35
$c create rectangle $x $y $x $y -outline black -tag zoomArea
36
}
37
38
#--------------------------------------------------------
39
#
40
# zoomStroke
41
#
42
# Zoom in to the area selected by itemMark and
43
# itemStroke.
44
#
45
#--------------------------------------------------------
46
proc zoomStroke {c x y} {
47
global zoomArea
48
set zoomArea(x1) [$c canvasx $x]
49
set zoomArea(y1) [$c canvasy $y]
50
$c coords zoomArea $zoomArea(x0) $zoomArea(y0) $zoomArea(x1) $zoomArea(y1)
51
}
52
53
#--------------------------------------------------------
54
#
55
# zoomArea
56
#
57
# Zoom in to the area selected by itemMark and
58
# itemStroke.
59
#
60
#--------------------------------------------------------
61
proc zoomArea {c x y} {
62
global zoomArea
63
64
#--------------------------------------------------------
65
# Get the final coordinates.
66
# Remove area selection rectangle
67
#--------------------------------------------------------
68
set zoomArea(x1) [$c canvasx $x]
69
set zoomArea(y1) [$c canvasy $y]
70
$c delete zoomArea
71
72
#--------------------------------------------------------
73
# Check for zero-size area
74
#--------------------------------------------------------
75
if {($zoomArea(x0)==$zoomArea(x1)) || ($zoomArea(y0)==$zoomArea(y1))} {
76
return
77
}
78
79
#--------------------------------------------------------
80
# Determine size and center of selected area
81
#--------------------------------------------------------
82
set areaxlength [expr {abs($zoomArea(x1)-$zoomArea(x0))}]
83
set areaylength [expr {abs($zoomArea(y1)-$zoomArea(y0))}]
84
set xcenter [expr {($zoomArea(x0)+$zoomArea(x1))/2.0}]
85
set ycenter [expr {($zoomArea(y0)+$zoomArea(y1))/2.0}]
86
87
#--------------------------------------------------------
88
# Determine size of current window view
89
# Note that canvas scaling always changes the coordinates
90
# into pixel coordinates, so the size of the current
91
# viewport is always the canvas size in pixels.
92
# Since the canvas may have been resized, ask the
93
# window manager for the canvas dimensions.
94
#--------------------------------------------------------
95
set winxlength [winfo width $c]
96
set winylength [winfo height $c]
97
98
#--------------------------------------------------------
99
# Calculate scale factors, and choose smaller
100
#--------------------------------------------------------
101
set xscale [expr {$winxlength/$areaxlength}]
102
set yscale [expr {$winylength/$areaylength}]
103
if { $xscale > $yscale } {
104
set factor $yscale
105
} else {
106
set factor $xscale
107
}
108
109
#--------------------------------------------------------
110
# Perform zoom operation
111
#--------------------------------------------------------
112
zoom $c $factor $xcenter $ycenter $winxlength $winylength
113
}
114
115
#--------------------------------------------------------
116
#
117
# fit
118
#
119
# Fit to all objects
120
#--------------------------------------------------------
121
proc fit { canvas } {
122
set bbox [$canvas bbox all]
123
# provided view is the start and end of the viewed window in 0.0-1.0 of the
124
# entire region.
125
set xv [$canvas xview]
126
set yv [$canvas yview]
127
set xf [expr [lindex $xv 1] - [lindex $xv 0]]
128
set yf [expr [lindex $yv 1] - [lindex $yv 0]]
129
if {$yf < $xf} {
130
set scale $yf
131
} else {
132
set scale $xf
133
}
134
# we want to set the center of the canvas to the bbox / 2
135
foreach {x0 y0 x1 y1} $bbox {break}
136
set x [expr ($x0 + $x1)/2.0]
137
set y [expr ($y0 + $y1)/2.0]
138
zoom $canvas $scale $x $y
139
}
140
141
#--------------------------------------------------------
142
#
143
# zoom
144
#
145
# Zoom the canvas view, based on scale factor
146
# and centerpoint and size of new viewport.
147
# If the center point is not provided, zoom
148
# in/out on the current window center point.
149
#
150
# This procedure uses the canvas scale function to
151
# change coordinates of all objects in the canvas.
152
#
153
#--------------------------------------------------------
154
proc zoom { canvas factor \
155
{xcenter ""} {ycenter ""} \
156
{winxlength ""} {winylength ""} } {
157
158
#--------------------------------------------------------
159
# If (xcenter,ycenter) were not supplied,
160
# get the canvas coordinates of the center
161
# of the current view. Note that canvas
162
# size may have changed, so ask the window
163
# manager for its size
164
#--------------------------------------------------------
165
if { [string equal $winxlength ""] } {
166
set winxlength [winfo width $canvas]
167
}
168
if { [string equal $winylength ""] } {
169
set winylength [winfo height $canvas]
170
}
171
if { [string equal $xcenter ""] } {
172
set xcenter [$canvas canvasx [expr {$winxlength/2.0}]]
173
}
174
if { [string equal $ycenter ""] } {
175
set ycenter [$canvas canvasy [expr {$winylength/2.0}]]
176
}
177
178
#--------------------------------------------------------
179
# Scale all objects in the canvas
180
# Adjust our viewport center point
181
#--------------------------------------------------------
182
$canvas scale all 0 0 $factor $factor
183
set xcenter [expr {$xcenter * $factor}]
184
set ycenter [expr {$ycenter * $factor}]
185
186
#--------------------------------------------------------
187
# Get the size of all the items on the canvas.
188
#
189
# This is *really easy* using
190
# $canvas bbox all
191
# but it is also wrong. Non-scalable canvas
192
# items like text and windows now have a different
193
# relative size when compared to all the lines and
194
# rectangles that were uniformly scaled with the
195
# [$canvas scale] command.
196
#
197
# It would be better to tag all scalable items,
198
# and make a single call to [bbox].
199
# Instead, we iterate through all canvas items and
200
# their coordinates to compute our own bbox.
201
#--------------------------------------------------------
202
set x0 1.0e30; set x1 -1.0e30 ;
203
set y0 1.0e30; set y1 -1.0e30 ;
204
foreach item [$canvas find all] {
205
switch -exact [$canvas type $item] {
206
"arc" -
207
"line" -
208
"oval" -
209
"polygon" -
210
"rectangle" {
211
set coords [$canvas coords $item]
212
foreach {x y} $coords {
213
if { $x < $x0 } {set x0 $x}
214
if { $x > $x1 } {set x1 $x}
215
if { $y < $y0 } {set y0 $y}
216
if { $y > $y0 } {set y1 $y}
217
}
218
}
219
}
220
}
221
222
#--------------------------------------------------------
223
# Now figure the size of the bounding box
224
#--------------------------------------------------------
225
set xlength [expr {$x1-$x0}]
226
set ylength [expr {$y1-$y0}]
227
228
#--------------------------------------------------------
229
# But ... if we set the scrollregion and xview/yview
230
# based on only the scalable items, then it is not
231
# possible to zoom in on one of the non-scalable items
232
# that is outside of the boundary of the scalable items.
233
#
234
# So expand the [bbox] of scaled items until it is
235
# larger than [bbox all], but do so uniformly.
236
#--------------------------------------------------------
237
foreach {ax0 ay0 ax1 ay1} [$canvas bbox all] {break}
238
239
while { ($ax0<$x0) || ($ay0<$y0) || ($ax1>$x1) || ($ay1>$y1) } {
240
# triple the scalable area size
241
set x0 [expr {$x0-$xlength}]
242
set x1 [expr {$x1+$xlength}]
243
set y0 [expr {$y0-$ylength}]
244
set y1 [expr {$y1+$ylength}]
245
set xlength [expr {$xlength*3.0}]
246
set ylength [expr {$ylength*3.0}]
247
}
248
249
#--------------------------------------------------------
250
# Now that we've finally got a region defined with
251
# the proper aspect ratio (of only the scalable items)
252
# but large enough to include all items, we can compute
253
# the xview/yview fractions and set our new viewport
254
# correctly.
255
#--------------------------------------------------------
256
set newxleft [expr {($xcenter-$x0-($winxlength/2.0))/$xlength}]
257
set newytop [expr {($ycenter-$y0-($winylength/2.0))/$ylength}]
258
$canvas configure -scrollregion [list $x0 $y0 $x1 $y1]
259
$canvas xview moveto $newxleft
260
$canvas yview moveto $newytop
261
262
#--------------------------------------------------------
263
# Change the scroll region one last time, to fit the
264
# items on the canvas.
265
#--------------------------------------------------------
266
$canvas configure -scrollregion [$canvas bbox all]
267
}
268
269
##############################################################################
270
#
271
# NETWORK GRAPH UTILITIES
272
#
273
##############################################################################
274
275
# provide back color based on port speed / speed
276
proc portColor {port} {
277
set width [IBPort_width_get $port]
278
set speed [IBPort_speed_get $port]
279
280
set color [getColor $width${speed}G]
281
282
return $color
283
}
284
285
proc LoadAnnotationsFile {} {
286
global ANNOTATIONS
287
global ANNOTATION_FILE P
288
289
if {![info exists ANNOTATION_FILE]} {
290
return
291
}
292
if {![file readable $ANNOTATION_FILE]} {
293
return
294
}
295
296
set f [open $ANNOTATION_FILE r]
297
298
if {[info exists ANNOTATIONS]} {unset ANNOTATIONS}
299
300
while {[gets $f sLine] >= 0} {
301
# TODO: Support not only sysPort annotations
302
if {![regexp {(\S+)\s+(.+)} $sLine d1 name anno]} {
303
puts "-W- Skipping annotation file line:$sLine"
304
continue
305
}
306
set ANNOTATIONS(sysport:$name) $anno
307
}
308
}
309
310
proc DrawAnnotationFromFile {} {
311
global ANNOTATIONS
312
global C gFabric
313
314
# clear all annotations
315
$C delete withtag anno
316
317
# TODO: Support not only sysPort annotations
318
foreach e [array names ANNOTATIONS sysport:*] {
319
set sysPortName [string range $e [string length sysport:] end]
320
set anno $ANNOTATIONS($e)
321
322
# find the sys port
323
set sysPort [findSysPortByName $sysPortName]
324
if {$sysPort == ""} {
325
puts "-W- failed to find sys port:$sysPortName"
326
continue
327
}
328
329
set sysName [IBSystem_name_get [IBSysPort_p_system_get $sysPort]]
330
set portName [IBSysPort_name_get $sysPort]
331
# get the items of this port
332
set items [$C find withtag ${portName}&&sysport&&of:$sysName]
333
if {[llength $items] == 0} {
334
puts "-W- No items for sys port:$sysPortName"
335
continue
336
}
337
338
set bbox [$C bbox $items]
339
set outCoords [bboxCenter $bbox [expr rand()*0.95]]
340
$C create text $outCoords -tags anno -fill red \
341
-text $anno
342
puts "-I- Annotated $sysPortName with $anno"
343
}
344
}
345
346
347
# draw a single node
348
proc drawNode {node graph} {
349
global NODE
350
global IB_CA_NODE
351
set nodeName [IBNode_name_get $node]
352
353
if {[regexp {^node:(.*)} $nodeName d1 n]} {
354
set nodeName "0x$n"
355
}
356
357
set nodeLabel "\{$nodeName|"
358
set numPorts [IBNode_numPorts_get $node]
359
switch $numPorts {
360
1 {append nodeLabel "{<f1> P1}\}"}
361
2 {append nodeLabel "{<f1> P1|<f2> P2}\}"}
362
8 {
363
append nodeLabel "{<f1> P1|<f2> P2|<f3> P3|<f4> P4}|"
364
append nodeLabel "{<f5> P5|<f6> P6|<f7> P7|<f8> P8}\}"
365
}
366
24 {
367
append nodeLabel "{<f1> P1|<f2> P2|<f3> P3|<f4> P4}|"
368
append nodeLabel "{<f5> P5|<f6> P6|<f7> P7|<f8> P8}|"
369
append nodeLabel "{<f9> P9|<f10> P10|<f11> P11|<f12> P12}|"
370
append nodeLabel "{<f13> P13|<f14> P14|<f15> P15|<f16> P16}|"
371
append nodeLabel "{<f17> P17|<f18> P18|<f19> P19|<f20> P20}|"
372
append nodeLabel "{<f21> P21|<f22> P22|<f23> P23|<f24> P24}\}"
373
}
374
default {
375
puts "-E- Fail to handle $nodeName with $numPorts ports"
376
}
377
}
378
set NODE($node) \
379
[$graph addnode $nodeName shape record \
380
fontsize 7 label $nodeLabel \
381
fillcolor lightblue2 style filled \
382
]
383
384
if {[IBNode_type_get $node] == $IB_CA_NODE} {
385
$NODE($node) setattributes fillcolor lightgrey
386
}
387
}
388
389
proc drawSystem {sys graph} {
390
global SYSTEM
391
global SYS_PORT_IDX_BY_NAME
392
global EXPAND_SYSTEMS
393
global ANNOTATIONS
394
395
# puts "-I- Drawing system $sys"
396
set sysName [IBSystem_name_get $sys]
397
398
# remove extra "system" from auto systems
399
if {[regexp {^system:(.*)} $sysName d1 n]} {
400
set sysName "0x$n"
401
}
402
403
# the system might be expanded
404
if {[info exists EXPAND_SYSTEMS($sysName)]} {
405
set subGraph [$graph addsubgraph \
406
cluster_$sysName label $sysName labelfontsize 7 \
407
bgcolor wheat color black]
408
foreach nameNNode [IBSystem_NodeByName_get $sys] {
409
set node [lindex $nameNNode 1]
410
drawNode $node $subGraph
411
}
412
return
413
}
414
415
set sysLabel "\{$sysName|"
416
417
# we only draw system ports that are connected
418
set connSysPorts {}
419
set prevPrefix "-"
420
set first 1
421
set sysPortIdx 0
422
set numInLine 0
423
set sysPorts [IBSystem_PortByName_get $sys]
424
foreach sysNameNPort [lsort -dictionary -index 0 $sysPorts] {
425
foreach {portName sysPort} $sysNameNPort {break}
426
427
set fullName "$sysName/$portName"
428
set isAnnotated [info exists ANNOTATIONS(sysport:$fullName)]
429
set remSysPort [IBSysPort_p_remoteSysPort_get $sysPort]
430
if {$isAnnotated == 0 && $remSysPort == ""} {continue}
431
432
# we use heuristic to know when to break the ports line
433
if {![regexp {(.*)/[^/]+$} $portName d1 prefix]} {
434
set prefix ""
435
}
436
437
if {$prefix != $prevPrefix || $numInLine == 6} {
438
set numInLine 0
439
if {$first} {
440
append sysLabel "\{"
441
set first 0
442
} else {
443
append sysLabel "\}|\{"
444
}
445
set prevPrefix $prefix
446
} else {
447
if {$first == 0} {
448
append sysLabel "|"
449
} else {
450
set first 0
451
}
452
}
453
incr numInLine
454
append sysLabel "<f$sysPortIdx> $portName"
455
set SYS_PORT_IDX_BY_NAME($sys,$portName) $sysPortIdx
456
incr sysPortIdx
457
}
458
if {$first == 0} {
459
append sysLabel "\}\}"
460
} else {
461
append sysLabel "\}"
462
}
463
464
if {[regexp {^S[0-9a-fA-F]+$} $sysName]} {
465
set fillColor lightgrey
466
} else {
467
set fillColor lightyellow
468
}
469
470
global SYSTEM_ORDER
471
if {[info exist SYSTEM_ORDER] && [lsearch $SYSTEM_ORDER $sysName] >= 0} {
472
set SYSTEM($sys) \
473
[$graph addnode $sysName shape record \
474
fontsize 7 label $sysLabel labelfontcolor red \
475
fillcolor $fillColor style filled \
476
pos 10,10 ]
477
} else {
478
set SYSTEM($sys) \
479
[$graph addnode $sysName shape record \
480
fontsize 7 label $sysLabel labelfontcolor red \
481
fillcolor $fillColor style filled \
482
]
483
}
484
}
485
486
# draw a single node connections
487
proc drawNodeConns {node graph} {
488
global SYS_PORT_IDX_BY_NAME
489
global NODE SYSTEM
490
global EXPAND_SYSTEMS
491
global CONN
492
493
# puts "-V- Drawing connections of node:[IBNode_name_get $node]"
494
set sys [IBNode_p_system_get $node]
495
set sysName [IBSystem_name_get $sys]
496
set isExpanded [info exists EXPAND_SYSTEMS($sysName)]
497
for {set pn 1} {$pn <= [IBNode_numPorts_get $node]} {incr pn} {
498
set port [IBNode_getPort $node $pn]
499
if {$port == ""} {continue}
500
set portName [IBPort_getName $port]
501
502
set remPort [IBPort_p_remotePort_get $port]
503
if {$remPort == ""} {continue}
504
505
set remPortName [IBPort_getName $remPort]
506
if {[info exists CONN($remPortName)] } {continue}
507
508
set toNode [IBPort_p_node_get $remPort]
509
set toPortNum [IBPort_num_get $remPort]
510
set toSys [IBNode_p_system_get $toNode]
511
set toSysName [IBSystem_name_get $toSys]
512
513
# we can skip connections within same system if it
514
# is not expanded
515
if {($sys == $toSys) && !$isExpanded} {continue}
516
517
# now we need to figure out if we are connecting
518
# system ports or not
519
set sysPort [IBPort_p_sysPort_get $port]
520
if {$sysPort == "" || $isExpanded} {
521
set isDrawn [info exists NODE($node)]
522
if {$isDrawn == 0} {continue}
523
set fromRec $NODE($node)
524
set fromPort f$pn
525
} else {
526
if {![info exists SYSTEM($sys)]} {
527
puts "-W- System $sys is not drawn???"
528
continue
529
}
530
set fromRec $SYSTEM($sys)
531
set fromPortName [IBSysPort_name_get $sysPort]
532
if {![info exists SYS_PORT_IDX_BY_NAME($sys,$fromPortName)]} {
533
puts "-W- System $sys port $fromPortName is not drawn???"
534
continue
535
}
536
set fromPort "f$SYS_PORT_IDX_BY_NAME($sys,$fromPortName)"
537
}
538
539
set remSysPort [IBPort_p_sysPort_get $remPort]
540
set isRemExpanded [info exists EXPAND_SYSTEMS($toSysName)]
541
if {$remSysPort == "" || $isRemExpanded} {
542
set toRec $NODE($toNode)
543
set toPort f$toPortNum
544
} else {
545
set toRec $SYSTEM($toSys)
546
set toPortName [IBSysPort_name_get $remSysPort]
547
set toPort "f$SYS_PORT_IDX_BY_NAME($toSys,$toPortName)"
548
}
549
550
# puts "-V- Connecting from:$fromRec / $fromPort -> $toRec / $toPort ... "
551
set conn \
552
[$graph addedge "$toRec" "$fromRec" \
553
tailport $toPort headport $fromPort \
554
arrowhead normal arrowtail normal \
555
]
556
557
set CONN($portName) $conn
558
559
# use coloring for link speed/width
560
$conn setattributes color [portColor $port]
561
}
562
}
563
564
# process the code generated by graphviz
565
proc tagGraphVizCode {fabric code} {
566
global NODE SYSTEM
567
set newCode {}
568
569
# We scan through the code for text and on the first
570
# appearence of a node tag. Then try matching against known
571
# systems and nodes
572
set newCode ""
573
set numSystems 0
574
set numNodes 0
575
set numPorts 0
576
set prevNode ""
577
foreach sLine [split $code "\n"] {
578
if {[regexp {^(.*-text.*-tags\s+)(.*graph.*)} $sLine d1 pf tags]} {
579
append newCode "$pf {$tags system}\n"
580
incr numSystems
581
} elseif {[regexp {^(.*-text\s+(\S+).*-tags\s+)(.*node.*)} \
582
$sLine d1 pf txt tags]} {
583
# we can be on a new node -
584
if {$prevNode != $tags} {
585
# new node tag is it a system or node?
586
set sys [IBFabric_getSystem $fabric $txt]
587
if {$sys != ""} {
588
# puts "-V- TAGS: new sys $tags txt:$txt"
589
# a system
590
append newCode "$pf {$tags system}\n"
591
incr numSystems
592
set portTagType sysport
593
set parent $txt
594
} else {
595
# puts "-V- TAGS: new node $tags txt:$txt"
596
set portTagType port
597
append newCode "$pf {$tags node}\n"
598
incr numNodes
599
set parent $txt
600
}
601
set prevNode $tags
602
} else {
603
# puts "-V- TAGS: new $portTagType $tags txt:$txt"
604
605
# it must be a port
606
append newCode "$pf {$tags $portTagType of:$parent}\n"
607
incr numPorts
608
}
609
} else {
610
append newCode "$sLine\n"
611
}
612
}
613
# avoid the disabling of the widgets
614
regsub -all -- {-disabled} $newCode {} newCode
615
puts "-I- Marked $numSystems systems $numNodes nodes $numPorts ports"
616
return $newCode
617
}
618
619
# create selection box for each object type and assign bindings
620
proc bindMenusToTags {c} {
621
622
set objNHdl {
623
system showSysMenu
624
node showNodeMenu
625
port showPortMenu
626
sysport showSysPortMenu
627
}
628
629
foreach {type hdlFunc} $objNHdl {
630
foreach item [$c find withtag $type] {
631
foreach {x0 y0 x1 y1} [$c bbox $item] {break}
632
set dy [expr $y1 - $y0]
633
if {[catch {set name [$c itemcget $item -text]}]} {continue}
634
set tags [$c itemcget $item -tags]
635
$c addtag $name withtag $item
636
lappend tags name:$name
637
lappend tags ${type}Handle
638
set handleItem [$c create rectangle $x0 \
639
[expr $y0 - $dy] $x1 [expr $y1 + $dy] \
640
-outline {} -tags $tags]
641
642
$c bind $handleItem <1> [list $hdlFunc %W %x %y]
643
}
644
}
645
}
646
647
# provide a system list in the order stored by system names
648
# return a list of {name id} pairs
649
proc getSysList {fabric} {
650
global SYSTEM_ORDER
651
652
# first get all the systems sorted by name
653
set sysList {}
654
set nameList {}
655
if {[info exists SYSTEM_ORDER]} {
656
foreach sysName $SYSTEM_ORDER {
657
set sys [IBFabric_getSystem $fabric $sysName]
658
if {$sys != ""} {
659
puts "-I- Adding root $sysName"
660
lappend sysList [list $sysName $sys]
661
lappend nameList $sysName
662
}
663
}
664
}
665
666
# now build the name list not including the
667
foreach nameNSys [lsort -index 0 [IBFabric_SystemByName_get $fabric]] {
668
set name [lindex $nameNSys 0]
669
set sys [lindex $nameNSys 1]
670
if {[lsearch -exact $nameList $name] < 0} {
671
lappend sysList [list $name $sys]
672
lappend nameList $name
673
}
674
}
675
return $sysList
676
}
677
678
# take a canvans and a fabric and draw the fabric on the canvas
679
proc drawFabric {fabric c} {
680
global NODE SYSTEM CONN SYS_PORT_IDX_BY_NAME
681
global EXPAND_SYSTEMS
682
683
foreach g {CONN NODE SYSTEM SYS_PORT_IDX_BY_NAME} {
684
if {[info exists $g]} {
685
unset $g
686
}
687
}
688
689
# cleanup the canvas
690
$c delete all
691
692
# set graph [dotnew graph mode hier rankdir TB fontsize 7 \
693
# ranksep equaly labelfontsize 7 size 300,300]
694
set cbg [option get $c background *]
695
set graph [dotnew graph mode hier fontsize 7 \
696
ranksep equaly labelfontsize 7 bgcolor $cbg]
697
698
# we add each system as a subgraph and then
699
foreach nameNSys [getSysList $fabric] {
700
set sys [lindex $nameNSys 1]
701
drawSystem $sys $graph
702
}
703
704
# go over all nodes and connect them
705
foreach nameNNode [IBFabric_NodeByName_get $fabric] {
706
set node [lindex $nameNNode 1]
707
drawNodeConns $node $graph
708
}
709
710
SetStatus "-I- Calculating graph layout ..."
711
$graph layout NEATO
712
SetStatus "-I- Packing graph ..."
713
set code [$graph render]
714
SetStatus "-I- Packing graph ... done"
715
716
set newCode [tagGraphVizCode $fabric $code]
717
eval $newCode
718
bindMenusToTags $c
719
720
# fit the canvas
721
# fit $c
722
}
723
724
#assume there is a name:* tag in teh list return the name
725
proc getNameTag {tags} {
726
set idx [lsearch -glob $tags name:*]
727
if {$idx < 0} {
728
return ""
729
}
730
return [string range [lindex $tags $idx] 5 end]
731
}
732
733
proc getOfTag {tags} {
734
set idx [lsearch -glob $tags of:*]
735
if {$idx < 0} {
736
return ""
737
}
738
return [string range [lindex $tags $idx] 3 end]
739
}
740
741
# set the EXPANDED for the system under the cursor and
742
# call redraw
743
proc expand {c x y} {
744
global EXPAND_SYSTEMS
745
global gFabric C
746
set tags [$c itemcget current -tags]
747
if {[llength $tags] == 0} {return}
748
set sysName [getNameTag $tags]
749
750
SetStatus "-I- Expanding System: $sysName ..."
751
puts "-I- Expanding System: $sysName ..."
752
753
set EXPAND_SYSTEMS($sysName) 1
754
755
after 100 drawFabric $gFabric $C
756
}
757
758
# set the EXPANDED for the system under the cursor and
759
# call redraw
760
proc deExpand {c x y} {
761
global EXPAND_SYSTEMS
762
global gFabric C
763
set tags [$c itemcget current -tags]
764
if {[llength $tags] == 0} {return}
765
set sysName [getNameTag $tags]
766
767
SetStatus "-I- De-Expanding System: $sysName ..."
768
puts "-I- De-Expanding System: $sysName ..."
769
770
if {[info exists EXPAND_SYSTEMS($sysName)]} {
771
unset EXPAND_SYSTEMS($sysName)
772
}
773
774
after 100 drawFabric $gFabric $C
775
}
776
777
proc showSysMenu {c x y} {
778
global gFabric
779
set tags [$c itemcget current -tags]
780
set sysName [getNameTag $tags]
781
puts "System: $sysName"
782
# find the port
783
set sys [IBFabric_getSystem $gFabric $sysName]
784
if {$sys == ""} {
785
puts "-E- fail to find system $sysName in the fabric"
786
return
787
}
788
PropsUpdate system $sys
789
}
790
791
proc showNodeMenu {c x y} {
792
global gFabric
793
set tags [$c itemcget current -tags]
794
set nodeName [getNameTag $tags]
795
# add node: if guid:
796
if {[regexp {0x([0-9a-fA-F]{16})} $nodeName d1 n]} {
797
set nodeName "node:$n"
798
}
799
puts "Node: $nodeName"
800
801
set node [IBFabric_getNode $gFabric $nodeName]
802
if {$node == ""} {
803
puts "-E- fail to find node $nodeName in the fabric"
804
puts " [IBFabric_NodeByName_get $gFabric]"
805
return
806
}
807
808
PropsUpdate node $node
809
}
810
811
proc showPortMenu {c x y} {
812
global gPort gFabric
813
set tags [$c itemcget current -tags]
814
# puts "-V- $tags"
815
set ntag [getOfTag $tags]
816
set node [$c find withtag ${ntag}&&node ]
817
set nodeName [$c itemcget $node -text]
818
set portName [getNameTag $tags]
819
puts "Port: $nodeName $portName"
820
821
# find the port
822
set node [IBFabric_getNode $gFabric $nodeName]
823
if {$node == ""} {
824
puts "-E- fail to find node $nodeName in the fabric"
825
puts " [IBFabric_NodeByName_get $gFabric]"
826
return
827
}
828
829
regexp {[0-9]+} $portName portNum
830
set port [IBNode_getPort $node $portNum]
831
if {$port == ""} {
832
puts "-E- fail to find port $nodeName/$portName in the fabric"
833
return
834
}
835
836
PropsUpdate port $port
837
}
838
839
proc showSysPortMenu {c x y} {
840
global gPort gFabric
841
set tags [$c itemcget current -tags]
842
set ntag [getOfTag $tags]
843
set systag [$c find withtag ${ntag}&&system ]
844
set sysName [$c itemcget $systag -text]
845
# add node: if guid:
846
if {[regexp {0x([0-9a-fA-F]{16})} $sysName d1 n]} {
847
set nodeName "system:$n"
848
}
849
set portName [getNameTag $tags]
850
puts "SysPort: $sysName $portName"
851
852
# find the port
853
set sys [IBFabric_getSystem $gFabric $sysName]
854
if {$sys == ""} {
855
puts "-E- fail to find system $sysName in the fabric"
856
return
857
}
858
859
set sysPort [IBSystem_getSysPort $sys $portName]
860
if {$sysPort == ""} {
861
puts "-E- fail to find system port $sysName/$portName in the fabric"
862
return
863
}
864
865
PropsUpdate sysport $sysPort
866
}
867
868
# Perform the fabric update based on the availability of a topology
869
# and the LST file
870
proc GraphUpdate {lstFile} {
871
global G
872
global gTopoFabric
873
global gLstFabric
874
global gFabric
875
global C
876
877
# cleanup
878
foreach fType {gFabric gTopoFabric gLstFabric} {
879
if {[info exists $fType]} {
880
delete_IBFabric [set $fType]
881
}
882
}
883
884
set gFabric [new_IBFabric]
885
886
if {![info exists G(argv:topo.file)]} {
887
puts "-I- Parsing subnet lst: $lstFile"
888
IBFabric_parseSubnetLinks $gFabric $lstFile
889
} else {
890
# load the topo
891
set gTopoFabric [new_IBFabric]
892
IBFabric_parseTopology $gTopoFabric $G(argv:topo.file)
893
894
# load the lst
895
set gLstFabric [new_IBFabric]
896
IBFabric_parseSubnetLinks $gLstFabric $lstFile
897
898
# compare and merge
899
set m [ibdmMatchFabrics $gTopoFabric $gLstFabric \
900
$G(argv:sys.name) $G(argv:port.num) $G(data:root.port.guid)]
901
puts $m
902
903
ibdmBuildMergedFabric $gTopoFabric $gLstFabric $gFabric
904
puts "-I- Topo merged"
905
}
906
907
drawFabric $gFabric $C
908
}
909
910
# clear all highlights
911
proc guiClearAllMarking {} {
912
global C
913
914
set items [$C find withtag mark]
915
puts "-I- Clearing mark on $items"
916
foreach item $items {
917
if {[llength [$C gettags $item]] == 1} {
918
$C delete $item
919
} else {
920
$C dtag $item mark
921
$C itemconfigure $item -fill black -activefill black
922
}
923
}
924
}
925
926
proc SetStatus {msg} {
927
global S O StatusLine
928
$S configure -state normal
929
set StatusLine $msg
930
$S configure -state readonly
931
set color $O(color:txtDef)
932
if {[regexp {^-([WEI])-} $msg d1 type]} {
933
switch $type {
934
E {set color $O(color:txtErr)}
935
W {set color $O(color:txtWarn)}
936
I {set color $O(color:txtInfo)}
937
}
938
}
939
$S configure -foreground [lindex $color 2]
940
update
941
}
942
943
# zoom to object by ibdm id
944
proc zoomToObjByIbdmId {type obj} {
945
global C
946
947
switch $type {
948
system {
949
set name [IBSystem_name_get $obj]
950
set items [$C find withtag ${name}&&system]
951
}
952
node {
953
set name [IBNode_name_get $obj]
954
set items [$C find withtag ${name}&&node]
955
}
956
sysport {
957
set sys [IBSysPort_p_system_get $obj]
958
set sysName [IBSystem_name_get $sys]
959
set name [IBSysPort_name_get $obj]
960
set items [$C find withtag ${name}&&sysport&&of:$sysName]
961
}
962
port {
963
set node [IBPort_p_node_get $obj]
964
set nodeName [IBNode_name_get $node]
965
set name "P[IBPort_num_get $obj]"
966
set items [$C find withtag ${name}&&port&&of:$nodeName]
967
}
968
}
969
if {[llength $items]} {
970
set bbox [$C bbox $items]
971
set xy [bboxCenter $bbox]
972
zoom $C 1.0 [lindex $xy 0] [lindex $xy 1]
973
puts "-I- Zooming on $bbox"
974
} else {
975
puts "-I- No items for $type $obj"
976
}
977
}
978
979
# find and highlight a system by name
980
proc guiHighLightByName {objType name} {
981
global gFabric C
982
set items ""
983
switch $objType {
984
system {
985
set sys [IBFabric_getSystem $gFabric $name]
986
if {$sys == ""} {
987
SetStatus "-W- Fail to find system by name:$name"
988
return
989
}
990
PropsUpdate system $sys
991
992
set items [$C find withtag ${name}&&system]
993
}
994
sysport {
995
# we need to try each hier sep
996
set sysName ""
997
set sys ""
998
set subNames [split $name /]
999
1000
while {[llength $subNames]} {
1001
set n [lindex $subNames 0]
1002
set subNames [lrange $subNames 1 end]
1003
if {$sysName != ""} { append sysName / }
1004
append sysName $n
1005
set sys [IBFabric_getSystem $gFabric $sysName]
1006
if {$sys != ""} { break }
1007
}
1008
1009
if {$sys == ""} {
1010
SetStatus "-W- Fail to find system for port by name:\"$name\""
1011
return
1012
}
1013
1014
set portName [join $subNames /]
1015
set sysPort [IBSystem_getSysPort $sys $portName]
1016
if {$sysPort == ""} {
1017
SetStatus "-W- Fail to find system port by name:\"$name\""
1018
return
1019
}
1020
PropsUpdate sysport $sysPort
1021
set items [$C find withtag ${portName}&&sysport&&of:$sysName]
1022
}
1023
node {
1024
set node [IBFabric_getNode $gFabric $name]
1025
if {$node == ""} {
1026
SetStatus "-W- Fail to find node by name:$name"
1027
return
1028
}
1029
PropsUpdate node $node
1030
set items [$C find withtag ${name}&&node]
1031
# we might need to look for a system...
1032
if {[llength $items] == 0} {
1033
set sys [IBNode_p_system_get $node]
1034
set sysName [IBSystem_name_get $sys]
1035
return [guiHighLightByName system $sysName]
1036
}
1037
}
1038
port {
1039
if {![regexp {(.*)/P([0-9]+)} $name d1 nodeName portNum]} {
1040
SetStatus "-W- Fail to find node for port by name:\"$name\""
1041
return
1042
}
1043
set node [IBFabric_getNode $gFabric $nodeName]
1044
if {$node == ""} {
1045
SetStatus "-W- Fail to find node for port by name:\"$name\""
1046
return
1047
}
1048
1049
set port [IBNode_getPort $node $portNum]
1050
if {$port == ""} {
1051
SetStatus "-W- Fail to find port by name:\"$name\""
1052
return
1053
}
1054
PropsUpdate port $port
1055
set portName "P$portNum"
1056
1057
set items [$C find withtag ${portName}&&port&&of:$nodeName]
1058
1059
if {[llength $items] == 0} {
1060
set sysPort [IBPort_p_sysPort_get $port]
1061
set sys [IBNode_p_system_get $node]
1062
set sysName [IBSystem_name_get $sys]
1063
if {$sysPort == ""} {
1064
# it is internal - just highlight the sys
1065
return [guiHighLightByName system $sysName]
1066
} else {
1067
set sysPortName "$sysName/[IBSysPort_name_get $sysPort]"
1068
return [guiHighLightByName sysport $sysPortName]
1069
}
1070
}
1071
1072
}
1073
}
1074
1075
if {![llength $items]} {
1076
SetStatus "-W- Fail to find any displayed obejct for $objType name:\"$name\""
1077
return
1078
}
1079
1080
set bbox [$C bbox $items]
1081
zoom $C 1.0 [lindex $bbox 0] [lindex $bbox 1]
1082
foreach item $items {
1083
$C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
1084
$C addtag mark withtag $item
1085
}
1086
1087
return $items
1088
}
1089
1090
# find and highlight a system by name
1091
proc guiHighLightByGuid {objType guid} {
1092
global gFabric C
1093
1094
# we try getting by system/node/port
1095
set sys [IBFabric_getSystemByGuid $gFabric $guid]
1096
set node [IBFabric_getNodeByGuid $gFabric $guid]
1097
set port [IBFabric_getPortByGuid $gFabric $guid]
1098
1099
switch $objType {
1100
system {
1101
if {$sys != ""} {
1102
set name [IBSystem_name_get $sys]
1103
} elseif {$node != ""} {
1104
set sys [IBNode_p_system_get $node]
1105
set name [IBSystem_name_get $sys]
1106
} elseif {$port != ""} {
1107
set node [IBPort_p_node_get $port]
1108
set sys [IBNode_p_system_get $node]
1109
set name [IBSystem_name_get $sys]
1110
} else {
1111
SetStatus "-W- Fail to find system by guid:$guid"
1112
return
1113
}
1114
1115
set obj $sys
1116
set items [$C find withtag ${name}&&system]
1117
}
1118
node {
1119
if {$node != ""} {
1120
set name [IBNode_name_get $node]
1121
} elseif {$port != ""} {
1122
set node [IBPort_p_node_get $port]
1123
set name [IBNode_name_get $node]
1124
} else {
1125
SetStatus "-W- Fail to find node by guid:$guid"
1126
return
1127
}
1128
set obj $node
1129
set items [$C find withtag ${name}&&node]
1130
}
1131
port {
1132
if {$port == ""} {
1133
SetStatus "-W- Fail to find port by guid:$guid"
1134
return
1135
}
1136
set obj $port
1137
1138
set nodeName [IBNode_name_get [IBPort_p_node_get $port]]
1139
set name "P[IBPort_num_get $port]"
1140
set items [$C find withtag ${name}&&port&&of:$nodeName]
1141
}
1142
sysport {
1143
if {$port == ""} {
1144
SetStatus "-W- Fail to find system port by guid:$guid"
1145
return
1146
}
1147
1148
set sysPort [IBPort_p_sysPort_get $port]
1149
if {$sysPort == ""} {
1150
SetStatus "-W- Fail to find system port for port with guid:$guid"
1151
return
1152
}
1153
1154
set sys [IBSysPort_p_system_get $sysPort]
1155
set sysName [IBSystem_name_get $sys]
1156
set name [IBSysPort_name_get $sysPort]
1157
set obj $sysPort
1158
set items [$C find withtag ${name}&&sysport&&of:$sysName]
1159
}
1160
}
1161
1162
if {![llength $items]} {
1163
SetStatus "-W- Fail to find any displayed obejct for $objType name:\"$name\""
1164
return
1165
}
1166
1167
PropsUpdate $objType $obj
1168
set bbox [$C bbox $items]
1169
zoom $C 1.0 [lindex $bbox 0] [lindex $bbox 1]
1170
foreach item $items {
1171
$C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
1172
$C addtag mark withtag $item
1173
}
1174
return $items
1175
}
1176
1177
# find and highlight a system by name
1178
proc guiHighLightByLid {objType lid} {
1179
global gFabric C
1180
1181
# we try getting port by lid:
1182
set port [IBFabric_getPortByLid $gFabric $lid]
1183
if {$port == ""} {
1184
SetStatus "-W- Fail to find port by lid:$lid"
1185
return
1186
}
1187
1188
switch $objType {
1189
system {
1190
set node [IBPort_p_node_get $port]
1191
set sys [IBNode_p_system_get $node]
1192
set name [IBSystem_name_get $sys]
1193
set items [$C find withtag ${name}&&system]
1194
}
1195
node {
1196
set node [IBPort_p_node_get $port]
1197
set name [IBNode_name_get $node]
1198
set items [$C find withtag ${name}&&node]
1199
}
1200
port {
1201
set nodeName [IBNode_name_get [IBPort_p_node_get $port]]
1202
set name "P[IBPort_num_get $port]"
1203
set items [$C find withtag ${name}&&port&&of:$nodeName]
1204
}
1205
sysport {
1206
set sysPort [IBPort_p_sysPort_get $port]
1207
if {$sysPort == ""} {
1208
SetStatus "-W- Fail to find system port for port with lid:$lid"
1209
return
1210
}
1211
1212
set sys [IBSysPort_p_system_get $sysPort]
1213
set sysName [IBSystem_name_get $sys]
1214
set name [IBSysPort_name_get $sysPort]
1215
set items [$C find withtag ${name}&&sysport&&of:$sysName]
1216
}
1217
}
1218
1219
if {![llength $items]} {
1220
SetStatus "-W- Fail to find any displayed obejct for $objType lid:$lid"
1221
return
1222
}
1223
1224
set bbox [$C bbox $items]
1225
zoom $C 1.0 [lindex $bbox 0] [lindex $bbox 1]
1226
foreach item $items {
1227
$C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
1228
$C addtag mark withtag $item
1229
}
1230
return $items
1231
}
1232
1233
# return a sys port if exists
1234
proc findSysPortByName {name} {
1235
global gFabric
1236
# we need to try each hier sep
1237
set sysName ""
1238
set sys ""
1239
set subNames [split $name /]
1240
set sysPort ""
1241
while {[llength $subNames]} {
1242
set n [lindex $subNames 0]
1243
set subNames [lrange $subNames 1 end]
1244
if {$sysName != ""} { append sysName / }
1245
append sysName $n
1246
set sys [IBFabric_getSystem $gFabric $sysName]
1247
if {$sys != ""} { break }
1248
}
1249
1250
if {$sys != ""} {
1251
set portName [join $subNames /]
1252
set sysPort [IBSystem_getSysPort $sys $portName]
1253
}
1254
return $sysPort
1255
}
1256
1257
# simpler as we know the node ports end with P[0-9]+
1258
proc findPortByName {name} {
1259
global gFabric
1260
1261
if {![regexp {(.*)/P([0-9]+)$} $name d1 nodeName portNum]} {
1262
return ""
1263
}
1264
1265
set node [IBFabric_getNode $gFabric $nodeName]
1266
if {$node == ""} {
1267
return ""
1268
}
1269
1270
return [IBNode_getPort $node $portNum]
1271
}
1272
1273
proc bboxCenter {bbox {xScale 0.5} {yScale 0.5}} {
1274
foreach {x0 y0 x1 y1} $bbox {break}
1275
return [list [expr ($x0*(1-$xScale) + $x1*$xScale)] \
1276
[expr ($y0*(1-$yScale) + $y1*$yScale)] ]
1277
}
1278
1279
# highlight all objects accross the directed route
1280
proc guiHighLightByDR {startPort route} {
1281
global C
1282
# first we try to get the given start port
1283
set allItems {}
1284
1285
set sysPort [findSysPortByName $startPort]
1286
if {$sysPort == ""} {
1287
# try to get a port by that name
1288
set port [findPortByName $startPort]
1289
if {$port == ""} {
1290
SetStatus "-W- Fail to find system port or port with name:\"$startPort\""
1291
return
1292
}
1293
} else {
1294
set port [IBSysPort_p_nodePort_get $sysPort]
1295
}
1296
1297
# need to traverse from that port/sysport
1298
# if the given path is made of [] we need to convert hex to dec
1299
if {[regexp {^\s*([[][0-9a-fA-F][]])+\s*$} $route]} {
1300
set dr {}
1301
foreach h [split $route {[]}] {
1302
if {$h != ""} {
1303
lappend dr [expr 0x$h]
1304
}
1305
}
1306
} else {
1307
set dr [split $route ", "]
1308
}
1309
1310
if {[lindex $dr 0] == 0} {
1311
set dr [lrange $dr 1 end]
1312
}
1313
1314
# traverse the path
1315
set hop 0
1316
foreach p $dr {
1317
set items ""
1318
set node [IBPort_p_node_get $port]
1319
set outPort [IBNode_getPort $node $p]
1320
if {$outPort == ""} {
1321
SetStatus "-W- Got dead end on path at node:\"[IBNode_name_get $node]\" port:$p\""
1322
break
1323
}
1324
1325
# highlight outgoing port and sysport
1326
set nodeName [IBNode_name_get [IBPort_p_node_get $outPort]]
1327
set name "P[IBPort_num_get $outPort]"
1328
set iItems [$C find withtag ${name}&&port&&of:$nodeName]
1329
set allItems [concat $allItems $iItems]
1330
1331
set sysPort [IBPort_p_sysPort_get $outPort]
1332
if {$sysPort != ""} {
1333
set sys [IBSysPort_p_system_get $sysPort]
1334
set sysName [IBSystem_name_get $sys]
1335
set name [IBSysPort_name_get $sysPort]
1336
set items [$C find withtag ${name}&&sysport&&of:$sysName]
1337
set iItems [concat $iItems $items]
1338
}
1339
set allItems [concat $allItems $iItems]
1340
1341
if {[llength $iItems]} {
1342
set outCoords [bboxCenter [$C bbox [lindex $iItems 0]] [expr rand()*0.95]]
1343
}
1344
1345
set port [IBPort_p_remotePort_get $outPort]
1346
if {$port == ""} {
1347
SetStatus "-W- No remote port on path at node:\"[IBNode_name_get $node]\" port:$p\""
1348
$C create text $outCoords -tags mark -fill [getColor mark] -text "DEAD END ($p)"
1349
break
1350
}
1351
1352
# highlight input port and sysport
1353
set items ""
1354
set nodeName [IBNode_name_get [IBPort_p_node_get $port]]
1355
set name "P[IBPort_num_get $port]"
1356
set items [$C find withtag ${name}&&port&&of:$nodeName]
1357
set allItems [concat $allItems $items]
1358
set oItems $items
1359
1360
set sysPort [IBPort_p_sysPort_get $port]
1361
if {$sysPort != ""} {
1362
set sys [IBSysPort_p_system_get $sysPort]
1363
set sysName [IBSystem_name_get $sys]
1364
set name [IBSysPort_name_get $sysPort]
1365
set items [$C find withtag ${name}&&sysport&&of:$sysName]
1366
set oItems [concat $oItems $items]
1367
}
1368
set allItems [concat $allItems $oItems]
1369
1370
if {[llength $oItems]} {
1371
set inCoords [bboxCenter [$C bbox [lindex $oItems 0]] [expr rand()*0.95]]
1372
1373
# create a marker
1374
$C create line [concat $outCoords $inCoords] \
1375
-tags mark -fill [getColor mark] -arrow last
1376
set x [expr ([lindex $outCoords 0] + [lindex $inCoords 0]) / 2.0]
1377
set y [expr ([lindex $outCoords 1] + [lindex $inCoords 1]) / 2.0]
1378
$C create text $x $y -anchor w -text $hop -tags mark -fill [getColor mtxt]
1379
}
1380
1381
incr hop
1382
}
1383
1384
foreach item $allItems {
1385
$C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
1386
$C addtag mark withtag $item
1387
}
1388
return $allItems
1389
}
1390
1391
##############################################################################
1392
#
1393
# PROPS Widget Commands
1394
#
1395
##############################################################################
1396
proc PropsUpdate {objType ibdmHandle {zoom 0}} {
1397
global P
1398
# prevents recursion loop
1399
global _PropsUpdate_inside
1400
if {$ibdmHandle == ""} {return}
1401
1402
if {[info exists _PropsUpdate_inside] && $_PropsUpdate_inside} {return}
1403
set _PropsUpdate_inside 1
1404
1405
if {$ibdmHandle == ""} { return }
1406
1407
foreach c [winfo child $P] {
1408
pack forget $c
1409
}
1410
1411
switch $objType {
1412
system {PropsSystem $ibdmHandle}
1413
node {PropsNode $ibdmHandle}
1414
port {PropsPort $ibdmHandle}
1415
sysport {PropsSysPort $ibdmHandle}
1416
}
1417
1418
# zoom to that object
1419
if {$zoom} {
1420
zoomToObjByIbdmId $objType $ibdmHandle
1421
}
1422
set _PropsUpdate_inside 0
1423
}
1424
1425
proc PropsSystem {sys} {
1426
global P PROPS
1427
set PROPS(sys,id) $sys
1428
set PROPS(sys,name) [IBSystem_name_get $sys]
1429
set PROPS(sys,type) [IBSystem_type_get $sys]
1430
set PROPS(sys,guid) [IBSystem_guid_get $sys]
1431
set PROPS(sys,nodes,id) [IBSystem_NodeByName_get $sys]
1432
set PROPS(sys,nodes) [llength $PROPS(sys,nodes,id)]
1433
set b $PROPS(sys,nodes,menu)
1434
$b delete 0 end
1435
set i 0
1436
foreach nameNNode $PROPS(sys,nodes,id) {
1437
$b insert $i command -label [lindex $nameNNode 0] \
1438
-command "PropsUpdate node [lindex $nameNNode 1]"
1439
incr i
1440
}
1441
pack $P.sys -expand yes -fill x -anchor nw
1442
}
1443
1444
proc PropsNode {node} {
1445
global P PROPS
1446
pack $P.node -expand yes -fill x -anchor nw
1447
set PROPS(node,id) $node
1448
set PROPS(node,name) [IBNode_name_get $node]
1449
set PROPS(node,guid) [IBNode_guid_get $node]
1450
set PROPS(node,ports) [IBNode_numPorts_get $node]
1451
set PROPS(node,dev) [IBNode_devId_get $node]
1452
set PROPS(node,rev) [IBNode_revId_get $node]
1453
set PROPS(node,vend) [IBNode_vendId_get $node]
1454
set PROPS(node,sys,id) [IBNode_p_system_get $node]
1455
set PROPS(node,sys) [IBSystem_name_get $PROPS(node,sys,id)]
1456
set PROPS(node,dr) [getDrToNode $node]
1457
set b $PROPS(node,ports,menu)
1458
$b delete 0 end
1459
set i 0
1460
for {set pn 1} {$pn <= $PROPS(node,ports)} {incr pn} {
1461
set port [IBNode_getPort $node $pn]
1462
if {$port != ""} {
1463
$b insert $i command -label "P$pn" \
1464
-command "PropsUpdate port $port 1"
1465
incr i
1466
}
1467
}
1468
}
1469
1470
proc PropsPort {port} {
1471
global P PROPS
1472
pack $P.port -expand yes -fill x -anchor nw
1473
set PROPS(port,id) $port
1474
set PROPS(port,name) [IBPort_getName $port]
1475
set PROPS(port,guid) [IBPort_guid_get $port]
1476
set PROPS(port,lid) [IBPort_base_lid_get $port]
1477
set PROPS(port,speed) [IBPort_speed_get $port]
1478
set PROPS(port,width) [IBPort_width_get $port]
1479
set node [IBPort_p_node_get $port]
1480
set PROPS(port,node,id) $node
1481
set PROPS(port,node) [IBNode_name_get $node]
1482
set remPort [IBPort_p_remotePort_get $port]
1483
set PROPS(port,rem,id) $remPort
1484
if {$remPort != ""} {
1485
set PROPS(port,rem) [IBPort_getName $remPort]
1486
} else {
1487
set PROPS(port,rem) "NOT CONNECTED"
1488
}
1489
set sysPort [IBPort_p_sysPort_get $port]
1490
set PROPS(port,sysp,id) $sysPort
1491
if {$sysPort != ""} {
1492
set sys [IBSysPort_p_system_get $sysPort]
1493
set PROPS(port,sysp) \
1494
"[IBSystem_name_get $sys]/[IBSysPort_name_get $sysPort]"
1495
} else {
1496
set PROPS(port,sysp) "NONE"
1497
}
1498
}
1499
1500
proc PropsSysPort {sysPort} {
1501
global P PROPS ANNOTATIONS
1502
pack $P.sysport -expand yes -fill x -anchor nw
1503
set PROPS(sysport,id) $sysPort
1504
set PROPS(sysport,name) [IBSysPort_name_get $sysPort]
1505
set PROPS(sysport,sys,id) [IBSysPort_p_system_get $sysPort]
1506
set PROPS(sysport,sys) [IBSystem_name_get $PROPS(sysport,sys,id)]
1507
set port [IBSysPort_p_nodePort_get $sysPort]
1508
set PROPS(sysport,width) [IBPort_width_get $port]
1509
set PROPS(sysport,speed) [IBPort_speed_get $port]
1510
set node [IBPort_p_node_get $port]
1511
set PROPS(sysport,port,id) $port
1512
set PROPS(sysport,port) \
1513
"[IBNode_name_get $node]/P[IBPort_num_get $port]"
1514
set remSysPort [IBSysPort_p_remoteSysPort_get $sysPort]
1515
set PROPS(sysport,rem,id) $remSysPort
1516
if {$remSysPort != ""} {
1517
set remSys [IBSysPort_p_system_get $remSysPort]
1518
set PROPS(sysport,rem) \
1519
"[IBSystem_name_get $remSys]/[IBSysPort_name_get $remSysPort]"
1520
} else {
1521
set PROPS(sysport,rem) "NOT CONNECTED"
1522
}
1523
set fullName "$PROPS(sysport,sys)/$PROPS(sysport,name)"
1524
if {[info exists ANNOTATIONS(sysport:$fullName)]} {
1525
set PROPS(sysport,anno) $ANNOTATIONS(sysport:$fullName)
1526
} else {
1527
set PROPS(sysport,anno) ""
1528
}
1529
}
1530
1531
# get a DR to a port by its ID
1532
# BFS untill finding it ...
1533
proc getDrToNode {targetNode} {
1534
global G
1535
global gFabric
1536
1537
set startPort [IBFabric_getPortByGuid $gFabric $G(data:root.port.guid)]
1538
if {$startPort == ""} {
1539
puts "-E- Fail to find start port !"
1540
return -1
1541
}
1542
1543
set Q [list [list [IBPort_p_node_get $startPort] "0"]]
1544
while {[llength $Q]} {
1545
set nodeNPath [lindex $Q 0]
1546
set Q [lreplace $Q 0 0]
1547
1548
set node [lindex $nodeNPath 0]
1549
set path [lindex $nodeNPath 1]
1550
1551
if {$node == $targetNode} {
1552
puts "-I- Found node [IBNode_name_get $targetNode] at path:$path"
1553
return $path
1554
}
1555
1556
set VISITED($node) 1
1557
1558
for {set pn 1} {$pn <= [IBNode_numPorts_get $node]} {incr pn} {
1559
set port [IBNode_getPort $node $pn]
1560
if {$port == ""} {continue}
1561
set remPort [IBPort_p_remotePort_get $port]
1562
if {$remPort == ""} {continue}
1563
set remNode [IBPort_p_node_get $remPort]
1564
if {[info exists VISITED($remNode)]} {continue}
1565
lappend Q [list $remNode "$path,$pn"]
1566
}
1567
}
1568
puts "-W- Failed to find node [IBNode_name_get $targetNode]"
1569
return -1
1570
}
1571
1572
# select a port number gui
1573
proc numSelector {maxNum title} {
1574
global numSelectorVal
1575
if {![winfo exists .num_select]} {
1576
set t [toplevel .num_select]
1577
wm withdraw $t
1578
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
1579
label $t.l -text $title
1580
pack $t.l -side top -expand yes -fill x
1581
set o [tk_optionMenu $f.b numSelectorVal 1]
1582
for {set i 2} {$i < $maxNum} {incr i} {
1583
$o insert $i command -label $i \
1584
-command "global numSelectorVal; update;set numSelectorVal $i"
1585
}
1586
set numSelectorVal 1
1587
pack $f.b -side left -padx 2 -pady 2
1588
pack $f
1589
}
1590
wm title .num_select $title
1591
wm deiconify .num_select
1592
update
1593
tkwait variable numSelectorVal
1594
destroy .num_select
1595
return $numSelectorVal
1596
}
1597
1598
# we rely on the current PROP for
1599
proc setPortState {state {port 0}} {
1600
global PROPS
1601
1602
if {$port == 0} {
1603
set port $PROPS(port,id)
1604
}
1605
1606
set node [IBPort_p_node_get $port]
1607
1608
set drPath [getDrToNode $node]
1609
if {$drPath == -1} {
1610
return
1611
}
1612
1613
set portNum [IBPort_num_get $port]
1614
if {[catch {set res [exec ibportstate -D $drPath $portNum $state]} e]} {
1615
LogAppend "\n-E---------------------------------------------------\n$e"
1616
} else {
1617
LogAppend "\n-I---------------------------------------------------\n$res"
1618
}
1619
}
1620
1621
proc setNodePortState {state} {
1622
global PROPS
1623
set node $PROPS(node,id)
1624
1625
set drPath [getDrToNode $node]
1626
if {$drPath == -1} {
1627
return
1628
}
1629
1630
set portNum [numSelector [IBNode_numPorts_get $node] \
1631
"Select a port number"]
1632
if {$portNum == ""} { return }
1633
1634
if {[catch {set res [exec ibportstate -D $drPath $portNum $state]} e]} {
1635
LogAppend "\n-E---------------------------------------------------\n$e"
1636
} else {
1637
LogAppend "\n-I---------------------------------------------------\n$res"
1638
}
1639
}
1640
1641
proc setSysPortState {state} {
1642
global PROPS
1643
1644
set sysPort $PROPS(sysport,id)
1645
set port [IBSysPort_p_nodePort_get $sysPort]
1646
setPortState $state $port
1647
}
1648
1649
proc portCounters {op {port 0}} {
1650
global PROPS
1651
1652
if {$port == 0} {
1653
set port $PROPS(port,id)
1654
}
1655
1656
set lid [IBPort_base_lid_get $port]
1657
if {$lid == 0} {
1658
}
1659
set portNum [IBPort_num_get $port]
1660
if {$op == "clr"} {
1661
set opt -R
1662
} else {
1663
set opt ""
1664
}
1665
1666
set cmd "perfquery $opt $lid $portNum"
1667
if {[catch {eval "set res \[exec $cmd\]"} e]} {
1668
LogAppend "\n-E---------------------------------------------------\n$cmd\n$e"
1669
} else {
1670
LogAppend "\n-I---------------------------------------------------\n$cmd\n$res"
1671
}
1672
}
1673
1674
# when port counters are queries from Node
1675
# NOTE: we can not rely on the existance of the port
1676
proc nodePortCounters {op} {
1677
global PROPS
1678
set node $PROPS(node,id)
1679
1680
set portNum [numSelector [IBNode_numPorts_get $node] \
1681
"Select a port number"]
1682
if {$portNum == ""} { return }
1683
1684
# find first port that match
1685
set port ""
1686
for {set pn 1} {$pn < [IBNode_numPorts_get $node]} {incr pn} {
1687
set port [IBNode_getPort $node $pn]
1688
if {$port != ""} {break}
1689
}
1690
if {$port == ""} {return}
1691
1692
set lid [IBPort_base_lid_get $port]
1693
if {$op == "clr"} {
1694
set opt -R
1695
} else {
1696
set opt ""
1697
}
1698
1699
if {[catch {eval "set res [exec perfquery $opt $lid $portNum]"} e]} {
1700
LogAppend "\n-E---------------------------------------------------\n$e"
1701
} else {
1702
LogAppend "\n-I---------------------------------------------------\n$res"
1703
}
1704
}
1705
1706
proc sysPortCounters {op} {
1707
global PROPS
1708
1709
set sysPort $PROPS(sysport,id)
1710
set port [IBSysPort_p_nodePort_get $sysPort]
1711
portCounters $op $port
1712
}
1713
1714
##############################################################################
1715
#
1716
# LOG WIDGET COMMANDS
1717
#
1718
##############################################################################
1719
1720
# perform log analysis from the given index
1721
proc LogAnalyze {{startIndex 0.0}} {
1722
global L
1723
set text [$L get $startIndex end]
1724
# loop through the text for sections:
1725
set startChar 0
1726
set numErrs 0
1727
set numWarnings 0
1728
set numInfos 0
1729
1730
set rex "\n-(\[IWE\])-\[^\n\]*(\n\[^-\]\[^\n\]*)*"
1731
while {[regexp -start $startChar -indices -- $rex $text all type]} {
1732
set start [lindex $all 0]
1733
set type [string range $text [lindex $type 0] [lindex $type 1]]
1734
set sIdx [lindex $all 0]
1735
set eIdx [expr [lindex $all 1] + 1]
1736
switch $type {
1737
E { set tagName errors; incr numErrs }
1738
W { set tagName warnings; incr numWarnings }
1739
I { set tagName infos; incr numInfos }
1740
}
1741
$L tag add $tagName "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
1742
set startChar [lindex $all 1]
1743
}
1744
puts "-I- Found $numErrs errors $numWarnings warnings $numInfos infos"
1745
1746
# Now scan for names guids and routes...
1747
set startChar 0
1748
set numNames 0
1749
1750
set rex "\\s+\"(\[^0-9\]\[^\"\]+)\"\\s+"
1751
while {[regexp -start $startChar -indices -- $rex $text all name]} {
1752
set sIdx [lindex $name 0]
1753
set eIdx [expr [lindex $name 1] + 1]
1754
$L tag add NAME "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
1755
set startChar [lindex $all 1]
1756
incr numNames
1757
}
1758
1759
set startChar 0
1760
set numLids 0
1761
set rex {(lid|LID)[\s:=]*(0x[0-9a-fA-F]+|[0-9]+)}
1762
while {[regexp -start $startChar -indices -- $rex $text all pre lid]} {
1763
set sIdx [lindex $lid 0]
1764
set eIdx [expr [lindex $lid 1] + 1]
1765
$L tag add LID "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
1766
set startChar [lindex $all 1]
1767
incr numLids
1768
}
1769
1770
set startChar 0
1771
set numGuids 0
1772
set rex {[Gg][Uu][Ii][Dd]=*(0x[0-9a-fA-F]+)}
1773
while {[regexp -start $startChar -indices -- $rex $text all guid]} {
1774
set sIdx [lindex $guid 0]
1775
set eIdx [expr [lindex $guid 1] + 1]
1776
$L tag add GUID "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
1777
set startChar [lindex $all 1]
1778
incr numGuids
1779
}
1780
1781
set startChar 0
1782
set numRoutes 0
1783
set rex {\"([0-9]+(,[0-9]+)*)\"}
1784
while {[regexp -start $startChar -indices -- $rex $text all route]} {
1785
set sIdx [lindex $route 0]
1786
set eIdx [expr [lindex $route 1] + 1]
1787
$L tag add ROUTE "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
1788
set startChar [lindex $all 1]
1789
incr numRoutes
1790
}
1791
1792
puts "-I- Found $numNames names $numLids LIDS $numGuids GUIDs $numRoutes Directed-Routes"
1793
}
1794
1795
proc LogUpdate {log} {
1796
global L
1797
1798
#puts $log
1799
1800
# Filter out any "discovring" message
1801
set nlog $log
1802
set discRex "-I- Discovering the subnet ... \[0-9\]+ nodes .\[0-9\]+ Switches & \[0-9\]+ CA-s. discovered.\\s*\n"
1803
regsub -all -- $discRex $log "" nlog
1804
1805
# perform the log area update
1806
$L configure -state normal
1807
$L delete 0.0 end
1808
$L insert 0.0 $nlog
1809
1810
# Do some hypertexting
1811
LogAnalyze
1812
$L configure -state disabled
1813
}
1814
1815
proc LogAppend {log {scrollToPos 1}} {
1816
global L
1817
set start [$L index end]
1818
$L configure -state normal
1819
$L insert end "$log\n"
1820
$L configure -state disabled
1821
if {$scrollToPos} {
1822
$L see end
1823
}
1824
LogAnalyze $start
1825
update
1826
}
1827
1828
# an object tag was selected
1829
proc LogObjSelect {log type w x y} {
1830
global G
1831
# get the tag text under the x y
1832
set startNEnd [$log tag prevrange $type @$x,$y]
1833
set val [$log get [lindex $startNEnd 0] [lindex $startNEnd 1]]
1834
switch $type {
1835
NAME {
1836
if {[guiHighLightByName port $val] != ""} {
1837
SetStatus "-I- Found Port $val"
1838
} elseif {[guiHighLightByName node $val] != ""} {
1839
SetStatus "-I- Found Node $val"
1840
} elseif {[guiHighLightByName system $val] != ""} {
1841
SetStatus "-I- Found System $val"
1842
} elseif {[guiHighLightByName sysport $val] != ""} {
1843
SetStatus "-I- Found System Port $val"
1844
} else {
1845
SetStatus "-I- Failed to find object with name $val"
1846
}
1847
}
1848
LID {
1849
set x [guiHighLightByLid sysport $val]
1850
set y [guiHighLightByLid port $val]
1851
if {$x != "" || $y != ""} {
1852
SetStatus "-I- Find by LID succeeded"
1853
}
1854
}
1855
ROUTE {
1856
guiHighLightByDR "$G(argv:sys.name)/P$G(argv:port.num)" $val
1857
}
1858
GUID {
1859
set x [guiHighLightByGuid system $val]
1860
set y [guiHighLightByGuid sysport $val]
1861
if {$x != "" || $y != ""} {
1862
SetStatus "-I- Find by GUID succeeded"
1863
}
1864
}
1865
}
1866
}
1867
1868
# initialize the props guid such that we have a pannel
1869
# for each object type
1870
proc initPropsGui {p} {
1871
global PROPS O
1872
1873
set props {
1874
{sys SYSTEM
1875
{
1876
name Name ""
1877
type Type ""
1878
guid GUID ""
1879
nodes "\#Node" {PropsUpdate node $PROPS(sys,node,id) 1}
1880
}
1881
}
1882
{node NODE
1883
{
1884
name Name ""
1885
guid GUID ""
1886
dr "Directed Route" ""
1887
sys System {PropsUpdate system $PROPS(node,sys,id) 1}
1888
ports "\#Ports" {PropsUpdate port $PROPS(node,port,id) 1}
1889
dev "Device ID" ""
1890
rev "Revision ID" ""
1891
vend "Vendor ID"
1892
}
1893
}
1894
{port PORT
1895
{
1896
name Name ""
1897
guid GUID ""
1898
lid LID ""
1899
speed Speed ""
1900
width Width ""
1901
node Node {PropsUpdate node $PROPS(port,node,id) 1}
1902
rem Conn {PropsUpdate port $PROPS(port,rem,id) 1}
1903
sysp SysPort {PropsUpdate sysport $PROPS(port,sysp,id) 1}
1904
}
1905
}
1906
{sysport "FRONT PANEL PORT"
1907
{
1908
name Name ""
1909
sys System {PropsUpdate system $PROPS(sysport,sys,id) 1}
1910
port "Node Port" {PropsUpdate port $PROPS(sysport,port,id) 1}
1911
rem "Connected to" {PropsUpdate sysport $PROPS(sysport,rem,id) 1}
1912
width Width ""
1913
speed Speed ""
1914
anno Annotation ""
1915
}
1916
}
1917
}
1918
1919
set cmds {
1920
{sys}
1921
{node
1922
{{UP "setNodePortState enable"} {DOWN "setNodePortState disable"}}
1923
{{"PM Get" "nodePortCounters get"} {"PM Clr" "nodePortCounters clr"}}
1924
}
1925
{port
1926
{{UP "setPortState enable"} {DOWN "setPortState disable"}}
1927
{{"PM Get" "portCounters get"} {"PM Clr" "portCounters clr"}}
1928
}
1929
{sysport
1930
{{UP "setSysPortState enable"} {DOWN "setSysPortState disable"}}
1931
{{"PM Get" "sysPortCounters get"} {"PM Clr" "sysPortCounters clr"}}
1932
}
1933
}
1934
1935
foreach propSet $props {
1936
set obj [lindex $propSet 0]
1937
frame $p.$obj -background [lindex $O(color:$obj) 2] -padx 2 -pady 2
1938
set f $p.$obj.f
1939
frame $f
1940
set header [lindex $propSet 1]
1941
label $f.l -text $header
1942
pack $f.l -side top
1943
foreach {attr lbl cmd} [lindex $propSet 2] {
1944
frame $f.$attr -borderwidth 2 -relief ridge
1945
label $f.$attr.l -text "$lbl:"
1946
1947
if {[string range $lbl 0 0] == "\#"} {
1948
label $f.$attr.v -textvariable PROPS($obj,$attr)
1949
set PROPS($obj,$attr,menu) \
1950
[tk_optionMenu $f.$attr.m PROPS($obj,$attr,sel) \
1951
"Select a [string range $lbl 1 end]"]
1952
pack $f.$attr.l -side top -anchor w
1953
pack $f.$attr.m -side right -anchor e -expand yes -fill x
1954
pack $f.$attr.v -side left -anchor w
1955
set PROPS($obj,$attr,cb) $cmd
1956
set cmd ""
1957
} else {
1958
entry $f.$attr.v -textvariable PROPS($obj,$attr) \
1959
-exportselection 1 -state readonly -relief flat
1960
pack $f.$attr.l $f.$attr.v -side top -anchor nw \
1961
-expand true -fill x
1962
}
1963
pack $f.$attr -side top -fill x -anchor nw
1964
if {$cmd != ""} {
1965
bind $f.$attr.l <ButtonPress-2> $cmd
1966
bind $f.$attr.v <ButtonPress-2> $cmd
1967
}
1968
}
1969
pack $f -side top -expand yes -fill both
1970
}
1971
1972
foreach cmdSet $cmds {
1973
set lineIdx 0
1974
set obj [lindex $cmdSet 0]
1975
foreach lineDef [lrange $cmdSet 1 end] {
1976
set f $p.$obj.f
1977
incr lineIdx
1978
frame $f.cmds$lineIdx
1979
set bIdx 0
1980
foreach bnc $lineDef {
1981
set b [lindex $bnc 0]
1982
set c [lindex $bnc 1]
1983
incr bIdx
1984
button $f.cmds$lineIdx.$bIdx -text $b -command $c
1985
pack $f.cmds$lineIdx.$bIdx -side left -anchor w
1986
}
1987
pack $f.cmds$lineIdx -side top -anchor w
1988
}
1989
}
1990
}
1991
1992
##############################################################################
1993
#
1994
# MAIN MENU COMMANDS
1995
#
1996
##############################################################################
1997
proc getNodeLid {node} {
1998
set port ""
1999
for {set pn 1} {$pn <= [IBNode_numPorts_get $node]} {incr pn} {
2000
set port [IBNode_getPort $node $pn]
2001
if {$port != ""} {
2002
set remPort [IBPort_p_remotePort_get $port]
2003
if {$remPort != ""} {break}
2004
}
2005
}
2006
if {$remPort == ""} {return 0}
2007
set lid [IBPort_base_lid_get $port]
2008
return $lid
2009
}
2010
2011
# given a key and a list of ley/value pairs get the pair
2012
proc assoc {key key_list} {
2013
foreach kv $key_list {
2014
if {[lindex $kv 0] == $key} {return [lindex $kv 1]}
2015
}
2016
2017
return ""
2018
}
2019
2020
proc SetVL0Statics {} {
2021
global gFabric
2022
2023
set staticCredits 0x68
2024
foreach nNNode [IBFabric_NodeByName_get $gFabric] {
2025
set node [lindex $nNNode 1]
2026
set sys [IBNode_p_system_get $node]
2027
set name "[IBSystem_name_get $sys]/[lindex $nNNode 0]"
2028
set devId [IBNode_devId_get $node]
2029
set lid [getNodeLid $node]
2030
if {$lid == 0} {
2031
puts "-W- Ignoring node $name with zero LID"
2032
continue
2033
}
2034
2035
# differet treatment for switches and HCAs
2036
switch $devId {
2037
23108 -
2038
25204 -
2039
25208 -
2040
25218 {
2041
# port 1 0x100A0.24 (len 7)
2042
set v [crRead $lid 0x100A0]
2043
set d [assoc data $v]
2044
if {$d == ""} {
2045
puts "-W- Failed to obtain data from $name lid:$lid"
2046
continue
2047
}
2048
2049
set nd [format 0x%x [expr $d & 0x8fffffff | ($staticCredits << 24)]]
2050
if {$d != $nd} {
2051
puts "-I- Updating $name P1 $d -> $nd"
2052
crWrite $lid $nd 0x100A0
2053
}
2054
if {$devId != 25208} {
2055
# port 2 0x108A0.24
2056
set v [crRead $lid 0x108A0]
2057
set d [assoc data $v]
2058
if {$d == ""} {
2059
puts "-W- Failed to obtain data from $name lid:$lid"
2060
continue
2061
}
2062
2063
set nd [format 0x%x [expr $d & 0x8fffffff | ($staticCredits << 24)]]
2064
if {$d != $nd} {
2065
puts "-I- Updating $name P2 $d -> $nd"
2066
crWrite $lid $nd 0x108A0
2067
}
2068
}
2069
}
2070
47396 {
2071
set addr 0x101280
2072
for {set i 0} {$i < 24} {incr i} {
2073
# IB port 1 101280.16
2074
# CR 0 101280.16 (len 16)
2075
# CR 1 102280.16
2076
# CR 23 118280.16
2077
set v [crRead $lid $addr]
2078
set d [assoc data $v]
2079
if {$d == ""} {
2080
puts "-W- Failed to obtain data from $name lid:$lid"
2081
continue
2082
}
2083
set nd [format 0x%x [expr $d & 0xffff | ($staticCredits << 16)]]
2084
if {$d != $nd} {
2085
puts "-I- Updating $name P[expr $i + 1] $d -> $nd"
2086
crWrite $lid $nd $addr
2087
}
2088
2089
incr addr 0x1000
2090
}
2091
}
2092
default {
2093
puts "-W- Ignoring node $name with devId:$devId"
2094
}
2095
}
2096
}
2097
2098
}
2099
2100
proc DiagNet {} {
2101
global G
2102
global testModeDir
2103
global IBDIAGNET_FLAGS
2104
2105
# can we just load existing files?
2106
if {$testModeDir != 0} {
2107
set f [open [file join $testModeDir ibdiagnet.stdout.log] r]
2108
set res [read $f]
2109
close $f
2110
set lstFile [file join $testModeDir ibdiagnet.lst]
2111
} else {
2112
set lstFile /tmp/ibdiagnet.lst
2113
set r ""
2114
LogAppend "-I-Invoking ibdiagnet ...."
2115
# puts "-I- Invoking ibdiagnet ...."
2116
if {[catch {set r [eval "exec ibdiagnet $IBDIAGNET_FLAGS"]} e]} {
2117
set res "-E- Error calling ibdiagnet:$e\n"
2118
append res $r
2119
} else {
2120
set res $r
2121
}
2122
}
2123
2124
LogUpdate $res
2125
2126
GraphUpdate $lstFile
2127
}
2128
2129
# reread the annotations file and enforce DISABLED state
2130
# and UP for the rest
2131
proc EnforceAnnotations {} {
2132
global ANNOTATIONS
2133
LoadAnnotationsFile
2134
set numEn 0
2135
set numDis 0
2136
foreach e [array names ANNOTATIONS sysport:*] {
2137
set sysPortName [string range $e [string length sysport:] end]
2138
set anno $ANNOTATIONS($e)
2139
2140
# find the sys port
2141
set sysPort [findSysPortByName $sysPortName]
2142
if {$sysPort == ""} {
2143
puts "-W- failed to find sys port:$sysPortName"
2144
continue
2145
}
2146
2147
set port [IBSysPort_p_nodePort_get $sysPort]
2148
set node [IBPort_p_node_get $port]
2149
2150
if {[regexp DISABLED $anno]} {
2151
SetStatus "-I- Disabling $sysPortName"
2152
set state disable
2153
incr numDis
2154
} else {
2155
SetStatus "-I- Enabling $sysPortName"
2156
set state enable
2157
incr numEn
2158
}
2159
2160
set drPath [getDrToNode $node]
2161
if {$drPath == -1} {
2162
return
2163
}
2164
2165
set portNum [IBPort_num_get $port]
2166
catch {set res [exec ibportstate -D $drPath $portNum $state]}
2167
}
2168
SetStatus "-I- Annotation Enforced: Enabled:$numEn Disbled:$numDis"
2169
2170
}
2171
2172
proc FindByName {} {
2173
global FindByName
2174
if {![winfo exists .find_by_name]} {
2175
set t [toplevel .find_by_name]
2176
wm withdraw $t
2177
2178
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2179
2180
labelframe $f.e -text "Name:" -padx 2 -pady 2 -borderwidth 2
2181
entry $f.e.e -textvariable FindByName(name)
2182
pack $f.e.e -side left -fill x -expand yes
2183
2184
labelframe $f.b -text "Object Type:" -padx 2 -pady 2 -borderwidth 2
2185
foreach {type name} {system System sysport "System Port" node Node port Port} {
2186
radiobutton $f.b.b$type -text "$name" -variable FindByName(type) \
2187
-relief flat -value $type
2188
pack $f.b.b$type -side top -pady 2 -anchor w
2189
}
2190
pack $f.e $f.b -side top -expand yes -fill both
2191
frame $f.x
2192
button $f.x.f -text FIND \
2193
-command {guiHighLightByName $FindByName(type) $FindByName(name)}
2194
button $f.x.c -text CLEAR -command guiClearAllMarking
2195
pack $f.x.f $f.x.c -side left -fill x -expand yes
2196
pack $f.x -side bottom -fill x -expand yes
2197
pack $f
2198
wm title .find_by_name "IBDiagUI - Find object by name"
2199
set FindByName(type) system
2200
2201
}
2202
wm deiconify .find_by_name
2203
}
2204
2205
proc FindByGUID {} {
2206
global FindByGuid
2207
if {![winfo exists .find_by_guid]} {
2208
set t [toplevel .find_by_guid]
2209
wm withdraw $t
2210
2211
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2212
2213
labelframe $f.e -text "GUID:" -padx 2 -pady 2 -borderwidth 2
2214
entry $f.e.e -textvariable FindByGuid(guid)
2215
pack $f.e.e -side left -fill x -expand yes
2216
2217
labelframe $f.b -text "Object Type:" -padx 2 -pady 2 -borderwidth 2
2218
foreach {type name} {system "System" sysport "System Port" node "Node" port "Port"} {
2219
radiobutton $f.b.b$type -text "$name" -variable FindByGuid(type) \
2220
-relief flat -value $type
2221
pack $f.b.b$type -side top -pady 2 -anchor w
2222
}
2223
pack $f.e $f.b -side top -expand yes -fill both
2224
frame $f.x
2225
button $f.x.f -text FIND \
2226
-command {guiHighLightByGuid $FindByGuid(type) $FindByGuid(guid)}
2227
button $f.x.c -text CLEAR -command guiClearAllMarking
2228
pack $f.x.f $f.x.c -side left -fill x -expand yes
2229
pack $f.x -side bottom -fill x -expand yes
2230
pack $f
2231
wm title .find_by_guid "IBDiagUI - Find object by GUID"
2232
set FindByGuid(type) system
2233
2234
}
2235
wm deiconify .find_by_guid
2236
}
2237
2238
proc FindByLID {} {
2239
global FindByLid
2240
if {![winfo exists .find_by_lid]} {
2241
set t [toplevel .find_by_lid]
2242
wm withdraw $t
2243
2244
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2245
2246
labelframe $f.e -text "LID:" -padx 2 -pady 2 -borderwidth 2
2247
entry $f.e.e -textvariable FindByLid(lid)
2248
pack $f.e.e -side left -fill x -expand yes
2249
2250
labelframe $f.b -text "Object Type:" -padx 2 -pady 2 -borderwidth 2
2251
foreach {type name} {system "System" sysport "System Port" node "Node" port "Port"} {
2252
radiobutton $f.b.b$type -text "$name" -variable FindByLid(type) \
2253
-relief flat -value $type
2254
pack $f.b.b$type -side top -pady 2 -anchor w
2255
}
2256
pack $f.e $f.b -side top -expand yes -fill both
2257
frame $f.x
2258
button $f.x.f -text FIND \
2259
-command {guiHighLightByLid $FindByLid(type) $FindByLid(lid)}
2260
button $f.x.c -text CLEAR -command guiClearAllMarking
2261
pack $f.x.f $f.x.c -side left -fill x -expand yes
2262
pack $f.x -side bottom -fill x -expand yes
2263
pack $f
2264
wm title .find_by_lid "IBDiagUI - Find object holding a LID"
2265
set FindByLid(type) system
2266
2267
}
2268
wm deiconify .find_by_lid
2269
}
2270
2271
proc FindByDR {} {
2272
global FindByDR G
2273
if {![winfo exists .find_by_dr]} {
2274
set t [toplevel .find_by_dr]
2275
wm withdraw $t
2276
2277
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2278
2279
labelframe $f.e -text "Directed Route:" -padx 2 -pady 2 -borderwidth 2
2280
entry $f.e.e -textvariable FindByDR(DR)
2281
pack $f.e.e -side left -fill x -expand yes
2282
2283
labelframe $f.p -text "Start Port:" -padx 2 -pady 2 -borderwidth 2
2284
entry $f.p.e -textvariable FindByDR(port)
2285
pack $f.p.e -side left -fill x -expand yes
2286
pack $f.e $f.p -side top -expand yes -fill both
2287
frame $f.x
2288
button $f.x.f -text FIND \
2289
-command {guiHighLightByDR $FindByDR(port) $FindByDR(DR)}
2290
button $f.x.c -text CLEAR -command guiClearAllMarking
2291
pack $f.x.f $f.x.c -side left -fill x -expand yes
2292
pack $f.x -side bottom -fill x -expand yes
2293
pack $f
2294
wm title .find_by_dr "IBDiagUI - Find objects on a Directed Route"
2295
set FindByDR(port) "$G(argv:sys.name)/P$G(argv:port.num)"
2296
}
2297
wm deiconify .find_by_dr
2298
}
2299
2300
2301
proc setColor {b opt} {
2302
global O
2303
foreach {w desc val} $O($opt) {break}
2304
set color [tk_chooseColor -title "Choose a $desc color" -initialcolor $val]
2305
if {$color != ""} {
2306
set O($opt) [list $w $desc $color]
2307
$b configure -background $color
2308
}
2309
}
2310
2311
proc getColor {col} {
2312
global O
2313
if {[info exists O(color:$col)]} {
2314
return [lindex $O(color:$col) 2]
2315
} else {
2316
puts "-W- could not find color $col"
2317
return black
2318
}
2319
setLogColors
2320
}
2321
2322
# Display a form for setting fabric roots
2323
proc SetRoots {} {
2324
global C gFabric
2325
if {![winfo exists .set_roots_opts]} {
2326
set t [toplevel .set_roots_opts]
2327
wm withdraw $t
2328
2329
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2330
label $f.l -text "Root systems names:"
2331
entry $f.e -textvariable SYSTEM_ORDER
2332
button $f.b -text REDRAW -command "drawFabric $gFabric $C"
2333
pack $f.l $f.e $f.b -side top -expand true -fill x
2334
pack $f
2335
wm title .set_roots_opts "IBDiagUI - Set Roots Options"
2336
}
2337
wm deiconify .set_roots_opts
2338
}
2339
2340
# Display a form for setting colors
2341
proc SetColorOpts {} {
2342
global O
2343
if {![winfo exists .set_color_opts]} {
2344
set t [toplevel .set_color_opts]
2345
wm withdraw $t
2346
2347
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2348
set prevFirstWord ""
2349
foreach opt [lsort [array name O color:*]] {
2350
foreach {w desc val} $O($opt) {break}
2351
set firstWord [lindex $desc 0]
2352
if {$firstWord != $prevFirstWord} {
2353
set wName [string tolower $firstWord]
2354
set wf [labelframe $f.$wName -text "$firstWord:" \
2355
-padx 2 -pady 2 -borderwidth 2]
2356
pack $wf -side top -expand yes -fill x
2357
set prevFirstWord $firstWord
2358
}
2359
button $wf.$w -text [lrange $desc 1 end] \
2360
-command "setColor $wf.$w $opt" \
2361
-background $val
2362
pack $wf.$w -side left -pady 2 -anchor w -fill x
2363
}
2364
pack $f
2365
wm title .set_color_opts "IBDiagUI - Set Color Options"
2366
}
2367
wm deiconify .set_color_opts
2368
}
2369
2370
proc SetAnnotationsFile {} {
2371
global O
2372
if {![winfo exists .load_annos]} {
2373
set t [toplevel .load_annos]
2374
wm withdraw $t
2375
2376
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2377
label $f.l -text "Annotation File Name"
2378
entry $f.e -textvariable ANNOTATION_FILE
2379
button $f.b -text LOAD -command LoadAnnotationsFile
2380
pack $f.l $f.e $f.b -side top -expand yes -fill x
2381
pack $f
2382
2383
wm title .load_annos "IBDiagUI - Set Color Options"
2384
2385
if {![info exists ANNOTATION_FILE]} {
2386
set ANNOTATION_FILE ""
2387
}
2388
}
2389
wm deiconify .load_annos
2390
}
2391
2392
proc SetIBDiagFlags {} {
2393
global O
2394
if {![winfo exists .ibdiag_flags]} {
2395
set t [toplevel .ibdiag_flags]
2396
wm withdraw $t
2397
2398
set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
2399
label $f.l -text "IBDiagNet Flags:"
2400
entry $f.e -textvariable IBDIAGNET_FLAGS
2401
pack $f.l $f.e -side top -expand yes -fill x
2402
pack $f
2403
2404
wm title .ibdiag_flags "IBDiagUI - Set IBDiagNet Flags"
2405
}
2406
wm deiconify .ibdiag_flags
2407
}
2408
2409
2410
proc HelpAbout {} {
2411
catch {destroy .help_about}
2412
set tl [toplevel .help_about]
2413
label $tl.l -text {
2414
IBDIAG GUI
2415
2416
Version: 1.0
2417
Date: Sep 2006
2418
Author: Eitan Zahavi <eitan@mellanox.co.il>
2419
}
2420
pack $tl.l
2421
}
2422
2423
##############################################################################
2424
#
2425
# GUI INITIALIZATION
2426
#
2427
##############################################################################
2428
2429
# save as much as possible in .ibdiagui
2430
proc guiQuit {} {
2431
global PANES O
2432
global ANNOTATION_FILE
2433
2434
if {[catch {set f [open .ibdiagui w]} ]} {
2435
return
2436
}
2437
2438
puts $f "wm geometry . [wm geometry .]"
2439
puts $f "update"
2440
foreach w [array names PANES] {
2441
foreach idx $PANES($w) {
2442
set coords [$w sash coord $idx]
2443
puts $f "$w sash place $idx [lindex $coords 0] [lindex $coords 1]"
2444
}
2445
}
2446
2447
foreach opt [array names O] {
2448
puts $f "set O($opt) {$O($opt)}"
2449
}
2450
2451
puts $f "set ANNOTATION_FILE \"$ANNOTATION_FILE\""
2452
close $f
2453
exit
2454
}
2455
2456
# init the menu bar
2457
proc initMenuBar {m} {
2458
menubutton $m.file -text File -underline 0 -menu $m.file.menu
2459
menubutton $m.refresh -text Refresh -underline 0 -menu $m.refresh.menu
2460
menubutton $m.find -text Find -underline 0 -menu $m.find.menu
2461
menubutton $m.opts -text Options -underline 0 -menu $m.opts.menu
2462
2463
menu $m.file.menu -tearoff no
2464
$m.file.menu add command -label Quit -command guiQuit
2465
2466
menu $m.refresh.menu -tearoff no
2467
$m.refresh.menu add command -label Network -command DiagNet
2468
$m.refresh.menu add command -label "Enforce Annotations" \
2469
-command EnforceAnnotations
2470
$m.refresh.menu add command -label "Add Statics to VL0" \
2471
-command SetVL0Statics
2472
2473
menu $m.find.menu -tearoff no
2474
$m.find.menu add command -label Name -command FindByName
2475
$m.find.menu add command -label GUID -command FindByGUID
2476
$m.find.menu add command -label LID -command FindByLID
2477
$m.find.menu add command -label Route -command FindByDR
2478
2479
menu $m.opts.menu -tearoff no
2480
$m.opts.menu add command -label Colors -command SetColorOpts
2481
$m.opts.menu add command -label "Set Roots" -command SetRoots
2482
$m.opts.menu add command -label "Set Annotation File" \
2483
-command SetAnnotationsFile
2484
$m.opts.menu add command -label "Set IBDiagNet Options" \
2485
-command SetIBDiagFlags
2486
2487
menubutton $m.help -text Help -underline 0 -menu $m.help.menu
2488
menu $m.help.menu -tearoff no
2489
$m.help.menu add command -label About -command HelpAbout
2490
2491
pack $m.file $m.refresh $m.find $m.opts -side left
2492
2493
pack $m.help -side right
2494
}
2495
2496
#--------------------------------------------------------
2497
# Init the main windows and provide their ids in globals:
2498
# G - the graphic canvas widget id
2499
# P - the props frame
2500
# L - the LOG text widget
2501
#--------------------------------------------------------
2502
proc initMainFrame {f} {
2503
global C P L PANES
2504
2505
#--------------------------------------------------------
2506
# The hierarchy of widgets we build is defined below
2507
# f
2508
# pw1 - the main pane split vertically
2509
# tf - the top frame
2510
# pw2 - the second pane - this time horizontal
2511
# gf - graphic frame
2512
# gg - graphic grid
2513
# chs - canvas horizonal scroll
2514
# cvs - canvas vertical scroll
2515
# c - canvas
2516
# pf - props frame
2517
# bf - the bottom frame
2518
# tg - text grid
2519
# ths - text horizonal srcolll
2520
# tvs - text vertical srcolll
2521
# t - text widget
2522
#--------------------------------------------------------
2523
2524
# pw1 - the main pane split vertically
2525
set pw1 [panedwindow $f.pw1 -orient vertical -showhandle yes]
2526
set PANES($pw1) 0
2527
2528
# tf - the top frame
2529
set tf [frame $pw1.tf]
2530
# pw2 - the second pane - this time horizontal
2531
set pw2 [panedwindow $tf.pw2 -showhandle yes]
2532
set PANES($pw2) 0
2533
2534
# gf - graphic frame
2535
set gf [frame $tf.gf]
2536
# gg - graphic grid
2537
set gg [frame $gf.g]
2538
# chs - canvas horizonal scroll
2539
set chs [scrollbar $gf.chs -orient horiz -command "$gf.c xview"]
2540
# cvs - canvas vertical scroll
2541
set cvs [scrollbar $gf.cvs -orient vertical -command "$gf.c yview"]
2542
# c - canvas
2543
set c [canvas $gf.c -relief sunken -borderwidth 2 \
2544
-scrollregion {-11c -11c 11c 11c} \
2545
-xscrollcommand "$chs set" \
2546
-yscrollcommand "$cvs set" ]
2547
# pf - props frame
2548
set pf [frame $tf.pf]
2549
# bf - the bottom frame
2550
set bf [frame $pw1.bf]
2551
# tg - text grid
2552
set tg [frame $bf.g]
2553
# ths - text horizonal srcolll
2554
set ths [scrollbar $bf.ths -orient horiz -command "$bf.t xview"]
2555
# tvs - text vertical srcolll
2556
set tvs [scrollbar $bf.tvs -orient vertical -command "$bf.t yview"]
2557
# t - text widget
2558
set t [text $bf.t \
2559
-yscrollcommand "$tvs set" \
2560
-xscrollcommand "$ths set" \
2561
-state disabled]
2562
2563
#--------------------------------------------------------
2564
# Packing...
2565
#--------------------------------------------------------
2566
2567
# Graphic area
2568
pack $gg -expand yes -fill both -padx 1 -pady 1
2569
grid rowconfig $gg 0 -weight 1 -minsize 0
2570
grid columnconfig $gg 0 -weight 1 -minsize 0
2571
grid $c -padx 1 -in $gg -pady 1 \
2572
-row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
2573
grid $cvs -in $gg -padx 1 -pady 1 \
2574
-row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
2575
grid $chs -in $gg -padx 1 -pady 1 \
2576
-row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
2577
2578
# graphic / prop pane
2579
$pw2 add $pf
2580
$pw2 add $gf
2581
2582
pack $pw2 -side top -expand yes -fill both -pady 2 -padx 2m
2583
$pw2 paneconfigure $gf -sticky news -width 10c
2584
$pw2 paneconfigure $pf -sticky news -minsize 4c
2585
2586
# the frame holding it
2587
# pack $tf -side top -expand yes -fill both
2588
pack $tf -side top -fill both
2589
2590
# log text area
2591
pack $tg -expand yes -fill both -padx 1 -pady 1
2592
grid rowconfig $tg 0 -weight 1 -minsize 0
2593
grid columnconfig $tg 0 -weight 1 -minsize 0
2594
grid $t -padx 1 -in $tg -pady 1 \
2595
-row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
2596
grid $tvs -in $tg -padx 1 -pady 1 \
2597
-row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
2598
grid $ths -in $tg -padx 1 -pady 1 \
2599
-row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
2600
2601
# the frame holding it
2602
# pack $bf -side top -expand yes -fill x
2603
pack $bf -side top -fill x
2604
2605
# the main pane window
2606
$pw1 add $tf $bf
2607
pack $pw1 -side top -expand yes -fill both -pady 2 -padx 2m
2608
# $pw1 paneconfigure $tf -minsize 15c
2609
# $pw1 paneconfigure $bf
2610
2611
bind $c <3> "zoomMark $c %x %y"
2612
bind $c <B3-Motion> "zoomStroke $c %x %y"
2613
bind $c <ButtonRelease-3> "zoomArea $c %x %y"
2614
bind $c <KeyPress-z> "zoom $c 1.25"
2615
bind $c <KeyPress-Z> "zoom $c 0.8"
2616
bind $c <KeyPress-f> "fit $c"
2617
bind . <3> "zoomMark $c %x %y"
2618
bind . <B3-Motion> "zoomStroke $c %x %y"
2619
bind . <ButtonRelease-3> "zoomArea $c %x %y"
2620
bind . <KeyPress-z> "zoom $c 1.25"
2621
bind . <KeyPress-Z> "zoom $c 0.8"
2622
bind . <KeyPress-f> "fit $c"
2623
bind . <KeyPress-e> "expand $c %x %y"
2624
bind . <KeyPress-d> "deExpand $c %x %y"
2625
bind . <KeyPress-c> "guiClearAllMarking"
2626
2627
set C $c
2628
set L $t
2629
set P $pf
2630
2631
$L tag bind NAME <Button-1> "LogObjSelect $L NAME %W %x %y"
2632
$L tag bind LID <Button-1> "LogObjSelect $L LID %W %x %y"
2633
$L tag bind GUID <Button-1> "LogObjSelect $L GUID %W %x %y"
2634
$L tag bind ROUTE <Button-1> "LogObjSelect $L ROUTE %W %x %y"
2635
}
2636
2637
proc setLogColors {} {
2638
global L
2639
$L tag configure errors -foreground [getColor txtErr]
2640
$L tag configure warnings -foreground [getColor txtWarn]
2641
$L tag configure infos -foreground [getColor txtInfo]
2642
$L tag configure NAME -background [getColor txtName]
2643
$L tag configure LID -background [getColor txtLid]
2644
$L tag configure GUID -background [getColor txtGuid]
2645
$L tag configure ROUTE -background [getColor txtRoute]
2646
}
2647
2648
proc initGui {} {
2649
global O L S StatusLine P
2650
global ANNOTATION_FILE
2651
# . configure -background white -width 10i -height 10i
2652
2653
# menu is a separate line at the top
2654
frame .m -relief raised -padx 2 -pady 2
2655
pack .m -side top -expand no -fill x -anchor nw
2656
initMenuBar .m
2657
2658
# the pane structure
2659
frame .r -relief ridge -height 10i -width 10i
2660
pack .r -side top -expand yes -fill both
2661
2662
# status line
2663
frame .s
2664
entry .s.e -relief flat -state readonly -textvariable StatusLine
2665
pack .s.e -fill x -expand true -side bottom
2666
pack .s -side bottom -fill x
2667
set S .s.e
2668
2669
# the main frame
2670
initMainFrame .r
2671
2672
set O(color:txtDef) {ld "Log Msg Default" black}
2673
set O(color:txtErr) {le "Log Msg Error" red }
2674
set O(color:txtWarn) {lw "Log Msg Warning" "#704000"}
2675
set O(color:txtInfo) {li "Log Msg Info" darkgreen }
2676
set O(color:txtName) {ln "Log Tag Name" "#909000" }
2677
set O(color:txtLid) {ll "Log Tag LID" "#fb9933" }
2678
set O(color:txtGuid) {lg "Log Tag GUID" "#906070" }
2679
set O(color:txtRoute) {lr "Log Tag Route" "#aa40a0"}
2680
2681
set O(color:1x2.5G) {p1x25g "Link 1x 2.5G" "#ff0000"}
2682
set O(color:1x5G) {p1x5g "Link 1x 5G" "#c80000"}
2683
set O(color:1x10G) {p1x10g "Link 1x 10G" "#960000"}
2684
set O(color:4x2.5G) {p4x25g "Link 4x 2.5G" "#00ff00"}
2685
set O(color:4x5G) {p4x5g "Link 4x 5G" "#00c800"}
2686
set O(color:4x10G) {p4x10g "Link 4x 10G" "#009600"}
2687
set O(color:12x2.5G) {p12x25g "Link 12x 2.5G" "#0000ff"}
2688
set O(color:12x5G) {p12x5g "Link 12x 5G" "#00ff40"}
2689
set O(color:12x10G) {p12x10g "Link 12x 10G" "#00ff80"}
2690
2691
set O(color:sys) {sys "Props System" "#ff5e1b"}
2692
set O(color:node) {node "Props Node" "#00beff"}
2693
set O(color:port) {port "Props Port" "#00ff96"}
2694
set O(color:sysport) {sysp "Props System Port" "#f400cc"}
2695
2696
set O(color:mark) {mark "Marking Selected" "#f400f1"}
2697
set O(color:mtxt) {mtxt "Marking Text" "#0000ff"}
2698
2699
if {[file exists .ibdiagui]} {
2700
source .ibdiagui
2701
}
2702
2703
# actuall set the colors on the text tags
2704
setLogColors
2705
initPropsGui $P
2706
LoadAnnotationsFile
2707
SetStatus "Initializing ... "
2708
}
2709
2710
##############################################################################
2711
#
2712
# Main flow
2713
#
2714
2715
# we provide a way to load the results of ibdiagnet for testing
2716
# to do this provide -D <dir name> that dir needs to have:
2717
# ibdiagnet.stdout.log
2718
# ibdiahnet.lst
2719
# OPTIONAL: ibdiagnet.topo
2720
set testModeDirIdx [lsearch $argv "-D"]
2721
if {$testModeDirIdx >= 0} {
2722
set testModeDir [lindex $argv [expr $testModeDirIdx + 1]]
2723
if {![file exists [file join $testModeDir ibdiagnet.lst]]} {
2724
puts "-E- No [file join $testModeDir ibdiagnet.lst]"
2725
exit 1
2726
}
2727
if {![file exists [file join $testModeDir ibdiagnet.stdout.log]]} {
2728
puts "-E- No [file join $testModeDir ibdiagnet.stdout.log]"
2729
exit 1
2730
}
2731
set argv [lreplace $argv $testModeDirIdx [expr $testModeDirIdx + 1]]
2732
} else {
2733
set testModeDir 0
2734
}
2735
2736
set IBDIAGNET_FLAGS $argv
2737
2738
InitializeIBDIAG
2739
StartIBDIAG
2740
if {! [info exists G(argv:sys.name)]} {
2741
set G(argv:sys.name) [lindex [split [info hostname] .] 0]
2742
}
2743
2744
# We init the Tk only after parsing the command line
2745
# to avoid the interpretation of args by Tk.
2746
if {[catch {package require Tk} e]} {
2747
puts "-E- ibdiagui depends on a Tk installation"
2748
puts " Please download and install tk8.4"
2749
puts " Error: $e"
2750
exit 1
2751
}
2752
2753
if {[catch {package require Tcldot} e]} {
2754
puts "-E- ibdiagui depends on a Tcldot installation"
2755
puts " Please download and install Graphviz"
2756
puts " Error: $e"
2757
exit 1
2758
}
2759
2760
if {[catch {initGui} e]} {
2761
puts "-E- $e"
2762
puts " $errorInfo"
2763
exit
2764
}
2765
2766
if {[catch {DiagNet} e]} {
2767
puts "-E- $e"
2768
puts " $errorInfo"
2769
}
2770
2771
package provide ibdiagui 1.0
2772
Loggerhead is a web-based interface for Breezy
Version: 2.0.1