libibdm1 1.2-OFED-1.4.2-1.1 / usr / lib / ibdiagui1.2 / ibdiagui.tcl

# This code should be sourced into ibis through ibdiagui wrapper
source [file join [file dirname [info script]] ibdebug.tcl]

if {[catch {package require ibdm} e]} {
   puts "-E- ibdiagui depends on a 'IBDM' installation"
   puts "    Your ib_utils installation must be broken. Please reinstall"
   puts "    Error: $e"
   exit 1
}

if {[catch {package require ibis} e]} {
   puts "-E- ibdiagui depends on a 'ibis' installation"
   puts "    Your ib_utils installation must be broken. Please reinstall"
   puts "    Error: $e"
   exit 1
}

##############################################################################
#
# GENERIC CANVAS ZOOMING UTILITIES
#
##############################################################################

#--------------------------------------------------------
#
#  zoomMark
#
#  Mark the first (x,y) coordinate for zooming.
#
#--------------------------------------------------------
proc zoomMark {c x y} {
   global zoomArea
   set zoomArea(x0) [$c canvasx $x]
   set zoomArea(y0) [$c canvasy $y]
   $c create rectangle $x $y $x $y -outline black -tag zoomArea
}

#--------------------------------------------------------
#
#  zoomStroke
#
#  Zoom in to the area selected by itemMark and
#  itemStroke.
#
#--------------------------------------------------------
proc zoomStroke {c x y} {
   global zoomArea
   set zoomArea(x1) [$c canvasx $x]
   set zoomArea(y1) [$c canvasy $y]
   $c coords zoomArea $zoomArea(x0) $zoomArea(y0) $zoomArea(x1) $zoomArea(y1)
}

#--------------------------------------------------------
#
#  zoomArea
#
#  Zoom in to the area selected by itemMark and
#  itemStroke.
#
#--------------------------------------------------------
proc zoomArea {c x y} {
   global zoomArea

   #--------------------------------------------------------
   #  Get the final coordinates.
   #  Remove area selection rectangle
   #--------------------------------------------------------
   set zoomArea(x1) [$c canvasx $x]
   set zoomArea(y1) [$c canvasy $y]
   $c delete zoomArea

   #--------------------------------------------------------
   #  Check for zero-size area
   #--------------------------------------------------------
   if {($zoomArea(x0)==$zoomArea(x1)) || ($zoomArea(y0)==$zoomArea(y1))} {
      return
   }

   #--------------------------------------------------------
   #  Determine size and center of selected area
   #--------------------------------------------------------
   set areaxlength [expr {abs($zoomArea(x1)-$zoomArea(x0))}]
   set areaylength [expr {abs($zoomArea(y1)-$zoomArea(y0))}]
   set xcenter [expr {($zoomArea(x0)+$zoomArea(x1))/2.0}]
   set ycenter [expr {($zoomArea(y0)+$zoomArea(y1))/2.0}]

   #--------------------------------------------------------
   #  Determine size of current window view
   #  Note that canvas scaling always changes the coordinates
   #  into pixel coordinates, so the size of the current
   #  viewport is always the canvas size in pixels.
   #  Since the canvas may have been resized, ask the
   #  window manager for the canvas dimensions.
   #--------------------------------------------------------
   set winxlength [winfo width $c]
   set winylength [winfo height $c]

   #--------------------------------------------------------
   #  Calculate scale factors, and choose smaller
   #--------------------------------------------------------
   set xscale [expr {$winxlength/$areaxlength}]
   set yscale [expr {$winylength/$areaylength}]
   if { $xscale > $yscale } {
      set factor $yscale
   } else {
      set factor $xscale
   }

   #--------------------------------------------------------
   #  Perform zoom operation
   #--------------------------------------------------------
   zoom $c $factor $xcenter $ycenter $winxlength $winylength
}

#--------------------------------------------------------
#
#  fit
#
#  Fit to all objects
#--------------------------------------------------------
proc fit { canvas } {
   set bbox [$canvas bbox all]
   # provided view is the start and end of the viewed window in 0.0-1.0 of the
   # entire region.
   set xv [$canvas xview]
   set yv [$canvas yview]
   set xf [expr [lindex $xv 1] - [lindex $xv 0]]
   set yf [expr [lindex $yv 1] - [lindex $yv 0]]
   if {$yf < $xf} {
      set scale $yf
   } else {
      set scale $xf
   }
   # we want to set the center of the canvas to the bbox / 2
   foreach {x0 y0 x1 y1} $bbox {break}
   set x [expr ($x0 + $x1)/2.0]
   set y [expr ($y0 + $y1)/2.0]
   zoom $canvas $scale $x $y
}

#--------------------------------------------------------
#
#  zoom
#
#  Zoom the canvas view, based on scale factor
#  and centerpoint and size of new viewport.
#  If the center point is not provided, zoom
#  in/out on the current window center point.
#
#  This procedure uses the canvas scale function to
#  change coordinates of all objects in the canvas.
#
#--------------------------------------------------------
proc zoom { canvas factor \
               {xcenter ""} {ycenter ""} \
               {winxlength ""} {winylength ""} } {

   #--------------------------------------------------------
   #  If (xcenter,ycenter) were not supplied,
   #  get the canvas coordinates of the center
   #  of the current view.  Note that canvas
   #  size may have changed, so ask the window
   #  manager for its size
   #--------------------------------------------------------
   if { [string equal $winxlength ""] } {
      set winxlength [winfo width $canvas]
   }
   if { [string equal $winylength ""] } {
      set winylength [winfo height $canvas]
   }
   if { [string equal $xcenter ""] } {
      set xcenter [$canvas canvasx [expr {$winxlength/2.0}]]
   }
   if { [string equal $ycenter ""] } {
      set ycenter [$canvas canvasy [expr {$winylength/2.0}]]
   }

   #--------------------------------------------------------
   #  Scale all objects in the canvas
   #  Adjust our viewport center point
   #--------------------------------------------------------
   $canvas scale all 0 0 $factor $factor
   set xcenter [expr {$xcenter * $factor}]
   set ycenter [expr {$ycenter * $factor}]

   #--------------------------------------------------------
   #  Get the size of all the items on the canvas.
   #
   #  This is *really easy* using
   #      $canvas bbox all
   #  but it is also wrong.  Non-scalable canvas
   #  items like text and windows now have a different
   #  relative size when compared to all the lines and
   #  rectangles that were uniformly scaled with the
   #  [$canvas scale] command.
   #
   #  It would be better to tag all scalable items,
   #  and make a single call to [bbox].
   #  Instead, we iterate through all canvas items and
   #  their coordinates to compute our own bbox.
   #--------------------------------------------------------
   set x0 1.0e30; set x1 -1.0e30 ;
   set y0 1.0e30; set y1 -1.0e30 ;
   foreach item [$canvas find all] {
      switch -exact [$canvas type $item] {
         "arc" -
         "line" -
         "oval" -
         "polygon" -
         "rectangle" {
            set coords [$canvas coords $item]
            foreach {x y} $coords {
               if { $x < $x0 } {set x0 $x}
               if { $x > $x1 } {set x1 $x}
               if { $y < $y0 } {set y0 $y}
               if { $y > $y0 } {set y1 $y}
            }
         }
      }
   }

   #--------------------------------------------------------
   #  Now figure the size of the bounding box
   #--------------------------------------------------------
   set xlength [expr {$x1-$x0}]
   set ylength [expr {$y1-$y0}]

   #--------------------------------------------------------
   #  But ... if we set the scrollregion and xview/yview
   #  based on only the scalable items, then it is not
   #  possible to zoom in on one of the non-scalable items
   #  that is outside of the boundary of the scalable items.
   #
   #  So expand the [bbox] of scaled items until it is
   #  larger than [bbox all], but do so uniformly.
   #--------------------------------------------------------
   foreach {ax0 ay0 ax1 ay1} [$canvas bbox all] {break}

   while { ($ax0<$x0) || ($ay0<$y0) || ($ax1>$x1) || ($ay1>$y1) } {
      # triple the scalable area size
      set x0 [expr {$x0-$xlength}]
      set x1 [expr {$x1+$xlength}]
      set y0 [expr {$y0-$ylength}]
      set y1 [expr {$y1+$ylength}]
      set xlength [expr {$xlength*3.0}]
      set ylength [expr {$ylength*3.0}]
   }

   #--------------------------------------------------------
   #  Now that we've finally got a region defined with
   #  the proper aspect ratio (of only the scalable items)
   #  but large enough to include all items, we can compute
   #  the xview/yview fractions and set our new viewport
   #  correctly.
   #--------------------------------------------------------
   set newxleft [expr {($xcenter-$x0-($winxlength/2.0))/$xlength}]
   set newytop  [expr {($ycenter-$y0-($winylength/2.0))/$ylength}]
   $canvas configure -scrollregion [list $x0 $y0 $x1 $y1]
   $canvas xview moveto $newxleft
   $canvas yview moveto $newytop

   #--------------------------------------------------------
   #  Change the scroll region one last time, to fit the
   #  items on the canvas.
   #--------------------------------------------------------
   $canvas configure -scrollregion [$canvas bbox all]
}

##############################################################################
#
# NETWORK GRAPH UTILITIES
#
##############################################################################

# provide back color based on port speed / speed
proc portColor {port} {
   set width [IBPort_width_get $port]
   set speed [IBPort_speed_get $port]

   set color [getColor $width${speed}G]

   return $color
}

proc LoadAnnotationsFile {} {
   global ANNOTATIONS
   global ANNOTATION_FILE P

   if {![info exists ANNOTATION_FILE]} {
      return
   }
   if {![file readable $ANNOTATION_FILE]} {
      return
   }

   set f [open $ANNOTATION_FILE r]

   if {[info exists ANNOTATIONS]} {unset ANNOTATIONS}

   while {[gets $f sLine] >= 0} {
      # TODO: Support not only sysPort annotations
      if {![regexp {(\S+)\s+(.+)} $sLine d1 name anno]} {
         puts "-W- Skipping annotation file line:$sLine"
         continue
      }
      set ANNOTATIONS(sysport:$name) $anno
   }
}

proc DrawAnnotationFromFile {} {
   global ANNOTATIONS
   global C gFabric

   # clear all annotations
   $C delete withtag anno

   # TODO: Support not only sysPort annotations
   foreach e [array names ANNOTATIONS sysport:*] {
      set sysPortName [string range $e [string length sysport:] end]
      set anno $ANNOTATIONS($e)

      # find the sys port
      set sysPort [findSysPortByName $sysPortName]
      if {$sysPort == ""} {
         puts "-W- failed to find sys port:$sysPortName"
         continue
      }

      set sysName [IBSystem_name_get [IBSysPort_p_system_get $sysPort]]
      set portName [IBSysPort_name_get $sysPort]
      # get the items of this port
      set items [$C find withtag ${portName}&&sysport&&of:$sysName]
      if {[llength $items] == 0} {
         puts "-W- No items for sys port:$sysPortName"
         continue
      }

      set bbox [$C bbox $items]
      set outCoords [bboxCenter $bbox [expr rand()*0.95]]
      $C create text $outCoords -tags anno -fill red \
         -text $anno
      puts "-I- Annotated $sysPortName with $anno"
   }
}


# draw a single node
proc drawNode {node graph} {
   global NODE
   global IB_CA_NODE
   set nodeName [IBNode_name_get $node]

   if {[regexp {^node:(.*)} $nodeName d1 n]} {
      set nodeName "0x$n"
   }

   set nodeLabel "\{$nodeName|"
   set numPorts [IBNode_numPorts_get $node]
   switch  $numPorts {
      1 {append nodeLabel "{<f1> P1}\}"}
      2 {append nodeLabel "{<f1> P1|<f2> P2}\}"}
      8 {
         append nodeLabel "{<f1> P1|<f2> P2|<f3> P3|<f4> P4}|"
         append nodeLabel "{<f5> P5|<f6> P6|<f7> P7|<f8> P8}\}"
      }
      24 {
         append nodeLabel "{<f1> P1|<f2> P2|<f3> P3|<f4> P4}|"
         append nodeLabel "{<f5> P5|<f6> P6|<f7> P7|<f8> P8}|"
         append nodeLabel "{<f9> P9|<f10> P10|<f11> P11|<f12> P12}|"
         append nodeLabel "{<f13> P13|<f14> P14|<f15> P15|<f16> P16}|"
         append nodeLabel "{<f17> P17|<f18> P18|<f19> P19|<f20> P20}|"
         append nodeLabel "{<f21> P21|<f22> P22|<f23> P23|<f24> P24}\}"
      }
      default {
         puts "-E- Fail to handle $nodeName with $numPorts ports"
      }
   }
   set NODE($node) \
      [$graph addnode $nodeName shape record \
          fontsize 7 label $nodeLabel \
          fillcolor lightblue2 style filled \
         ]

   if {[IBNode_type_get $node] == $IB_CA_NODE} {
      $NODE($node) setattributes fillcolor lightgrey
   }
}

proc drawSystem {sys graph} {
   global SYSTEM
   global SYS_PORT_IDX_BY_NAME
   global EXPAND_SYSTEMS
   global ANNOTATIONS

   # puts "-I- Drawing system $sys"
   set sysName [IBSystem_name_get $sys]

   # remove extra "system" from auto systems
   if {[regexp {^system:(.*)} $sysName d1 n]} {
      set sysName "0x$n"
   }

   # the system might be expanded
   if {[info exists EXPAND_SYSTEMS($sysName)]} {
      set subGraph [$graph addsubgraph \
                       cluster_$sysName label $sysName labelfontsize 7 \
                       bgcolor wheat color black]
      foreach nameNNode [IBSystem_NodeByName_get $sys] {
         set node [lindex $nameNNode 1]
         drawNode $node $subGraph
      }
      return
   }

   set sysLabel "\{$sysName|"

   # we only draw system ports that are connected
   set connSysPorts {}
   set prevPrefix "-"
   set first 1
   set sysPortIdx 0
   set numInLine 0
   set sysPorts [IBSystem_PortByName_get $sys]
   foreach sysNameNPort [lsort -dictionary -index 0 $sysPorts] {
      foreach {portName sysPort} $sysNameNPort {break}

      set fullName "$sysName/$portName"
      set isAnnotated [info exists ANNOTATIONS(sysport:$fullName)]
      set remSysPort [IBSysPort_p_remoteSysPort_get $sysPort]
      if {$isAnnotated == 0 && $remSysPort == ""} {continue}

      # we use heuristic to know when to break the ports line
      if {![regexp {(.*)/[^/]+$} $portName d1 prefix]} {
         set prefix ""
      }

      if {$prefix != $prevPrefix || $numInLine == 6} {
         set numInLine 0
         if {$first} {
            append sysLabel "\{"
            set first 0
         } else {
            append sysLabel "\}|\{"
         }
         set prevPrefix $prefix
      } else {
         if {$first == 0} {
            append sysLabel "|"
         } else {
            set first 0
         }
      }
      incr numInLine
      append sysLabel "<f$sysPortIdx> $portName"
      set SYS_PORT_IDX_BY_NAME($sys,$portName) $sysPortIdx
      incr sysPortIdx
   }
   if {$first == 0} {
      append sysLabel "\}\}"
   } else {
      append sysLabel "\}"
   }

   if {[regexp {^S[0-9a-fA-F]+$} $sysName]} {
      set fillColor lightgrey
   } else {
      set fillColor lightyellow
   }

   global SYSTEM_ORDER
   if {[info exist SYSTEM_ORDER] && [lsearch $SYSTEM_ORDER $sysName] >= 0} {
      set SYSTEM($sys) \
         [$graph addnode $sysName shape record \
             fontsize 7 label $sysLabel labelfontcolor red \
             fillcolor $fillColor style filled \
             pos 10,10 ]
   } else {
      set SYSTEM($sys) \
         [$graph addnode $sysName shape record \
             fontsize 7 label $sysLabel labelfontcolor red \
             fillcolor $fillColor style filled \
            ]
   }
}

# draw a single node connections
proc drawNodeConns {node graph} {
   global SYS_PORT_IDX_BY_NAME
   global NODE SYSTEM
   global EXPAND_SYSTEMS
   global CONN

   #  puts "-V- Drawing connections of node:[IBNode_name_get $node]"
   set sys [IBNode_p_system_get $node]
   set sysName [IBSystem_name_get $sys]
   set isExpanded [info exists EXPAND_SYSTEMS($sysName)]
   for {set pn 1} {$pn <= [IBNode_numPorts_get $node]} {incr pn} {
      set port [IBNode_getPort $node $pn]
      if {$port == ""} {continue}
      set portName [IBPort_getName $port]

      set remPort [IBPort_p_remotePort_get $port]
      if {$remPort == ""} {continue}

      set remPortName [IBPort_getName $remPort]
      if {[info exists CONN($remPortName)] } {continue}

      set toNode [IBPort_p_node_get $remPort]
      set toPortNum [IBPort_num_get $remPort]
      set toSys  [IBNode_p_system_get $toNode]
      set toSysName [IBSystem_name_get $toSys]

      # we can skip connections within same system if it
      # is not expanded
      if {($sys == $toSys) && !$isExpanded} {continue}

      # now we need to figure out if we are connecting
      # system ports or not
      set sysPort [IBPort_p_sysPort_get $port]
      if {$sysPort == "" || $isExpanded} {
         set isDrawn [info exists NODE($node)]
         if {$isDrawn == 0} {continue}
         set fromRec $NODE($node)
         set fromPort f$pn
      } else {
         if {![info exists SYSTEM($sys)]} {
            puts "-W- System $sys is not drawn???"
            continue
         }
         set fromRec $SYSTEM($sys)
         set fromPortName [IBSysPort_name_get $sysPort]
         if {![info exists SYS_PORT_IDX_BY_NAME($sys,$fromPortName)]} {
            puts "-W- System $sys port $fromPortName is not drawn???"
            continue
         }
         set fromPort "f$SYS_PORT_IDX_BY_NAME($sys,$fromPortName)"
      }

      set remSysPort [IBPort_p_sysPort_get $remPort]
      set isRemExpanded [info exists EXPAND_SYSTEMS($toSysName)]
      if {$remSysPort == "" || $isRemExpanded} {
         set toRec $NODE($toNode)
         set toPort f$toPortNum
      } else {
         set toRec $SYSTEM($toSys)
         set toPortName [IBSysPort_name_get $remSysPort]
         set toPort "f$SYS_PORT_IDX_BY_NAME($toSys,$toPortName)"
      }

      #     puts  "-V- Connecting from:$fromRec / $fromPort -> $toRec / $toPort ... "
      set conn \
         [$graph addedge "$toRec" "$fromRec" \
             tailport $toPort headport $fromPort \
             arrowhead normal arrowtail normal \
            ]

      set CONN($portName) $conn

      # use coloring for link speed/width
      $conn setattributes color [portColor $port]
   }
}

# process the code generated by graphviz
proc tagGraphVizCode {fabric code} {
   global NODE SYSTEM
   set newCode {}

   # We scan through the code for text and on the first
   # appearence of a node tag. Then try matching against known
   # systems and nodes
   set newCode ""
   set numSystems 0
   set numNodes 0
   set numPorts 0
   set prevNode ""
   foreach sLine [split $code "\n"] {
      if {[regexp {^(.*-text.*-tags\s+)(.*graph.*)} $sLine d1 pf tags]} {
         append newCode "$pf {$tags system}\n"
         incr numSystems
      } elseif {[regexp {^(.*-text\s+(\S+).*-tags\s+)(.*node.*)} \
                    $sLine d1 pf txt tags]} {
         # we can be on a new node -
         if {$prevNode != $tags} {
            # new node tag is it a system or node?
            set sys [IBFabric_getSystem $fabric $txt]
            if {$sys != ""} {
               #              puts "-V- TAGS: new sys $tags txt:$txt"
               # a system
               append newCode "$pf {$tags system}\n"
               incr numSystems
               set portTagType sysport
               set parent $txt
            } else {
               #              puts "-V- TAGS: new node $tags txt:$txt"
               set portTagType port
               append newCode "$pf {$tags node}\n"
               incr numNodes
               set parent $txt
            }
            set prevNode $tags
         } else {
            #           puts "-V- TAGS: new $portTagType $tags txt:$txt"

            # it must be a port
            append newCode "$pf {$tags $portTagType of:$parent}\n"
            incr numPorts
         }
      } else {
         append newCode "$sLine\n"
      }
   }
   # avoid the disabling of the widgets
   regsub -all -- {-disabled} $newCode {} newCode
   puts "-I- Marked $numSystems systems $numNodes nodes $numPorts ports"
   return $newCode
}

# create selection box for each object type and assign bindings
proc bindMenusToTags {c} {

   set objNHdl {
      system  showSysMenu
      node    showNodeMenu
      port    showPortMenu
      sysport showSysPortMenu
   }

   foreach {type hdlFunc} $objNHdl {
      foreach item [$c find withtag $type] {
         foreach {x0 y0 x1 y1} [$c bbox $item] {break}
         set dy [expr $y1 - $y0]
         if {[catch {set name [$c itemcget $item -text]}]} {continue}
         set tags [$c itemcget $item -tags]
         $c addtag $name withtag $item
         lappend tags name:$name
         lappend tags ${type}Handle
         set handleItem [$c create rectangle $x0 \
                            [expr $y0 - $dy] $x1 [expr $y1 + $dy] \
                            -outline {} -tags $tags]

         $c bind $handleItem <1> [list $hdlFunc %W %x %y]
      }
   }
}

# provide a system list in the order stored by system names
# return a list of {name id} pairs
proc getSysList {fabric} {
   global SYSTEM_ORDER

   # first get all the systems sorted by name
   set sysList {}
   set nameList {}
   if {[info exists SYSTEM_ORDER]} {
      foreach sysName $SYSTEM_ORDER {
         set sys [IBFabric_getSystem $fabric $sysName]
         if {$sys != ""} {
            puts "-I- Adding root $sysName"
            lappend sysList [list $sysName $sys]
            lappend nameList $sysName
         }
      }
   }

   # now build the name list not including the
   foreach nameNSys [lsort -index 0 [IBFabric_SystemByName_get $fabric]] {
      set name [lindex $nameNSys 0]
      set sys  [lindex $nameNSys 1]
      if {[lsearch -exact $nameList $name] < 0} {
         lappend sysList [list $name $sys]
         lappend nameList $name
      }
   }
   return $sysList
}

# take a canvans and a fabric and draw the fabric on the canvas
proc drawFabric {fabric c} {
   global NODE SYSTEM CONN SYS_PORT_IDX_BY_NAME
   global EXPAND_SYSTEMS

   foreach g {CONN NODE SYSTEM SYS_PORT_IDX_BY_NAME} {
      if {[info exists $g]} {
         unset $g
      }
   }

   # cleanup the canvas
   $c delete all

   #   set graph [dotnew graph mode hier rankdir TB fontsize 7 \
      #                 ranksep equaly labelfontsize 7 size 300,300]
   set cbg [option get $c background *]
   set graph [dotnew graph mode hier fontsize 7 \
                 ranksep equaly labelfontsize 7 bgcolor $cbg]

   # we add each system as a subgraph and then
   foreach nameNSys [getSysList $fabric] {
      set sys [lindex $nameNSys 1]
      drawSystem $sys $graph
   }

   # go over all nodes and connect them
   foreach nameNNode [IBFabric_NodeByName_get $fabric] {
      set node [lindex $nameNNode 1]
      drawNodeConns $node $graph
   }

   SetStatus "-I- Calculating graph layout ..."
   $graph layout NEATO
   SetStatus "-I- Packing graph ..."
   set code [$graph render]
   SetStatus "-I- Packing graph ... done"

   set newCode [tagGraphVizCode $fabric $code]
   eval $newCode
   bindMenusToTags $c

   # fit the canvas
   # fit $c
}

#assume there is a name:* tag in teh list return the name
proc getNameTag {tags} {
   set idx [lsearch -glob $tags name:*]
   if {$idx < 0} {
      return ""
   }
   return [string range [lindex $tags $idx] 5 end]
}

proc getOfTag {tags} {
   set idx [lsearch -glob $tags of:*]
   if {$idx < 0} {
      return ""
   }
   return [string range [lindex $tags $idx] 3 end]
}

# set the EXPANDED for the system under the cursor and
# call redraw
proc expand {c x y} {
   global EXPAND_SYSTEMS
   global gFabric C
   set tags [$c itemcget current -tags]
   if {[llength $tags] == 0} {return}
   set sysName [getNameTag $tags]

   SetStatus "-I- Expanding System: $sysName ..."
   puts "-I- Expanding System: $sysName ..."

   set EXPAND_SYSTEMS($sysName) 1

   after 100 drawFabric $gFabric $C
}

# set the EXPANDED for the system under the cursor and
# call redraw
proc deExpand {c x y} {
   global EXPAND_SYSTEMS
   global gFabric C
   set tags [$c itemcget current -tags]
   if {[llength $tags] == 0} {return}
   set sysName [getNameTag $tags]

   SetStatus "-I- De-Expanding System: $sysName ..."
   puts "-I- De-Expanding System: $sysName ..."

   if {[info exists EXPAND_SYSTEMS($sysName)]} {
      unset EXPAND_SYSTEMS($sysName)
   }

   after 100 drawFabric $gFabric $C
}

proc showSysMenu {c x y} {
   global gFabric
   set tags [$c itemcget current -tags]
   set sysName [getNameTag $tags]
   puts "System: $sysName"
   # find the port
   set sys [IBFabric_getSystem $gFabric $sysName]
   if {$sys == ""} {
      puts "-E- fail to find system $sysName in the fabric"
      return
   }
   PropsUpdate system $sys
}

proc showNodeMenu {c x y} {
   global gFabric
   set tags [$c itemcget current -tags]
   set nodeName [getNameTag $tags]
   # add node: if guid:
   if {[regexp {0x([0-9a-fA-F]{16})} $nodeName d1 n]} {
      set nodeName "node:$n"
   }
   puts "Node: $nodeName"

   set node [IBFabric_getNode $gFabric $nodeName]
   if {$node == ""} {
      puts "-E- fail to find node $nodeName in the fabric"
      puts "    [IBFabric_NodeByName_get $gFabric]"
      return
   }

   PropsUpdate node $node
}

proc showPortMenu {c x y} {
   global gPort gFabric
   set tags [$c itemcget current -tags]
   #  puts "-V- $tags"
   set ntag [getOfTag $tags]
   set node [$c find withtag ${ntag}&&node ]
   set nodeName [$c itemcget $node -text]
   set portName [getNameTag $tags]
   puts "Port: $nodeName $portName"

   # find the port
   set node [IBFabric_getNode $gFabric $nodeName]
   if {$node == ""} {
      puts "-E- fail to find node $nodeName in the fabric"
      puts "    [IBFabric_NodeByName_get $gFabric]"
      return
   }

   regexp {[0-9]+} $portName portNum
   set port [IBNode_getPort $node $portNum]
   if {$port == ""} {
      puts "-E- fail to find port $nodeName/$portName in the fabric"
      return
   }

   PropsUpdate port $port
}

proc showSysPortMenu {c x y} {
   global gPort gFabric
   set tags [$c itemcget current -tags]
   set ntag [getOfTag $tags]
   set systag [$c find withtag ${ntag}&&system ]
   set sysName [$c itemcget $systag -text]
   # add node: if guid:
   if {[regexp {0x([0-9a-fA-F]{16})} $sysName d1 n]} {
      set nodeName "system:$n"
   }
   set portName [getNameTag $tags]
   puts "SysPort: $sysName $portName"

   # find the port
   set sys [IBFabric_getSystem $gFabric $sysName]
   if {$sys == ""} {
      puts "-E- fail to find system $sysName in the fabric"
      return
   }

   set sysPort [IBSystem_getSysPort $sys $portName]
   if {$sysPort == ""} {
      puts "-E- fail to find system port $sysName/$portName in the fabric"
      return
   }

   PropsUpdate sysport $sysPort
}

# Perform the fabric update based on the availability of a topology
# and the LST file
proc GraphUpdate {lstFile} {
   global G
   global gTopoFabric
   global gLstFabric
   global gFabric
   global C

   # cleanup
   foreach fType {gFabric gTopoFabric gLstFabric} {
      if {[info exists $fType]} {
         delete_IBFabric [set $fType]
      }
   }

   set gFabric [new_IBFabric]

   if {![info exists G(argv:topo.file)]} {
      puts "-I- Parsing subnet lst: $lstFile"
      IBFabric_parseSubnetLinks $gFabric $lstFile
   } else {
      # load the topo
      set gTopoFabric [new_IBFabric]
      IBFabric_parseTopology $gTopoFabric $G(argv:topo.file)

      # load the lst
      set gLstFabric [new_IBFabric]
      IBFabric_parseSubnetLinks $gLstFabric $lstFile

      # compare and merge
      set m [ibdmMatchFabrics $gTopoFabric $gLstFabric \
                $G(argv:sys.name) $G(argv:port.num) $G(data:root.port.guid)]
      puts $m

      ibdmBuildMergedFabric $gTopoFabric $gLstFabric $gFabric
      puts "-I- Topo merged"
   }

   drawFabric $gFabric $C
}

# clear all highlights
proc guiClearAllMarking {} {
   global C

   set items [$C find withtag mark]
   puts "-I- Clearing mark on $items"
   foreach item $items {
      if {[llength [$C gettags $item]] == 1} {
         $C delete $item
      } else {
         $C dtag $item mark
         $C itemconfigure $item -fill black -activefill black
      }
   }
}

proc SetStatus {msg} {
   global S O StatusLine
   $S configure -state normal
   set StatusLine $msg
   $S configure -state readonly
   set color $O(color:txtDef)
   if {[regexp {^-([WEI])-} $msg d1 type]} {
      switch $type {
         E {set color $O(color:txtErr)}
         W {set color $O(color:txtWarn)}
         I {set color $O(color:txtInfo)}
      }
   }
   $S configure -foreground [lindex $color 2]
   update
}

# zoom to object by ibdm id
proc zoomToObjByIbdmId {type obj} {
   global C

   switch $type {
      system {
         set name [IBSystem_name_get $obj]
         set items [$C find withtag ${name}&&system]
      }
      node {
         set name [IBNode_name_get $obj]
         set items [$C find withtag ${name}&&node]
      }
      sysport {
         set sys [IBSysPort_p_system_get $obj]
         set sysName [IBSystem_name_get $sys]
         set name [IBSysPort_name_get $obj]
         set items [$C find withtag ${name}&&sysport&&of:$sysName]
      }
      port {
         set node [IBPort_p_node_get $obj]
         set nodeName [IBNode_name_get $node]
         set name "P[IBPort_num_get $obj]"
         set items [$C find withtag ${name}&&port&&of:$nodeName]
      }
   }
   if {[llength $items]} {
      set bbox [$C bbox $items]
      set xy [bboxCenter $bbox]
      zoom $C 1.0 [lindex $xy 0] [lindex $xy 1]
      puts "-I- Zooming on $bbox"
   } else {
      puts "-I- No items for $type $obj"
   }
}

# find and highlight a system by name
proc guiHighLightByName {objType name} {
   global gFabric C
   set items ""
   switch $objType {
      system {
         set sys [IBFabric_getSystem $gFabric $name]
         if {$sys == ""} {
            SetStatus "-W- Fail to find system by name:$name"
            return
         }
         PropsUpdate system $sys

         set items [$C find withtag ${name}&&system]
      }
      sysport {
         # we need to try each hier sep
         set sysName ""
         set sys ""
         set subNames [split $name /]

         while {[llength $subNames]} {
            set n [lindex $subNames 0]
            set subNames [lrange $subNames 1 end]
            if {$sysName != ""} { append sysName / }
            append sysName $n
            set sys [IBFabric_getSystem $gFabric $sysName]
            if {$sys != ""} { break }
         }

         if {$sys == ""} {
            SetStatus "-W- Fail to find system for port by name:\"$name\""
            return
         }

         set portName [join $subNames /]
         set sysPort [IBSystem_getSysPort $sys $portName]
         if {$sysPort == ""} {
            SetStatus "-W- Fail to find system port by name:\"$name\""
            return
         }
         PropsUpdate sysport $sysPort
         set items [$C find withtag ${portName}&&sysport&&of:$sysName]
      }
      node {
         set node [IBFabric_getNode $gFabric $name]
         if {$node == ""} {
            SetStatus "-W- Fail to find node by name:$name"
            return
         }
         PropsUpdate node $node
         set items [$C find withtag ${name}&&node]
         # we might need to look for a system...
         if {[llength $items] == 0} {
            set sys [IBNode_p_system_get $node]
            set sysName [IBSystem_name_get $sys]
            return [guiHighLightByName system $sysName]
         }
      }
      port {
         if {![regexp {(.*)/P([0-9]+)} $name d1 nodeName portNum]} {
            SetStatus "-W- Fail to find node for port by name:\"$name\""
            return
         }
         set node [IBFabric_getNode $gFabric $nodeName]
         if {$node == ""} {
            SetStatus "-W- Fail to find node for port by name:\"$name\""
            return
         }

         set port [IBNode_getPort $node $portNum]
         if {$port == ""} {
            SetStatus "-W- Fail to find port by name:\"$name\""
            return
         }
         PropsUpdate port $port
         set portName "P$portNum"

         set items [$C find withtag ${portName}&&port&&of:$nodeName]

         if {[llength $items] == 0} {
            set sysPort [IBPort_p_sysPort_get $port]
            set sys [IBNode_p_system_get $node]
            set sysName [IBSystem_name_get $sys]
            if {$sysPort == ""} {
               # it is internal - just highlight the sys
               return [guiHighLightByName system $sysName]
            } else {
               set sysPortName "$sysName/[IBSysPort_name_get $sysPort]"
               return [guiHighLightByName sysport $sysPortName]
            }
         }

      }
   }

   if {![llength $items]} {
      SetStatus "-W- Fail to find any displayed obejct for $objType name:\"$name\""
      return
   }

   set bbox [$C bbox $items]
   zoom $C 1.0 [lindex $bbox 0] [lindex $bbox 1]
   foreach item $items {
      $C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
      $C addtag mark withtag $item
   }

   return $items
}

# find and highlight a system by name
proc guiHighLightByGuid {objType guid} {
   global gFabric C

   # we try getting by system/node/port
   set sys [IBFabric_getSystemByGuid $gFabric $guid]
   set node [IBFabric_getNodeByGuid $gFabric $guid]
   set port [IBFabric_getPortByGuid $gFabric $guid]

   switch $objType {
      system {
         if {$sys != ""} {
            set name [IBSystem_name_get $sys]
         } elseif {$node != ""} {
            set sys [IBNode_p_system_get $node]
            set name [IBSystem_name_get $sys]
         } elseif {$port != ""} {
            set node [IBPort_p_node_get $port]
            set sys [IBNode_p_system_get $node]
            set name [IBSystem_name_get $sys]
         } else {
            SetStatus "-W- Fail to find system by guid:$guid"
            return
         }

         set obj $sys
         set items [$C find withtag ${name}&&system]
      }
      node {
         if {$node != ""} {
            set name [IBNode_name_get $node]
         } elseif {$port != ""} {
            set node [IBPort_p_node_get $port]
            set name [IBNode_name_get $node]
         } else {
            SetStatus "-W- Fail to find node by guid:$guid"
            return
         }
         set obj $node
         set items [$C find withtag ${name}&&node]
      }
      port {
         if {$port == ""} {
            SetStatus "-W- Fail to find port by guid:$guid"
            return
         }
         set obj $port

         set nodeName [IBNode_name_get [IBPort_p_node_get $port]]
         set name "P[IBPort_num_get $port]"
         set items [$C find withtag ${name}&&port&&of:$nodeName]
      }
      sysport {
         if {$port == ""} {
            SetStatus "-W- Fail to find system port by guid:$guid"
            return
         }

         set sysPort [IBPort_p_sysPort_get $port]
         if {$sysPort == ""} {
            SetStatus "-W- Fail to find system port for port with guid:$guid"
            return
         }

         set sys [IBSysPort_p_system_get $sysPort]
         set sysName [IBSystem_name_get $sys]
         set name [IBSysPort_name_get $sysPort]
         set obj $sysPort
         set items [$C find withtag ${name}&&sysport&&of:$sysName]
      }
   }

   if {![llength $items]} {
      SetStatus "-W- Fail to find any displayed obejct for $objType name:\"$name\""
      return
   }

   PropsUpdate $objType $obj
   set bbox [$C bbox $items]
   zoom $C 1.0 [lindex $bbox 0] [lindex $bbox 1]
   foreach item $items {
      $C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
      $C addtag mark withtag $item
   }
   return $items
}

# find and highlight a system by name
proc guiHighLightByLid {objType lid} {
   global gFabric C

   # we try getting port by lid:
   set port [IBFabric_getPortByLid $gFabric $lid]
   if {$port == ""} {
      SetStatus "-W- Fail to find port by lid:$lid"
      return
   }

   switch $objType {
      system {
         set node [IBPort_p_node_get $port]
         set sys [IBNode_p_system_get $node]
         set name [IBSystem_name_get $sys]
         set items [$C find withtag ${name}&&system]
      }
      node {
         set node [IBPort_p_node_get $port]
         set name [IBNode_name_get $node]
         set items [$C find withtag ${name}&&node]
      }
      port {
         set nodeName [IBNode_name_get [IBPort_p_node_get $port]]
         set name "P[IBPort_num_get $port]"
         set items [$C find withtag ${name}&&port&&of:$nodeName]
      }
      sysport {
         set sysPort [IBPort_p_sysPort_get $port]
         if {$sysPort == ""} {
            SetStatus "-W- Fail to find system port for port with lid:$lid"
            return
         }

         set sys [IBSysPort_p_system_get $sysPort]
         set sysName [IBSystem_name_get $sys]
         set name [IBSysPort_name_get $sysPort]
         set items [$C find withtag ${name}&&sysport&&of:$sysName]
      }
   }

   if {![llength $items]} {
      SetStatus "-W- Fail to find any displayed obejct for $objType lid:$lid"
      return
   }

   set bbox [$C bbox $items]
   zoom $C 1.0 [lindex $bbox 0] [lindex $bbox 1]
   foreach item $items {
      $C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
      $C addtag mark withtag $item
   }
   return $items
}

# return a sys port if exists
proc findSysPortByName {name} {
   global gFabric
   # we need to try each hier sep
   set sysName ""
   set sys ""
   set subNames [split $name /]
   set sysPort ""
   while {[llength $subNames]} {
      set n [lindex $subNames 0]
      set subNames [lrange $subNames 1 end]
      if {$sysName != ""} { append sysName / }
      append sysName $n
      set sys [IBFabric_getSystem $gFabric $sysName]
      if {$sys != ""} { break }
   }

   if {$sys != ""} {
      set portName [join $subNames /]
      set sysPort [IBSystem_getSysPort $sys $portName]
   }
   return $sysPort
}

# simpler as we know the node ports end with P[0-9]+
proc findPortByName {name} {
   global gFabric

   if {![regexp {(.*)/P([0-9]+)$} $name d1 nodeName portNum]} {
      return ""
   }

   set node [IBFabric_getNode $gFabric $nodeName]
   if {$node == ""} {
      return ""
   }

   return [IBNode_getPort $node $portNum]
}

proc bboxCenter {bbox {xScale 0.5} {yScale 0.5}} {
   foreach {x0 y0 x1 y1} $bbox {break}
   return [list [expr ($x0*(1-$xScale) + $x1*$xScale)] \
              [expr ($y0*(1-$yScale) + $y1*$yScale)] ]
}

# highlight all objects accross the directed route
proc guiHighLightByDR {startPort route} {
   global C
   # first we try to get the given start port
   set allItems {}

   set sysPort [findSysPortByName $startPort]
   if {$sysPort == ""} {
      # try to get a port by that name
      set port [findPortByName $startPort]
      if {$port == ""} {
         SetStatus "-W- Fail to find system port or port with name:\"$startPort\""
         return
      }
   } else {
      set port [IBSysPort_p_nodePort_get $sysPort]
   }

   # need to traverse from that port/sysport
   # if the given path is made of [] we need to convert hex to dec
   if {[regexp {^\s*([[][0-9a-fA-F][]])+\s*$} $route]} {
      set dr {}
      foreach h [split $route {[]}] {
         if {$h != ""} {
            lappend dr [expr 0x$h]
         }
      }
   } else {
      set dr [split $route ", "]
   }

   if {[lindex $dr 0] == 0} {
      set dr [lrange $dr 1 end]
   }

   # traverse the path
   set hop 0
   foreach p $dr {
      set items ""
      set node [IBPort_p_node_get $port]
      set outPort [IBNode_getPort $node $p]
      if {$outPort == ""} {
         SetStatus "-W- Got dead end on path at node:\"[IBNode_name_get $node]\" port:$p\""
         break
      }

      # highlight outgoing port and sysport
      set nodeName [IBNode_name_get [IBPort_p_node_get $outPort]]
      set name "P[IBPort_num_get $outPort]"
      set iItems [$C find withtag ${name}&&port&&of:$nodeName]
      set allItems [concat $allItems $iItems]

      set sysPort [IBPort_p_sysPort_get $outPort]
      if {$sysPort != ""} {
         set sys [IBSysPort_p_system_get $sysPort]
         set sysName [IBSystem_name_get $sys]
         set name [IBSysPort_name_get $sysPort]
         set items [$C find withtag ${name}&&sysport&&of:$sysName]
         set iItems [concat $iItems $items]
      }
      set allItems [concat $allItems $iItems]

      if {[llength $iItems]} {
         set outCoords [bboxCenter [$C bbox [lindex $iItems 0]] [expr rand()*0.95]]
      }

      set port [IBPort_p_remotePort_get $outPort]
      if {$port == ""} {
         SetStatus "-W- No remote port on path at node:\"[IBNode_name_get $node]\" port:$p\""
         $C create text $outCoords -tags mark -fill [getColor mark] -text "DEAD END ($p)"
         break
      }

      # highlight input port and sysport
      set items ""
      set nodeName [IBNode_name_get [IBPort_p_node_get $port]]
      set name "P[IBPort_num_get $port]"
      set items [$C find withtag ${name}&&port&&of:$nodeName]
      set allItems [concat $allItems $items]
      set oItems $items

      set sysPort [IBPort_p_sysPort_get $port]
      if {$sysPort != ""} {
         set sys [IBSysPort_p_system_get $sysPort]
         set sysName [IBSystem_name_get $sys]
         set name [IBSysPort_name_get $sysPort]
         set items [$C find withtag ${name}&&sysport&&of:$sysName]
         set oItems [concat $oItems $items]
      }
      set allItems [concat $allItems $oItems]

      if {[llength $oItems]} {
         set inCoords [bboxCenter [$C bbox [lindex $oItems 0]] [expr rand()*0.95]]

         # create a marker
         $C create line [concat $outCoords $inCoords] \
            -tags mark -fill [getColor mark] -arrow last
         set x [expr ([lindex $outCoords 0] + [lindex $inCoords 0]) / 2.0]
         set y [expr ([lindex $outCoords 1] + [lindex $inCoords 1]) / 2.0]
         $C create text $x $y -anchor w -text $hop -tags mark -fill [getColor mtxt]
      }

      incr hop
   }

   foreach item $allItems {
      $C itemconfigure $item -fill [getColor mark] -activefill [getColor mark]
      $C addtag mark withtag $item
   }
   return $allItems
}

##############################################################################
#
# PROPS Widget Commands
#
##############################################################################
proc PropsUpdate {objType ibdmHandle {zoom 0}} {
   global P
   # prevents recursion loop
   global _PropsUpdate_inside
   if {$ibdmHandle == ""} {return}

   if {[info exists _PropsUpdate_inside] && $_PropsUpdate_inside} {return}
   set _PropsUpdate_inside 1

   if {$ibdmHandle == ""} { return }

   foreach c [winfo child $P] {
      pack forget $c
   }

   switch $objType {
      system  {PropsSystem  $ibdmHandle}
      node    {PropsNode    $ibdmHandle}
      port    {PropsPort    $ibdmHandle}
      sysport {PropsSysPort $ibdmHandle}
   }

   # zoom to that object
   if {$zoom} {
      zoomToObjByIbdmId $objType $ibdmHandle
   }
   set _PropsUpdate_inside 0
}

proc PropsSystem {sys} {
   global P PROPS
   set PROPS(sys,id)   $sys
   set PROPS(sys,name) [IBSystem_name_get $sys]
   set PROPS(sys,type) [IBSystem_type_get $sys]
   set PROPS(sys,guid) [IBSystem_guid_get $sys]
   set PROPS(sys,nodes,id) [IBSystem_NodeByName_get $sys]
   set PROPS(sys,nodes) [llength $PROPS(sys,nodes,id)]
   set b $PROPS(sys,nodes,menu)
   $b delete 0 end
   set i 0
   foreach nameNNode $PROPS(sys,nodes,id) {
      $b insert $i command -label [lindex $nameNNode 0] \
         -command "PropsUpdate node [lindex $nameNNode 1]"
      incr i
   }
   pack $P.sys -expand yes -fill x -anchor nw
}

proc PropsNode {node} {
   global P PROPS
   pack $P.node -expand yes -fill x -anchor nw
   set PROPS(node,id)     $node
   set PROPS(node,name)   [IBNode_name_get $node]
   set PROPS(node,guid)   [IBNode_guid_get $node]
   set PROPS(node,ports)  [IBNode_numPorts_get $node]
   set PROPS(node,dev)    [IBNode_devId_get $node]
   set PROPS(node,rev)    [IBNode_revId_get $node]
   set PROPS(node,vend)   [IBNode_vendId_get $node]
   set PROPS(node,sys,id) [IBNode_p_system_get $node]
   set PROPS(node,sys)    [IBSystem_name_get $PROPS(node,sys,id)]
   set PROPS(node,dr)     [getDrToNode $node]
   set b $PROPS(node,ports,menu)
   $b delete 0 end
   set i 0
   for {set pn 1} {$pn <= $PROPS(node,ports)} {incr pn} {
      set port [IBNode_getPort $node $pn]
      if {$port != ""} {
         $b insert $i command -label "P$pn" \
            -command "PropsUpdate port $port 1"
         incr i
      }
   }
}

proc PropsPort {port} {
   global P PROPS
   pack $P.port -expand yes -fill x -anchor nw
   set PROPS(port,id)    $port
   set PROPS(port,name)  [IBPort_getName $port]
   set PROPS(port,guid)  [IBPort_guid_get $port]
   set PROPS(port,lid)   [IBPort_base_lid_get $port]
   set PROPS(port,speed) [IBPort_speed_get $port]
   set PROPS(port,width) [IBPort_width_get $port]
   set node [IBPort_p_node_get $port]
   set PROPS(port,node,id) $node
   set PROPS(port,node)  [IBNode_name_get $node]
   set remPort [IBPort_p_remotePort_get $port]
   set PROPS(port,rem,id) $remPort
   if {$remPort != ""} {
      set PROPS(port,rem) [IBPort_getName $remPort]
   } else {
      set PROPS(port,rem) "NOT CONNECTED"
   }
   set sysPort [IBPort_p_sysPort_get $port]
   set PROPS(port,sysp,id) $sysPort
   if {$sysPort != ""} {
      set sys [IBSysPort_p_system_get $sysPort]
      set PROPS(port,sysp) \
         "[IBSystem_name_get $sys]/[IBSysPort_name_get $sysPort]"
   } else {
      set PROPS(port,sysp) "NONE"
   }
}

proc PropsSysPort {sysPort} {
   global P PROPS ANNOTATIONS
   pack $P.sysport -expand yes -fill x -anchor nw
   set PROPS(sysport,id)    $sysPort
   set PROPS(sysport,name)   [IBSysPort_name_get $sysPort]
   set PROPS(sysport,sys,id) [IBSysPort_p_system_get $sysPort]
   set PROPS(sysport,sys)    [IBSystem_name_get $PROPS(sysport,sys,id)]
   set port [IBSysPort_p_nodePort_get $sysPort]
   set PROPS(sysport,width) [IBPort_width_get $port]
   set PROPS(sysport,speed) [IBPort_speed_get $port]
   set node [IBPort_p_node_get $port]
   set PROPS(sysport,port,id) $port
   set PROPS(sysport,port) \
      "[IBNode_name_get $node]/P[IBPort_num_get $port]"
   set remSysPort [IBSysPort_p_remoteSysPort_get $sysPort]
   set PROPS(sysport,rem,id) $remSysPort
   if {$remSysPort != ""} {
      set remSys [IBSysPort_p_system_get $remSysPort]
      set PROPS(sysport,rem) \
         "[IBSystem_name_get $remSys]/[IBSysPort_name_get $remSysPort]"
   } else {
      set PROPS(sysport,rem) "NOT CONNECTED"
   }
   set fullName "$PROPS(sysport,sys)/$PROPS(sysport,name)"
   if {[info exists ANNOTATIONS(sysport:$fullName)]} {
      set PROPS(sysport,anno) $ANNOTATIONS(sysport:$fullName)
   } else {
      set PROPS(sysport,anno) ""
   }
}

# get a DR to a port by its ID
# BFS untill finding it ...
proc getDrToNode {targetNode} {
   global G
   global gFabric

   set startPort [IBFabric_getPortByGuid $gFabric $G(data:root.port.guid)]
   if {$startPort == ""} {
      puts "-E- Fail to find start port !"
      return -1
   }

   set Q [list [list [IBPort_p_node_get $startPort] "0"]]
   while {[llength $Q]} {
      set nodeNPath [lindex $Q 0]
      set Q [lreplace $Q 0 0]

      set node [lindex $nodeNPath 0]
      set path [lindex $nodeNPath 1]

      if {$node == $targetNode} {
         puts "-I- Found node [IBNode_name_get $targetNode] at path:$path"
         return $path
      }

      set VISITED($node) 1

      for {set pn 1} {$pn <= [IBNode_numPorts_get $node]} {incr pn} {
         set port [IBNode_getPort $node $pn]
         if {$port == ""} {continue}
         set remPort [IBPort_p_remotePort_get $port]
         if {$remPort == ""} {continue}
         set remNode [IBPort_p_node_get $remPort]
         if {[info exists VISITED($remNode)]} {continue}
         lappend Q [list $remNode "$path,$pn"]
      }
   }
   puts "-W- Failed to find node [IBNode_name_get $targetNode]"
   return -1
}

# select a port number gui
proc numSelector {maxNum title} {
   global numSelectorVal
   if {![winfo exists .num_select]} {
      set t [toplevel .num_select]
      wm withdraw $t
      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
      label $t.l -text $title
      pack $t.l -side top -expand yes -fill x
      set o [tk_optionMenu $f.b numSelectorVal 1]
      for {set i 2} {$i < $maxNum} {incr i} {
         $o insert $i command -label $i \
            -command "global numSelectorVal; update;set numSelectorVal $i"
      }
      set numSelectorVal 1
      pack $f.b -side left -padx 2 -pady 2
      pack $f
   }
   wm title .num_select $title
   wm deiconify .num_select
   update
   tkwait variable numSelectorVal
   destroy .num_select
   return $numSelectorVal
}

# we rely on the current PROP for
proc setPortState {state {port 0}} {
   global PROPS

   if {$port == 0} {
      set port $PROPS(port,id)
   }

   set node [IBPort_p_node_get $port]

   set drPath [getDrToNode $node]
   if {$drPath == -1} {
      return
   }

   set portNum [IBPort_num_get $port]
   if {[catch {set res [exec ibportstate -D $drPath $portNum $state]} e]} {
      LogAppend "\n-E---------------------------------------------------\n$e"
   } else {
      LogAppend "\n-I---------------------------------------------------\n$res"
   }
}

proc setNodePortState {state} {
   global PROPS
   set node $PROPS(node,id)

   set drPath [getDrToNode $node]
   if {$drPath == -1} {
      return
   }

   set portNum [numSelector [IBNode_numPorts_get $node] \
                   "Select a port number"]
   if {$portNum == ""} { return }

   if {[catch {set res [exec ibportstate -D $drPath $portNum $state]} e]} {
      LogAppend "\n-E---------------------------------------------------\n$e"
   } else {
      LogAppend "\n-I---------------------------------------------------\n$res"
   }
}

proc setSysPortState {state} {
   global PROPS

   set sysPort $PROPS(sysport,id)
   set port [IBSysPort_p_nodePort_get $sysPort]
   setPortState $state $port
}

proc portCounters {op {port 0}} {
   global PROPS

   if {$port == 0} {
      set port $PROPS(port,id)
   }

   set lid [IBPort_base_lid_get $port]
   if {$lid == 0} {
   }
   set portNum [IBPort_num_get $port]
   if {$op == "clr"} {
      set opt -R
   } else {
      set opt ""
   }

   set cmd "perfquery $opt $lid $portNum"
   if {[catch {eval "set res \[exec $cmd\]"} e]} {
      LogAppend "\n-E---------------------------------------------------\n$cmd\n$e"
   } else {
      LogAppend "\n-I---------------------------------------------------\n$cmd\n$res"
   }
}

# when port counters are queries from Node
# NOTE: we can not rely on the existance of the port
proc nodePortCounters {op} {
   global PROPS
   set node $PROPS(node,id)

   set portNum [numSelector [IBNode_numPorts_get $node] \
                   "Select a port number"]
   if {$portNum == ""} { return }

   # find first port that match
   set port ""
   for {set pn 1} {$pn < [IBNode_numPorts_get $node]} {incr pn} {
      set port [IBNode_getPort $node $pn]
      if {$port != ""} {break}
   }
   if {$port == ""} {return}

   set lid [IBPort_base_lid_get $port]
   if {$op == "clr"} {
      set opt -R
   } else {
      set opt ""
   }

   if {[catch {eval "set res [exec perfquery $opt $lid $portNum]"} e]} {
      LogAppend "\n-E---------------------------------------------------\n$e"
   } else {
      LogAppend "\n-I---------------------------------------------------\n$res"
   }
}

proc sysPortCounters {op} {
   global PROPS

   set sysPort $PROPS(sysport,id)
   set port [IBSysPort_p_nodePort_get $sysPort]
   portCounters $op $port
}

##############################################################################
#
# LOG WIDGET COMMANDS
#
##############################################################################

# perform log analysis from the given index
proc LogAnalyze {{startIndex 0.0}} {
   global L
   set text [$L get $startIndex end]
   # loop through the text for sections:
   set startChar 0
   set numErrs 0
   set numWarnings 0
   set numInfos 0

   set rex "\n-(\[IWE\])-\[^\n\]*(\n\[^-\]\[^\n\]*)*"
   while {[regexp -start $startChar -indices -- $rex $text all type]} {
      set start [lindex $all 0]
      set type [string range $text [lindex $type 0] [lindex $type 1]]
      set sIdx [lindex $all 0]
      set eIdx [expr [lindex $all 1] + 1]
      switch $type {
         E { set tagName errors; incr numErrs }
         W { set tagName warnings; incr numWarnings }
         I { set tagName infos; incr numInfos }
      }
      $L tag add $tagName "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
      set startChar [lindex $all 1]
   }
   puts "-I- Found $numErrs errors $numWarnings warnings $numInfos infos"

   # Now scan for names guids and routes...
   set startChar 0
   set numNames 0

   set rex "\\s+\"(\[^0-9\]\[^\"\]+)\"\\s+"
   while {[regexp -start $startChar -indices -- $rex $text all name]} {
      set sIdx [lindex $name 0]
      set eIdx [expr [lindex $name 1] + 1]
      $L tag add NAME "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
      set startChar [lindex $all 1]
      incr numNames
   }

   set startChar 0
   set numLids 0
   set rex {(lid|LID)[\s:=]*(0x[0-9a-fA-F]+|[0-9]+)}
   while {[regexp -start $startChar -indices -- $rex $text all pre lid]} {
      set sIdx [lindex $lid 0]
      set eIdx [expr [lindex $lid 1] + 1]
      $L tag add LID "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
      set startChar [lindex $all 1]
      incr numLids
   }

   set startChar 0
   set numGuids 0
   set rex {[Gg][Uu][Ii][Dd]=*(0x[0-9a-fA-F]+)}
   while {[regexp -start $startChar -indices -- $rex $text all guid]} {
      set sIdx [lindex $guid 0]
      set eIdx [expr [lindex $guid 1] + 1]
      $L tag add GUID "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
      set startChar [lindex $all 1]
      incr numGuids
   }

   set startChar 0
   set numRoutes 0
   set rex {\"([0-9]+(,[0-9]+)*)\"}
   while {[regexp -start $startChar -indices -- $rex $text all route]} {
      set sIdx [lindex $route 0]
      set eIdx [expr [lindex $route 1] + 1]
      $L tag add ROUTE "$startIndex + $sIdx chars" "$startIndex + $eIdx chars"
      set startChar [lindex $all 1]
      incr numRoutes
   }

   puts "-I- Found $numNames names $numLids LIDS $numGuids GUIDs $numRoutes Directed-Routes"
}

proc LogUpdate {log} {
   global L

   #puts $log

   # Filter out any "discovring" message
   set nlog $log
   set discRex  "-I- Discovering the subnet ... \[0-9\]+ nodes .\[0-9\]+ Switches & \[0-9\]+ CA-s. discovered.\\s*\n"
   regsub -all -- $discRex $log "" nlog

   # perform the log area update
   $L configure -state normal
   $L delete 0.0 end
   $L insert 0.0 $nlog

   # Do some hypertexting
   LogAnalyze
   $L configure -state disabled
}

proc LogAppend {log {scrollToPos 1}} {
   global L
   set start [$L index end]
   $L configure -state normal
   $L insert end "$log\n"
   $L configure -state disabled
   if {$scrollToPos} {
      $L see end
   }
   LogAnalyze $start
   update
}

# an object tag was selected
proc LogObjSelect {log type w x y} {
   global G
   # get the tag text under the x y
   set startNEnd [$log tag prevrange $type @$x,$y]
   set val [$log get [lindex $startNEnd 0] [lindex $startNEnd 1]]
   switch $type {
      NAME {
         if {[guiHighLightByName port $val] != ""} {
            SetStatus "-I- Found Port $val"
         } elseif {[guiHighLightByName node $val] != ""} {
            SetStatus "-I- Found Node $val"
         } elseif {[guiHighLightByName system $val] != ""} {
            SetStatus "-I- Found System $val"
         } elseif {[guiHighLightByName sysport $val] != ""} {
            SetStatus "-I- Found System Port $val"
         } else {
            SetStatus "-I- Failed to find object with name $val"
         }
      }
      LID {
         set x [guiHighLightByLid sysport $val]
         set y [guiHighLightByLid port $val]
         if {$x != "" || $y != ""} {
            SetStatus "-I- Find by LID succeeded"
         }
      }
      ROUTE {
         guiHighLightByDR  "$G(argv:sys.name)/P$G(argv:port.num)" $val
      }
      GUID {
         set x [guiHighLightByGuid system $val]
         set y [guiHighLightByGuid sysport $val]
         if {$x != "" || $y != ""} {
            SetStatus "-I- Find by GUID succeeded"
         }
      }
   }
}

# initialize the props guid such that we have a pannel
# for each object type
proc initPropsGui {p} {
   global PROPS O

   set props {
      {sys SYSTEM
         {
            name Name ""
            type Type ""
            guid GUID ""
            nodes "\#Node" {PropsUpdate node $PROPS(sys,node,id) 1}
         }
      }
      {node NODE
         {
            name Name ""
            guid GUID ""
            dr   "Directed Route" ""
            sys  System     {PropsUpdate system $PROPS(node,sys,id) 1}
            ports "\#Ports" {PropsUpdate port  $PROPS(node,port,id) 1}
            dev "Device ID" ""
            rev "Revision ID" ""
            vend "Vendor ID"
         }
      }
      {port PORT
         {
            name Name ""
            guid GUID ""
            lid LID ""
            speed Speed ""
            width Width ""
            node Node    {PropsUpdate node    $PROPS(port,node,id) 1}
            rem Conn     {PropsUpdate port    $PROPS(port,rem,id)  1}
            sysp SysPort {PropsUpdate sysport $PROPS(port,sysp,id) 1}
         }
      }
      {sysport "FRONT PANEL PORT"
         {
            name Name ""
            sys System         {PropsUpdate system  $PROPS(sysport,sys,id)  1}
            port "Node Port"   {PropsUpdate port    $PROPS(sysport,port,id) 1}
            rem "Connected to" {PropsUpdate sysport $PROPS(sysport,rem,id)  1}
            width Width ""
            speed Speed ""
            anno Annotation ""
         }
      }
   }

   set cmds {
      {sys}
      {node
         {{UP "setNodePortState enable"} {DOWN "setNodePortState disable"}}
         {{"PM Get" "nodePortCounters get"} {"PM Clr" "nodePortCounters clr"}}
      }
      {port
         {{UP "setPortState enable"} {DOWN "setPortState disable"}}
         {{"PM Get" "portCounters get"} {"PM Clr" "portCounters clr"}}
      }
      {sysport
         {{UP "setSysPortState enable"} {DOWN "setSysPortState disable"}}
         {{"PM Get" "sysPortCounters get"} {"PM Clr" "sysPortCounters clr"}}
      }
   }

   foreach propSet $props {
      set obj [lindex $propSet 0]
      frame $p.$obj -background [lindex $O(color:$obj) 2] -padx 2 -pady 2
      set f $p.$obj.f
      frame $f
      set header [lindex $propSet 1]
      label $f.l -text $header
      pack $f.l -side top
      foreach {attr lbl cmd} [lindex $propSet 2] {
         frame $f.$attr -borderwidth 2 -relief ridge
         label $f.$attr.l -text "$lbl:"

         if {[string range $lbl 0 0] == "\#"} {
            label $f.$attr.v -textvariable PROPS($obj,$attr)
            set PROPS($obj,$attr,menu) \
               [tk_optionMenu $f.$attr.m PROPS($obj,$attr,sel) \
                   "Select a [string range $lbl 1 end]"]
            pack $f.$attr.l -side top -anchor w
            pack $f.$attr.m -side right -anchor e -expand yes -fill x
            pack $f.$attr.v -side left -anchor w
            set PROPS($obj,$attr,cb) $cmd
            set cmd ""
         } else {
            entry $f.$attr.v -textvariable PROPS($obj,$attr) \
               -exportselection 1 -state readonly -relief flat
            pack $f.$attr.l $f.$attr.v -side top -anchor nw \
               -expand true -fill x
         }
         pack $f.$attr -side top -fill x -anchor nw
         if {$cmd != ""} {
            bind $f.$attr.l <ButtonPress-2> $cmd
            bind $f.$attr.v <ButtonPress-2> $cmd
         }
      }
      pack $f -side top -expand yes -fill both
   }

   foreach cmdSet $cmds {
      set lineIdx 0
      set obj [lindex $cmdSet 0]
      foreach lineDef [lrange $cmdSet 1 end] {
         set f $p.$obj.f
         incr lineIdx
         frame $f.cmds$lineIdx
         set bIdx 0
         foreach bnc $lineDef {
            set b [lindex $bnc 0]
            set c [lindex $bnc 1]
            incr bIdx
            button $f.cmds$lineIdx.$bIdx -text $b -command $c
            pack $f.cmds$lineIdx.$bIdx -side left -anchor w
         }
         pack $f.cmds$lineIdx -side top -anchor w
      }
   }
}

##############################################################################
#
# MAIN MENU COMMANDS
#
##############################################################################
proc getNodeLid {node} {
   set port ""
   for {set pn 1} {$pn <= [IBNode_numPorts_get $node]} {incr pn} {
      set port [IBNode_getPort $node $pn]
      if {$port != ""} {
         set remPort [IBPort_p_remotePort_get $port]
         if {$remPort != ""} {break}
      }
   }
   if {$remPort == ""} {return 0}
   set lid [IBPort_base_lid_get $port]
   return $lid
}

# given a key and a list of ley/value pairs get the pair
proc assoc {key key_list} {
   foreach kv $key_list {
      if {[lindex $kv 0] == $key} {return [lindex $kv 1]}
   }

   return ""
}

proc SetVL0Statics {} {
   global gFabric

   set staticCredits 0x68
   foreach nNNode [IBFabric_NodeByName_get $gFabric] {
      set node [lindex $nNNode 1]
      set sys [IBNode_p_system_get $node]
      set name "[IBSystem_name_get $sys]/[lindex $nNNode 0]"
      set devId [IBNode_devId_get $node]
      set lid [getNodeLid $node]
      if {$lid == 0} {
         puts "-W- Ignoring node $name with zero LID"
         continue
      }

      # differet treatment for switches and HCAs
      switch $devId {
         23108 -
         25204 -
         25208 -
         25218 {
            # port 1 0x100A0.24 (len 7)
            set v [crRead $lid 0x100A0]
            set d [assoc data $v]
            if {$d == ""} {
               puts "-W- Failed to obtain data from $name lid:$lid"
               continue
            }

            set nd [format 0x%x [expr $d & 0x8fffffff | ($staticCredits << 24)]]
            if {$d != $nd} {
               puts "-I- Updating $name P1 $d -> $nd"
               crWrite $lid $nd 0x100A0
            }
            if {$devId != 25208} {
               # port 2 0x108A0.24
               set v [crRead $lid 0x108A0]
               set d [assoc data $v]
               if {$d == ""} {
                  puts "-W- Failed to obtain data from $name lid:$lid"
                  continue
               }

               set nd [format 0x%x [expr $d & 0x8fffffff | ($staticCredits << 24)]]
               if {$d != $nd} {
                  puts "-I- Updating $name P2 $d -> $nd"
                  crWrite $lid $nd 0x108A0
               }
            }
         }
         47396 {
            set addr 0x101280
            for {set i 0} {$i < 24} {incr i} {
               # IB port 1 101280.16
               # CR 0  101280.16 (len 16)
               # CR 1  102280.16
               # CR 23 118280.16
               set v [crRead $lid $addr]
               set d [assoc data $v]
               if {$d == ""} {
                  puts "-W- Failed to obtain data from $name lid:$lid"
                  continue
               }
               set nd [format 0x%x [expr $d & 0xffff | ($staticCredits << 16)]]
               if {$d != $nd} {
                  puts "-I- Updating $name P[expr $i + 1] $d -> $nd"
                  crWrite $lid $nd $addr
               }

               incr addr 0x1000
            }
         }
         default {
            puts "-W- Ignoring node $name with devId:$devId"
         }
      }
   }

}

proc DiagNet {} {
   global G
   global testModeDir
   global IBDIAGNET_FLAGS

   # can we just load existing files?
   if {$testModeDir != 0} {
      set f [open [file join $testModeDir ibdiagnet.stdout.log] r]
      set res [read $f]
      close $f
      set lstFile [file join $testModeDir ibdiagnet.lst]
   } else {
      set lstFile /tmp/ibdiagnet.lst
      set r ""
      LogAppend "-I-Invoking ibdiagnet ...."
      # puts "-I- Invoking ibdiagnet ...."
      if {[catch {set r [eval "exec ibdiagnet $IBDIAGNET_FLAGS"]} e]} {
         set res "-E- Error calling ibdiagnet:$e\n"
         append res $r
      } else {
         set res $r
      }
   }

   LogUpdate $res

   GraphUpdate $lstFile
}

# reread the annotations file and enforce DISABLED state
# and UP for the rest
proc EnforceAnnotations {} {
   global ANNOTATIONS
   LoadAnnotationsFile
   set numEn 0
   set numDis 0
   foreach e [array names ANNOTATIONS sysport:*] {
      set sysPortName [string range $e [string length sysport:] end]
      set anno $ANNOTATIONS($e)

      # find the sys port
      set sysPort [findSysPortByName $sysPortName]
      if {$sysPort == ""} {
         puts "-W- failed to find sys port:$sysPortName"
         continue
      }

      set port [IBSysPort_p_nodePort_get $sysPort]
      set node [IBPort_p_node_get $port]

      if {[regexp DISABLED $anno]} {
         SetStatus "-I- Disabling $sysPortName"
         set state disable
         incr numDis
      } else {
         SetStatus "-I- Enabling $sysPortName"
         set state enable
         incr numEn
      }

      set drPath [getDrToNode $node]
      if {$drPath == -1} {
         return
      }

      set portNum [IBPort_num_get $port]
      catch {set res [exec ibportstate -D $drPath $portNum $state]}
   }
   SetStatus "-I- Annotation Enforced: Enabled:$numEn Disbled:$numDis"

}

proc FindByName {} {
   global FindByName
   if {![winfo exists .find_by_name]} {
      set t [toplevel .find_by_name]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]

      labelframe $f.e -text "Name:" -padx 2 -pady 2 -borderwidth 2
      entry $f.e.e -textvariable FindByName(name)
      pack $f.e.e -side left -fill x -expand yes

      labelframe $f.b -text "Object Type:" -padx 2 -pady 2 -borderwidth 2
      foreach {type name} {system System sysport "System Port" node Node port Port} {
         radiobutton $f.b.b$type -text "$name" -variable FindByName(type) \
            -relief flat -value $type
         pack $f.b.b$type -side top -pady 2 -anchor w
      }
      pack $f.e $f.b -side top -expand yes -fill both
      frame $f.x
      button $f.x.f -text FIND \
         -command {guiHighLightByName $FindByName(type) $FindByName(name)}
      button $f.x.c -text CLEAR -command guiClearAllMarking
      pack $f.x.f $f.x.c -side left -fill x -expand yes
      pack $f.x -side bottom -fill x -expand yes
      pack $f
      wm title .find_by_name "IBDiagUI - Find object by name"
      set FindByName(type) system

   }
   wm deiconify .find_by_name
}

proc FindByGUID {} {
   global FindByGuid
   if {![winfo exists .find_by_guid]} {
      set t [toplevel .find_by_guid]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]

      labelframe $f.e -text "GUID:" -padx 2 -pady 2 -borderwidth 2
      entry $f.e.e -textvariable FindByGuid(guid)
      pack $f.e.e -side left -fill x -expand yes

      labelframe $f.b -text "Object Type:" -padx 2 -pady 2 -borderwidth 2
      foreach {type name} {system "System" sysport "System Port" node "Node" port "Port"} {
         radiobutton $f.b.b$type -text "$name" -variable FindByGuid(type) \
            -relief flat -value $type
         pack $f.b.b$type -side top -pady 2 -anchor w
      }
      pack $f.e $f.b -side top -expand yes -fill both
      frame $f.x
      button $f.x.f -text FIND \
         -command {guiHighLightByGuid $FindByGuid(type) $FindByGuid(guid)}
      button $f.x.c -text CLEAR -command guiClearAllMarking
      pack $f.x.f $f.x.c -side left -fill x -expand yes
      pack $f.x -side bottom -fill x -expand yes
      pack $f
      wm title .find_by_guid "IBDiagUI - Find object by GUID"
      set FindByGuid(type) system

   }
   wm deiconify .find_by_guid
}

proc FindByLID {} {
   global FindByLid
   if {![winfo exists .find_by_lid]} {
      set t [toplevel .find_by_lid]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]

      labelframe $f.e -text "LID:" -padx 2 -pady 2 -borderwidth 2
      entry $f.e.e -textvariable FindByLid(lid)
      pack $f.e.e -side left -fill x -expand yes

      labelframe $f.b -text "Object Type:" -padx 2 -pady 2 -borderwidth 2
      foreach {type name} {system "System" sysport "System Port" node "Node" port "Port"} {
         radiobutton $f.b.b$type -text "$name" -variable FindByLid(type) \
            -relief flat -value $type
         pack $f.b.b$type -side top -pady 2 -anchor w
      }
      pack $f.e $f.b -side top -expand yes -fill both
      frame $f.x
      button $f.x.f -text FIND \
         -command {guiHighLightByLid $FindByLid(type) $FindByLid(lid)}
      button $f.x.c -text CLEAR -command guiClearAllMarking
      pack $f.x.f $f.x.c -side left -fill x -expand yes
      pack $f.x -side bottom -fill x -expand yes
      pack $f
      wm title .find_by_lid "IBDiagUI - Find object holding a LID"
      set FindByLid(type) system

   }
   wm deiconify .find_by_lid
}

proc FindByDR {} {
   global FindByDR G
   if {![winfo exists .find_by_dr]} {
      set t [toplevel .find_by_dr]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]

      labelframe $f.e -text "Directed Route:" -padx 2 -pady 2 -borderwidth 2
      entry $f.e.e -textvariable FindByDR(DR)
      pack $f.e.e -side left -fill x -expand yes

      labelframe $f.p -text "Start Port:" -padx 2 -pady 2 -borderwidth 2
      entry $f.p.e -textvariable FindByDR(port)
      pack $f.p.e -side left -fill x -expand yes
      pack $f.e $f.p -side top -expand yes -fill both
      frame $f.x
      button $f.x.f -text FIND \
         -command {guiHighLightByDR $FindByDR(port) $FindByDR(DR)}
      button $f.x.c -text CLEAR -command guiClearAllMarking
      pack $f.x.f $f.x.c -side left -fill x -expand yes
      pack $f.x -side bottom -fill x -expand yes
      pack $f
      wm title .find_by_dr "IBDiagUI - Find objects on a Directed Route"
      set FindByDR(port) "$G(argv:sys.name)/P$G(argv:port.num)"
   }
   wm deiconify .find_by_dr
}


proc setColor {b opt} {
   global O
   foreach {w desc val} $O($opt) {break}
   set color [tk_chooseColor -title "Choose a $desc color" -initialcolor $val]
   if {$color != ""} {
      set O($opt) [list $w $desc $color]
      $b configure -background $color
   }
}

proc getColor {col} {
   global O
   if {[info exists O(color:$col)]} {
      return [lindex $O(color:$col) 2]
   } else {
      puts "-W- could not find color $col"
      return black
   }
   setLogColors
}

# Display a form for setting fabric roots
proc SetRoots {} {
   global C gFabric
   if {![winfo exists .set_roots_opts]} {
      set t [toplevel .set_roots_opts]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
      label $f.l -text "Root systems names:"
      entry $f.e -textvariable SYSTEM_ORDER
      button $f.b -text REDRAW -command "drawFabric $gFabric $C"
      pack $f.l $f.e $f.b -side top -expand true -fill x
      pack $f
      wm title .set_roots_opts "IBDiagUI - Set Roots Options"
   }
   wm deiconify .set_roots_opts
}

# Display a form for setting colors
proc SetColorOpts {} {
   global O
   if {![winfo exists .set_color_opts]} {
      set t [toplevel .set_color_opts]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
      set prevFirstWord ""
      foreach opt [lsort [array name O color:*]] {
         foreach {w desc val} $O($opt) {break}
         set firstWord [lindex $desc 0]
         if {$firstWord != $prevFirstWord} {
            set wName [string tolower $firstWord]
            set wf [labelframe $f.$wName -text "$firstWord:" \
                       -padx 2 -pady 2 -borderwidth 2]
            pack $wf -side top -expand yes -fill x
            set prevFirstWord $firstWord
         }
         button $wf.$w -text [lrange $desc 1 end] \
            -command "setColor $wf.$w $opt" \
            -background $val
         pack $wf.$w -side left -pady 2 -anchor w -fill x
      }
      pack $f
      wm title .set_color_opts "IBDiagUI - Set Color Options"
   }
   wm deiconify .set_color_opts
}

proc SetAnnotationsFile {} {
   global O
   if {![winfo exists .load_annos]} {
      set t [toplevel .load_annos]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
      label $f.l -text "Annotation File Name"
      entry $f.e -textvariable ANNOTATION_FILE
      button $f.b -text LOAD -command LoadAnnotationsFile
      pack $f.l $f.e $f.b -side top -expand yes -fill x
      pack $f

      wm title .load_annos "IBDiagUI - Set Color Options"

      if {![info exists ANNOTATION_FILE]} {
         set ANNOTATION_FILE ""
      }
   }
   wm deiconify .load_annos
}

proc SetIBDiagFlags {} {
   global O
   if {![winfo exists .ibdiag_flags]} {
      set t [toplevel .ibdiag_flags]
      wm withdraw $t

      set f [frame $t.f -padx 2 -pady 2 -borderwidth 2]
      label $f.l -text "IBDiagNet Flags:"
      entry $f.e -textvariable IBDIAGNET_FLAGS
      pack $f.l $f.e -side top -expand yes -fill x
      pack $f

      wm title .ibdiag_flags "IBDiagUI - Set IBDiagNet Flags"
   }
   wm deiconify .ibdiag_flags
}


proc HelpAbout {} {
   catch {destroy .help_about}
   set tl [toplevel  .help_about]
   label $tl.l -text {
      IBDIAG GUI

      Version: 1.0
      Date: Sep 2006
      Author: Eitan Zahavi <eitan@mellanox.co.il>
   }
   pack $tl.l
}

##############################################################################
#
# GUI INITIALIZATION
#
##############################################################################

# save as much as possible in .ibdiagui
proc guiQuit {} {
   global PANES O
   global ANNOTATION_FILE

   if {[catch {set f [open .ibdiagui w]} ]} {
      return
   }

   puts $f "wm geometry . [wm geometry .]"
   puts $f "update"
   foreach w [array names PANES] {
      foreach idx $PANES($w) {
         set coords [$w sash coord $idx]
         puts $f "$w sash place $idx [lindex $coords 0] [lindex $coords 1]"
      }
   }

   foreach opt [array names O] {
      puts $f "set O($opt) {$O($opt)}"
   }

   puts $f "set ANNOTATION_FILE \"$ANNOTATION_FILE\""
   close $f
   exit
}

# init the menu bar
proc initMenuBar {m} {
   menubutton $m.file -text File -underline 0 -menu $m.file.menu
   menubutton $m.refresh -text Refresh -underline 0 -menu $m.refresh.menu
   menubutton $m.find -text Find -underline 0 -menu $m.find.menu
   menubutton $m.opts -text Options -underline 0 -menu $m.opts.menu

   menu $m.file.menu -tearoff no
   $m.file.menu add command -label Quit -command guiQuit

   menu $m.refresh.menu -tearoff no
   $m.refresh.menu add command -label Network -command DiagNet
   $m.refresh.menu add command -label "Enforce Annotations" \
      -command EnforceAnnotations
   $m.refresh.menu add command -label "Add Statics to VL0" \
      -command SetVL0Statics

   menu $m.find.menu -tearoff no
   $m.find.menu add command -label Name -command FindByName
   $m.find.menu add command -label GUID -command FindByGUID
   $m.find.menu add command -label LID -command FindByLID
   $m.find.menu add command -label Route -command FindByDR

   menu $m.opts.menu -tearoff no
   $m.opts.menu add command -label Colors -command SetColorOpts
   $m.opts.menu add command -label "Set Roots" -command SetRoots
   $m.opts.menu add command -label "Set Annotation File" \
      -command SetAnnotationsFile
   $m.opts.menu add command -label "Set IBDiagNet Options" \
      -command SetIBDiagFlags

   menubutton $m.help -text Help -underline 0 -menu $m.help.menu
   menu $m.help.menu -tearoff no
   $m.help.menu add command -label About -command HelpAbout

   pack $m.file $m.refresh $m.find $m.opts -side left

   pack $m.help -side right
}

#--------------------------------------------------------
#  Init the main windows and provide their ids in globals:
#  G - the graphic canvas widget id
#  P - the props frame
#  L - the LOG text widget
#--------------------------------------------------------
proc initMainFrame {f} {
   global C P L PANES

   #--------------------------------------------------------
   #  The hierarchy of widgets we build is defined below
   #  f
   #   pw1 - the main pane split vertically
   #    tf - the top frame
   #     pw2 - the second pane - this time horizontal
   #      gf - graphic frame
   #       gg - graphic grid
   #       chs - canvas horizonal scroll
   #       cvs - canvas vertical scroll
   #       c - canvas
   #      pf - props frame
   #    bf - the bottom frame
   #     tg - text grid
   #     ths - text horizonal srcolll
   #     tvs - text vertical srcolll
   #     t - text widget
   #--------------------------------------------------------

   #   pw1 - the main pane split vertically
   set pw1 [panedwindow $f.pw1 -orient vertical -showhandle yes]
   set PANES($pw1) 0

   #    tf - the top frame
   set tf [frame $pw1.tf]
   #     pw2 - the second pane - this time horizontal
   set pw2 [panedwindow $tf.pw2 -showhandle yes]
   set PANES($pw2) 0

   #      gf - graphic frame
   set gf [frame $tf.gf]
   #       gg - graphic grid
   set gg [frame $gf.g]
   #       chs - canvas horizonal scroll
   set chs [scrollbar $gf.chs -orient horiz -command "$gf.c xview"]
   #       cvs - canvas vertical scroll
   set cvs [scrollbar $gf.cvs -orient vertical -command "$gf.c yview"]
   #       c - canvas
   set c [canvas $gf.c -relief sunken -borderwidth 2 \
             -scrollregion {-11c -11c 11c 11c} \
             -xscrollcommand "$chs set" \
             -yscrollcommand "$cvs set" ]
   #      pf - props frame
   set pf [frame $tf.pf]
   #    bf - the bottom frame
   set bf [frame $pw1.bf]
   #     tg - text grid
   set tg [frame $bf.g]
   #     ths - text horizonal srcolll
   set ths [scrollbar $bf.ths -orient horiz -command "$bf.t xview"]
   #     tvs - text vertical srcolll
   set tvs [scrollbar $bf.tvs -orient vertical -command "$bf.t yview"]
   #     t - text widget
   set t [text $bf.t \
             -yscrollcommand "$tvs set" \
             -xscrollcommand "$ths set" \
             -state disabled]

   #--------------------------------------------------------
   # Packing...
   #--------------------------------------------------------

   # Graphic area
   pack $gg -expand yes -fill both -padx 1 -pady 1
   grid rowconfig    $gg 0 -weight 1 -minsize 0
   grid columnconfig $gg 0 -weight 1 -minsize 0
   grid $c -padx 1 -in $gg -pady 1 \
      -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
   grid $cvs -in $gg -padx 1 -pady 1 \
      -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
   grid $chs -in $gg -padx 1 -pady 1 \
      -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news

   # graphic / prop pane
   $pw2 add $pf
   $pw2 add $gf

   pack $pw2 -side top -expand yes -fill both -pady 2 -padx 2m
   $pw2 paneconfigure $gf -sticky news -width 10c
   $pw2 paneconfigure $pf -sticky news -minsize 4c

   # the frame holding it
   # pack $tf -side top -expand yes -fill both
   pack $tf -side top -fill both

   # log text area
   pack $tg -expand yes -fill both -padx 1 -pady 1
   grid rowconfig    $tg 0 -weight 1 -minsize 0
   grid columnconfig $tg 0 -weight 1 -minsize 0
   grid $t -padx 1 -in $tg -pady 1 \
      -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
   grid $tvs -in $tg -padx 1 -pady 1 \
      -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
   grid $ths -in $tg -padx 1 -pady 1 \
      -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news

   # the frame holding it
   #   pack $bf -side top -expand yes -fill x
   pack $bf -side top -fill x

   # the main pane window
   $pw1 add $tf $bf
   pack $pw1 -side top -expand yes -fill both -pady 2 -padx 2m
   # $pw1 paneconfigure $tf -minsize 15c
   # $pw1 paneconfigure $bf

   bind $c <3> "zoomMark $c %x %y"
   bind $c <B3-Motion> "zoomStroke $c %x %y"
   bind $c <ButtonRelease-3> "zoomArea $c %x %y"
   bind $c <KeyPress-z> "zoom $c 1.25"
   bind $c <KeyPress-Z> "zoom $c 0.8"
   bind $c <KeyPress-f> "fit $c"
   bind . <3> "zoomMark $c %x %y"
   bind . <B3-Motion> "zoomStroke $c %x %y"
   bind . <ButtonRelease-3> "zoomArea $c %x %y"
   bind . <KeyPress-z> "zoom $c 1.25"
   bind . <KeyPress-Z> "zoom $c 0.8"
   bind . <KeyPress-f> "fit $c"
   bind . <KeyPress-e> "expand $c %x %y"
   bind . <KeyPress-d> "deExpand $c %x %y"
   bind . <KeyPress-c> "guiClearAllMarking"

   set C $c
   set L $t
   set P $pf

   $L tag bind NAME  <Button-1> "LogObjSelect $L NAME %W %x %y"
   $L tag bind LID   <Button-1> "LogObjSelect $L LID  %W %x %y"
   $L tag bind GUID  <Button-1> "LogObjSelect $L GUID %W %x %y"
   $L tag bind ROUTE <Button-1> "LogObjSelect $L ROUTE %W %x %y"
}

proc setLogColors {} {
   global L
   $L tag configure errors   -foreground [getColor txtErr]
   $L tag configure warnings -foreground [getColor txtWarn]
   $L tag configure infos    -foreground [getColor txtInfo]
   $L tag configure NAME   -background   [getColor txtName]
   $L tag configure LID    -background   [getColor txtLid]
   $L tag configure GUID   -background   [getColor txtGuid]
   $L tag configure ROUTE  -background   [getColor txtRoute]
}

proc initGui {} {
   global O L S StatusLine P
   global ANNOTATION_FILE
   # . configure -background white -width 10i -height 10i

   # menu is a separate line at the top
   frame .m -relief raised -padx 2 -pady 2
   pack .m -side top -expand no -fill x -anchor nw
   initMenuBar .m

   # the  pane structure
   frame .r -relief ridge -height 10i -width 10i
   pack .r -side top -expand yes -fill both

   # status line
   frame .s
   entry .s.e -relief flat -state readonly -textvariable StatusLine
   pack .s.e -fill x -expand true -side bottom
   pack .s -side bottom -fill x
   set S .s.e

   # the main frame
   initMainFrame .r

   set O(color:txtDef)   {ld "Log Msg Default"  black}
   set O(color:txtErr)   {le "Log Msg Error"    red }
   set O(color:txtWarn)  {lw "Log Msg Warning" "#704000"}
   set O(color:txtInfo)  {li "Log Msg Info"     darkgreen }
   set O(color:txtName)  {ln "Log Tag Name"  "#909000" }
   set O(color:txtLid)   {ll "Log Tag LID"   "#fb9933" }
   set O(color:txtGuid)  {lg "Log Tag GUID"  "#906070" }
   set O(color:txtRoute) {lr "Log Tag Route" "#aa40a0"}

   set O(color:1x2.5G)    {p1x25g "Link 1x 2.5G"   "#ff0000"}
   set O(color:1x5G)      {p1x5g  "Link 1x 5G"     "#c80000"}
   set O(color:1x10G)     {p1x10g "Link 1x 10G"    "#960000"}
   set O(color:4x2.5G)    {p4x25g "Link 4x 2.5G"   "#00ff00"}
   set O(color:4x5G)      {p4x5g  "Link 4x 5G"     "#00c800"}
   set O(color:4x10G)     {p4x10g "Link 4x 10G"    "#009600"}
   set O(color:12x2.5G)   {p12x25g "Link 12x 2.5G" "#0000ff"}
   set O(color:12x5G)     {p12x5g  "Link 12x 5G"   "#00ff40"}
   set O(color:12x10G)    {p12x10g "Link 12x 10G"  "#00ff80"}

   set O(color:sys)       {sys  "Props System"      "#ff5e1b"}
   set O(color:node)      {node "Props Node"        "#00beff"}
   set O(color:port)      {port "Props Port"        "#00ff96"}
   set O(color:sysport)   {sysp "Props System Port" "#f400cc"}

   set O(color:mark)      {mark "Marking Selected"  "#f400f1"}
   set O(color:mtxt)      {mtxt "Marking Text"      "#0000ff"}

   if {[file exists .ibdiagui]} {
      source .ibdiagui
   }

   # actuall set the colors on the text tags
   setLogColors
   initPropsGui $P
   LoadAnnotationsFile
   SetStatus "Initializing ... "
}

##############################################################################
#
# Main flow
#

# we provide a way to load the results of ibdiagnet for testing
# to do this provide -D <dir name> that dir needs to have:
# ibdiagnet.stdout.log
# ibdiahnet.lst
# OPTIONAL: ibdiagnet.topo
set testModeDirIdx [lsearch $argv "-D"]
if {$testModeDirIdx >= 0} {
   set testModeDir [lindex $argv [expr $testModeDirIdx + 1]]
   if {![file exists [file join $testModeDir ibdiagnet.lst]]} {
      puts "-E- No [file join $testModeDir ibdiagnet.lst]"
      exit 1
   }
   if {![file exists [file join $testModeDir ibdiagnet.stdout.log]]} {
      puts "-E- No [file join $testModeDir ibdiagnet.stdout.log]"
      exit 1
   }
   set argv [lreplace $argv $testModeDirIdx [expr $testModeDirIdx + 1]]
} else {
   set testModeDir 0
}

set IBDIAGNET_FLAGS $argv

InitializeIBDIAG
StartIBDIAG
if {! [info exists G(argv:sys.name)]} {
   set G(argv:sys.name) [lindex [split [info hostname] .] 0]
}

# We init the Tk only after parsing the command line
# to avoid the interpretation of args by Tk.
if {[catch {package require Tk} e]} {
   puts "-E- ibdiagui depends on a Tk installation"
   puts "    Please download and install tk8.4"
   puts "    Error: $e"
   exit 1
}

if {[catch {package require Tcldot} e]} {
   puts "-E- ibdiagui depends on a Tcldot installation"
   puts "    Please download and install Graphviz"
   puts "    Error: $e"
   exit 1
}

if {[catch {initGui} e]} {
   puts "-E- $e"
   puts "    $errorInfo"
   exit
}

if {[catch {DiagNet} e]} {
   puts "-E- $e"
   puts "    $errorInfo"
}

package provide ibdiagui 1.0