1336 lines
40 KiB
Tcl
1336 lines
40 KiB
Tcl
set g_imageFileTypes {{"images" {.gif}} {"images" {.jpg}} {"images" {.png}}
|
|
{"images" {.bmp}} {"images" {.pcx}} {"images" {.tga}}
|
|
{"images" {.tif}} {"images" {.ps}} {"images" {.ppm}}
|
|
{"images" {.xbm}} {"All files" {*} }}
|
|
|
|
global execMode
|
|
if { $execMode == "interactive"} {
|
|
if { [catch { package require Img }] } {
|
|
puts "warning: Tcl/Tk Img package not found"
|
|
puts " Thumbnails and other image types (JPG, PNG, etc.) will not be supported."
|
|
puts " Please install it with:"
|
|
puts " yum install tkimg (RedHat/Fedora)"
|
|
puts " sudo apt-get install libtk-img (Debian/Ubuntu)\n"
|
|
set g_imageFileTypes {{"images" {.gif}} {"All files" {*} }}
|
|
}
|
|
}
|
|
|
|
#
|
|
# Set the global systype variable using checkOS, if it hasn't been set yet
|
|
proc setSystype { } {
|
|
global systype
|
|
if { [info exists systype] } { return } ;# global already set
|
|
set systype [lindex [checkOS] 0]
|
|
}
|
|
|
|
#
|
|
# Return a string identifying the operating system,
|
|
# and a string of verbose OS info (for user display)
|
|
proc checkOS {} {
|
|
global tk_patchLevel tk_library
|
|
set ret {}
|
|
|
|
set tcl_ver [info patchlevel]
|
|
set tcl_libpath [info library]
|
|
if { [info exists tk_patchLevel] } {
|
|
set tk_ver $tk_patchLevel
|
|
set tk_libpath $tk_library
|
|
} else {
|
|
set tk_ver 0
|
|
set tk_libpath 0
|
|
}
|
|
set os_name [exec uname]
|
|
set os_ver [exec uname -r]
|
|
|
|
set machine [exec uname -m]
|
|
set kernel [exec uname -v]
|
|
|
|
set x11 0
|
|
catch { set x11 [winfo server .c] }
|
|
|
|
set os_ident "$os_name $os_ver"
|
|
lappend ret $os_ident
|
|
|
|
set os_verbose "$os_ident on $machine\nkernel build $kernel\nTCL version $tcl_ver ($tcl_libpath)\nTk version $tk_ver ($tk_libpath)\nX11 server $x11\n"
|
|
|
|
lappend ret $os_verbose
|
|
return $ret
|
|
}
|
|
|
|
# search a .imn topology file for old statements, and upgrade them
|
|
proc upgradeOldConfig { cfg_ref } {
|
|
global execMode
|
|
# modify config directly!
|
|
upvar 1 $cfg_ref cfg
|
|
|
|
set msg "config line updated:"
|
|
|
|
# s/circle/annotation/
|
|
set match {circle circle([0-9]+) (.)(.)}
|
|
set subs {annotation a\1 \2\3 type oval\3}
|
|
set r [regsub -all $match $cfg $subs cfg]
|
|
if { $r > 0 } { puts "$msg circle -> oval annotation ($r)" }
|
|
|
|
# s/label/annotation/
|
|
set match {label lab([0-9]+) (.)(.)}
|
|
set subs {annotation a1\1 \2\3 type text\3}
|
|
set r2 [regsub -all $match $cfg $subs cfg]
|
|
if { $r2 > 0 } { puts "$msg label -> text annotation ($r2)" }
|
|
|
|
# s/size/fontsize/
|
|
set r3 0
|
|
if { $r2 > 0 } {
|
|
set match {size ([0-9]+)}
|
|
set subs {fontsize \1}
|
|
set r3 [regsub -all $match $cfg $subs cfg]
|
|
if { $r3 > 0 } { puts "$msg size -> fontsize ($r3)" }
|
|
}
|
|
|
|
# s/model quagga/model router/
|
|
set match { model quagga}
|
|
set subs { model router}
|
|
set r4 [regsub -all $match $cfg $subs cfg]
|
|
if { $r4 > 0 } { puts "$msg model quagga -> model router ($r4)" }
|
|
|
|
# s/type pc/type router\n model PC/
|
|
set match { type pc}
|
|
set subs " type router\n model PC"
|
|
set r5 [regsub -all $match $cfg $subs cfg]
|
|
if { $r5 > 0 } { puts "$msg type pc -> model pc ($r5)" }
|
|
|
|
# s/type host/type router\n model host/
|
|
set match { type host}
|
|
set subs " type router\n model host"
|
|
set r6 [regsub -all $match $cfg $subs cfg]
|
|
if { $r6 > 0 } { puts "$msg type host -> model host ($r6)" }
|
|
|
|
incr r [expr {$r2 + $r3 + $r4 + $r5 + $r6}]
|
|
#puts "$cfg"
|
|
set choice ""
|
|
if { $execMode == "interactive" && $r > 0 } {
|
|
puts "$msg $r substitutions made"
|
|
set choice [tk_messageBox -type yesno -icon question -title "CORE" \
|
|
-message "This configuration file contains old syntax, \
|
|
would you like to upgrade it to the new format?"]
|
|
}
|
|
return $choice
|
|
}
|
|
|
|
# renumber n0 if it exists
|
|
proc upgradeConfigRemoveNode0 { } {
|
|
global node_list
|
|
set i [lsearch $node_list n0]
|
|
if { $i < 0 } { return }
|
|
|
|
set new [newObjectId node]
|
|
puts "changing node n0 to $new"
|
|
global $new n0
|
|
set $new $n0
|
|
renumberNodesIfcs n0 $new
|
|
set node_list [lreplace $node_list $i $i]
|
|
lappend node_list $new
|
|
}
|
|
|
|
# update network-config blocks from old imn file configs
|
|
proc upgradeNetworkConfigToServices { } {
|
|
global node_list
|
|
|
|
# XXX this is a hack to populate zebra service values
|
|
# really, we should query for service config items...
|
|
set vals "{('/usr/local/etc/quagga', '/var/run/quagga')}"
|
|
set vals "$vals {('/usr/local/etc/quagga/Quagga.conf', 'quaggaboot.sh', '/usr/local/etc/quagga/vtysh.conf')}"
|
|
set vals "$vals 35 {('sh quaggaboot.sh zebra',)} {('killall zebra',)} {} {}"
|
|
set statvals "{} {('staticroutes.sh', )} 35 {('sh staticroutes.sh', )}"
|
|
set statvals "$statvals {} {} {}"
|
|
|
|
foreach node $node_list {
|
|
#
|
|
# build Quagga services config from network-config block
|
|
#
|
|
set ospfv2 [netconfFetchSection $node "router ospf"]
|
|
set ospfv3 [netconfFetchSection $node "router ospf6"]
|
|
set rip [netconfFetchSection $node "router rip"]
|
|
set ripng [netconfFetchSection $node "router ripng"]
|
|
set bgp [netconfFetchSection $node "router bgp"]
|
|
if { $ospfv2 != "" || $ospfv3 != "" || $rip != "" || $ripng != "" } {
|
|
set cfg ""
|
|
set services "zebra IPForward"
|
|
foreach ifc [ifcList $node] {
|
|
lappend cfg "interface $ifc"
|
|
set ifccfg [netconfFetchSection $node "interface $ifc"]
|
|
set cfg "$cfg $ifccfg"
|
|
lappend cfg "!"
|
|
}
|
|
if { $ospfv2 != "" } {
|
|
netconfClearSection $node "router ospf"
|
|
lappend cfg "router ospf"; set cfg "$cfg $ospfv2 !"
|
|
lappend services "OSPFv2"
|
|
}
|
|
if { $ospfv3 != "" } {
|
|
netconfClearSection $node "router ospf6"
|
|
lappend cfg "router ospf6"; set cfg "$cfg $ospfv3 !"
|
|
lappend services "OSPFv3"
|
|
}
|
|
if { $rip != "" } {
|
|
netconfClearSection $node "router rip"
|
|
lappend cfg "router rip"; set cfg "$cfg $rip !"
|
|
lappend services "RIP"
|
|
}
|
|
if { $ripng != "" } {
|
|
netconfClearSection $node "router ripng"
|
|
lappend cfg "router ripng"; set cfg "$cfg $ripng !"
|
|
lappend services "RIPNG"
|
|
}
|
|
if { $bgp != "" } {
|
|
netconfClearSection $node "router bgp"
|
|
# AS number is lost here
|
|
lappend cfg "router bgp"; set cfg "$cfg $bgp !"
|
|
lappend services "BGP"
|
|
}
|
|
setCustomConfig $node "service:zebra" "zebra" $vals 0
|
|
set cfgname "/usr/local/etc/quagga/Quagga.conf"
|
|
setCustomConfig $node "service:zebra:$cfgname" $cfgname $cfg 0
|
|
set cfgname "/usr/local/etc/quagga/vtysh.conf"
|
|
setCustomConfig $node "service:zebra:$cfgname" $cfgname \
|
|
"service integrated-vtysh-config" 0
|
|
setNodeServices $node $services
|
|
puts "updating Quagga services on node $node"
|
|
} ;# end quagga services
|
|
#
|
|
# convert static model to router
|
|
#
|
|
if { [getNodeModel $node] == "static" } {
|
|
setNodeModel $node "router"
|
|
setNodeServices $node "IPForward"
|
|
puts "changing model static to router on node $node"
|
|
}
|
|
#
|
|
# convert static routes to a custom service
|
|
#
|
|
if { [getStatIPv4routes $node] != "" || \
|
|
[getStatIPv6routes $node] != "" } {
|
|
set cfg {}
|
|
lappend cfg "# custom static route service generated by util.tcl"
|
|
addStaticRoutesToConfig $node cfg
|
|
setStatIPv4routes $node ""; setStatIPv6routes $node "" ;# clear old
|
|
set cfgname "staticroutes.sh"
|
|
setCustomConfig $node "service:UserDefined" "UserDefined" \
|
|
$statvals 0
|
|
setCustomConfig $node "service:UserDefined:$cfgname" $cfgname $cfg 0
|
|
set services [getNodeServices $node true]
|
|
lappend services "UserDefined"
|
|
setNodeServices $node $services
|
|
puts "adding user-defined static routing service on node $node"
|
|
} ;# end static services
|
|
}
|
|
}
|
|
|
|
# get CPU usage from /proc/stat jiffies
|
|
proc getCPUUsage { } {
|
|
global lastcpu
|
|
|
|
if { [catch {set f [open "/proc/stat" r]} ] } {
|
|
return ""; # unable to open /proc/stat
|
|
}
|
|
|
|
array set cpu {}
|
|
|
|
while { [ gets $f line ] >= 0 } {
|
|
set cpun [lindex $line 0]
|
|
set user [lindex $line 1]; set nice [lindex $line 2]
|
|
set sys [lindex $line 3]; set idle [lindex $line 4]
|
|
if { [string range $cpun 0 2] != "cpu" } { continue }
|
|
set cpu($cpun) "$user $nice $sys $idle"
|
|
}
|
|
close $f
|
|
if { ![info exists cpu(cpu)] } { return "" }
|
|
|
|
set cpuusages ""
|
|
foreach cpun [lsort -dictionary [array names cpu]] {
|
|
if { ![info exists lastcpu($cpun)] } {
|
|
set lastcpu($cpun) "0 0 0 0"
|
|
}
|
|
set lu [lindex $lastcpu($cpun) 0]; set ln [lindex $lastcpu($cpun) 1]
|
|
set ls [lindex $lastcpu($cpun) 2]; set li [lindex $lastcpu($cpun) 3]
|
|
set u [lindex $cpu($cpun) 0]; set n [lindex $cpu($cpun) 1]
|
|
set s [lindex $cpu($cpun) 2]; set i [lindex $cpu($cpun) 3]
|
|
set lastcpu($cpun) "$u $n $s $i"
|
|
|
|
set usage_time [expr {($u-$lu) + ($n-$ln) + ($s-$ls)}]
|
|
set total_time [expr {$usage_time + ($i-$li)}]
|
|
if { $total_time <= 0 } {
|
|
set cpuusage "" ;# avoid div by zero
|
|
} else {
|
|
set cpuusage [expr { 100 * $usage_time / $total_time }]
|
|
}
|
|
lappend cpuusages $cpuusage
|
|
}
|
|
return $cpuusages
|
|
}
|
|
|
|
# Node selection dialog display given message 'msg' with initial node selection
|
|
# set to the 'initsel' list, and calls the callback using the selected nodes
|
|
proc popupSelectNodes { msg initsel callback } {
|
|
global node_list
|
|
|
|
set wi .nodeselect
|
|
catch {destroy $wi}
|
|
toplevel $wi -takefocus 1
|
|
wm resizable $wi 0 0
|
|
wm title $wi "Select Nodes"
|
|
grab $wi
|
|
|
|
frame $wi.nodes -borderwidth 4
|
|
|
|
if { $msg == "" } { set msg "Select one or more nodes:" }
|
|
label $wi.nodes.label -text $msg
|
|
frame $wi.nodes.fr
|
|
listbox $wi.nodes.fr.nodelist -width 40 \
|
|
-listvariable node_list -yscrollcommand "$wi.nodes.fr.scroll set" \
|
|
-activestyle dotbox -selectmode extended
|
|
scrollbar $wi.nodes.fr.scroll -command "$wi.nodes.fr.nodelist yview"
|
|
pack $wi.nodes.fr.nodelist -fill both -expand true -side left
|
|
pack $wi.nodes.fr.scroll -fill y -expand true -side left
|
|
pack $wi.nodes.label $wi.nodes.fr -side top -padx 4 -pady 4 \
|
|
-anchor w -fill both -expand true
|
|
pack $wi.nodes -fill both -expand true -side top
|
|
|
|
frame $wi.fbot -borderwidth 4
|
|
button $wi.fbot.apply -text "OK" \
|
|
-command "selectNodesHelper $wi {$callback}"
|
|
button $wi.fbot.cancel -text "Cancel" -command "destroy $wi"
|
|
pack $wi.fbot.cancel $wi.fbot.apply -side right -padx 4 -pady 4
|
|
pack $wi.fbot -side bottom
|
|
|
|
#set n [$wi.nodes.fr.from get $i]
|
|
#itemconfigure $i -foreground blue
|
|
set idx 0
|
|
foreach node $node_list {
|
|
foreach sel $initsel {
|
|
if { $node == $sel } {
|
|
$wi.nodes.fr.nodelist selection set $idx
|
|
break
|
|
}
|
|
}
|
|
incr idx
|
|
}
|
|
}
|
|
|
|
proc selectNodesHelper { wi callback } {
|
|
set selected_indices [$wi.nodes.fr.nodelist curselection]
|
|
set selected_nodes {}
|
|
foreach idx $selected_indices {
|
|
set node [$wi.nodes.fr.nodelist get $idx]
|
|
lappend selected_nodes $node
|
|
}
|
|
destroy $wi
|
|
lappend callback $selected_nodes
|
|
eval $callback
|
|
}
|
|
|
|
# Boeing: node renumbering dialog
|
|
proc popupRenumberNodes { } {
|
|
set wi .renumbernode
|
|
catch {destroy $wi}
|
|
toplevel $wi -takefocus 1
|
|
wm transient $wi .
|
|
wm resizable $wi 0 0
|
|
wm title $wi "Renumber Nodes"
|
|
grab $wi
|
|
|
|
frame $wi.nodes -borderwidth 4
|
|
|
|
frame $wi.nodes.left
|
|
label $wi.nodes.left.label -text "Change this node:"
|
|
frame $wi.nodes.left.fr
|
|
listbox $wi.nodes.left.fr.from -selectmode single -width 20 \
|
|
-listvariable node_list -yscrollcommand "$wi.nodes.left.fr.scroll set" \
|
|
-activestyle dotbox
|
|
scrollbar $wi.nodes.left.fr.scroll -command "$wi.nodes.left.fr.from yview"
|
|
pack $wi.nodes.left.fr.from $wi.nodes.left.fr.scroll -fill y -side left
|
|
pack $wi.nodes.left.label $wi.nodes.left.fr -side top -padx 4 -pady 4 \
|
|
-anchor w
|
|
pack $wi.nodes.left -side left
|
|
bind $wi.nodes.left.fr.from <<ListboxSelect>> "selectRenumberNodes $wi from"
|
|
|
|
frame $wi.nodes.right
|
|
label $wi.nodes.right.label -text "to this node:"
|
|
frame $wi.nodes.right.fr
|
|
listbox $wi.nodes.right.fr.to -selectmode single -width 20 \
|
|
-listvariable node_list -yscrollcommand "$wi.nodes.right.fr.scroll set"
|
|
scrollbar $wi.nodes.right.fr.scroll -command "$wi.nodes.right.fr.to yview"
|
|
pack $wi.nodes.right.fr.to $wi.nodes.right.fr.scroll -fill y -side left
|
|
pack $wi.nodes.right.label $wi.nodes.right.fr -side top -padx 4 -pady 4 \
|
|
-anchor w
|
|
pack $wi.nodes.right -side left
|
|
bind $wi.nodes.right.fr.to <<ListboxSelect>> "selectRenumberNodes $wi to"
|
|
|
|
pack $wi.nodes -side top
|
|
|
|
frame $wi.fbot -borderwidth 4
|
|
button $wi.fbot.apply -text "Renumber Node" -command "renumberNodes $wi" \
|
|
-state disabled
|
|
button $wi.fbot.cancel -text "Close" -command "destroy $wi"
|
|
pack $wi.fbot.cancel $wi.fbot.apply -side right -padx 4 -pady 4
|
|
pack $wi.fbot -side bottom
|
|
|
|
#set n [$wi.nodes.left.fr.from get $i]
|
|
#itemconfigure $i -foreground blue
|
|
}
|
|
|
|
# helper for highlighting nodes in the node renumbering list boxes
|
|
proc selectRenumberNodes { wi l } {
|
|
global renumber_node_from renumber_node_to; # may be undefined
|
|
if { $l == "to" } {
|
|
set nlist $wi.nodes.right.fr.to
|
|
set other "from"
|
|
} else {
|
|
set nlist $wi.nodes.left.fr.from
|
|
set other "to"
|
|
}
|
|
if { [info exists renumber_node_$other] } { ;# do we have two selections?
|
|
$wi.fbot.apply configure -state normal
|
|
}
|
|
set sel [$nlist curselection]
|
|
if { [info exists renumber_node_${l}] } {; # color prev selected item black
|
|
$nlist itemconfigure [set renumber_node_${l}] -foreground black
|
|
}
|
|
$nlist itemconfigure $sel -foreground blue; # highlight curr selection blue
|
|
set renumber_node_${l} $sel; # this value is used by the apply button
|
|
}
|
|
|
|
# perform node renumbering, e.g. n1 becomes n3 and n3 is now n1
|
|
proc renumberNodes { wi } {
|
|
global renumber_node_from renumber_node_to
|
|
set from_idx $renumber_node_from
|
|
set to_idx $renumber_node_to
|
|
|
|
if { $from_idx < 0 || $to_idx < 0 } { return }
|
|
set from [$wi.nodes.left.fr.from get $from_idx]
|
|
set to [$wi.nodes.right.fr.to get $to_idx]
|
|
set from_name [getNodeName $from]
|
|
set to_name [getNodeName $to]
|
|
|
|
set tmp [newObjectId node]
|
|
|
|
global $to $from $tmp
|
|
set $tmp [set $to]
|
|
renumberNodesIfcs $to $tmp
|
|
renumberNodesIfcs $from $to
|
|
set $to [set $from]
|
|
set $from [set $tmp]
|
|
renumberNodesIfcs $tmp $from
|
|
setNodeName $from $from_name
|
|
setNodeName $to $to_name
|
|
redrawAll
|
|
destroy $wi
|
|
}
|
|
|
|
# helper to change interface-peers and links from one node to another
|
|
proc renumberNodesIfcs { from to } {
|
|
foreach ifc [ifcList $from] {
|
|
set peer [peerByIfc $from $ifc]
|
|
set peerifc [ifcByPeer $peer $from]
|
|
set link [linkByPeers $from $peer]
|
|
global $peer $link
|
|
# modify the peer to point to the new node
|
|
set i [lsearch [set $peer] "interface-peer {$peerifc $from}"]
|
|
set $peer [lreplace [set $peer] $i $i "interface-peer {$peerifc $to}"]
|
|
# update the link variable with the new node
|
|
if { [lindex [linkPeers $link] 0] == $from } {
|
|
set newnodes "nodes {$to $peer}"
|
|
} else {
|
|
set newnodes "nodes {$peer $to}"
|
|
}
|
|
set $link [lreplace [set $link] 0 0 $newnodes]
|
|
}
|
|
}
|
|
|
|
proc addAddressesToConfig { node cfg_ref } {
|
|
global $node systype
|
|
|
|
upvar 1 $cfg_ref cfg
|
|
|
|
foreach ifc [ifcList $node] {
|
|
set addr [getIfcIPv4addr $node $ifc]
|
|
set addr6 [getIfcIPv6addr $node $ifc]
|
|
if {[lindex $systype 0] == "Linux" } { ;# Linux
|
|
if { $addr != "" } {
|
|
lappend cfg "/usr/local/sbin/addip.sh $ifc $addr"
|
|
}
|
|
if { $addr6 != "" } {
|
|
lappend cfg "/usr/local/sbin/addip.sh $ifc $addr6"
|
|
}
|
|
} else {
|
|
if { $addr != "" } {
|
|
lappend cfg "ifconfig $ifc inet $addr"
|
|
}
|
|
if { $addr6 != "" } {
|
|
lappend cfg "ifconfig $ifc inet6 $addr6"
|
|
}
|
|
}
|
|
}
|
|
|
|
}
|
|
|
|
# support for legacy static routing config
|
|
# called by upgradeNetworkConfigToServices
|
|
proc addStaticRoutesToConfig { node cfg_ref } {
|
|
global $node systype
|
|
|
|
upvar 1 $cfg_ref cfg
|
|
|
|
foreach statrte [getStatIPv4routes $node] {
|
|
set net [lindex [split $statrte] 0]
|
|
set gw [lindex [split $statrte] 1]
|
|
lappend cfg "/sbin/ip -4 route add $net via $gw"
|
|
}
|
|
|
|
foreach statrte [getStatIPv6routes $node] {
|
|
set net [lindex [split $statrte] 0]
|
|
set gw [lindex [split $statrte] 1]
|
|
if { $net == "::/0" } { set net "default" }
|
|
lappend cfg "/sbin/ip -6 route add $net via $gw"
|
|
}
|
|
|
|
}
|
|
|
|
proc getServiceStartString { } {
|
|
global systype
|
|
|
|
setSystype
|
|
|
|
return "/etc/init.d/core-daemon start"
|
|
}
|
|
|
|
proc popupBuildHostsFile { } {
|
|
global node_list
|
|
set wi .buildhostsdialog
|
|
|
|
catch {destroy $wi}
|
|
|
|
toplevel $wi
|
|
wm transient $wi .
|
|
wm resizable $wi 1 1
|
|
wm title $wi "Build hosts File"
|
|
|
|
# help text at top
|
|
frame $wi.top
|
|
set helptext "The entries below can be added to your /etc/hosts file.\n"
|
|
set helptext "$helptext Use the append button to write it now."
|
|
label $wi.top.help -text $helptext
|
|
pack $wi.top.help -side top -fill both -expand true
|
|
pack $wi.top -padx 4 -pady 4 -side top
|
|
|
|
# text box
|
|
frame $wi.mid
|
|
text $wi.mid.hosts -relief sunken -bd 2 \
|
|
-yscrollcommand "$wi.mid.scroll set" -setgrid 1 -height 30 -undo 1 \
|
|
-autosep 1 -background white
|
|
scrollbar $wi.mid.scroll -command "$wi.mid.hosts yview"
|
|
pack $wi.mid.hosts -side left -fill both -expand true
|
|
pack $wi.mid.scroll -side right -fill y
|
|
pack $wi.mid -side top -fill both -expand true
|
|
|
|
$wi.mid.hosts insert end "### begin CORE auto-generated hosts entries\n"
|
|
foreach node $node_list {
|
|
set hostname [getNodeName $node]
|
|
foreach ifc [ifcList $node] {
|
|
foreach addr [getIfcIPv4addr $node $ifc] {
|
|
set ip [lindex [split $addr /] 0]
|
|
$wi.mid.hosts insert end "$ip $hostname\n"
|
|
}
|
|
}
|
|
}
|
|
$wi.mid.hosts insert end "### end CORE auto-generated hosts entries\n"
|
|
|
|
# file selection
|
|
frame $wi.fil
|
|
entry $wi.fil.filename -width 30 -bg white
|
|
button $wi.fil.filebtn -text "..." -command {
|
|
set wi .buildhostsdialog
|
|
set f [$wi.fil.filename get]
|
|
set f [tk_getSaveFile -initialfile $f]
|
|
if { $f != "" } {
|
|
$wi.fil.filename delete 0 end
|
|
$wi.fil.filename insert 0 $f
|
|
}
|
|
}
|
|
pack $wi.fil.filename -expand true -fill x -side left
|
|
pack $wi.fil.filebtn -side left
|
|
pack $wi.fil -side top
|
|
$wi.fil.filename insert 0 "/etc/hosts"
|
|
|
|
# buttons on the bottom
|
|
frame $wi.btm
|
|
button $wi.btm.apply -text "Append file" -command {
|
|
set wi .buildhostsdialog
|
|
set hosts [string trim [$wi.mid.hosts get 0.0 end]]
|
|
set filename [$wi.fil.filename get]
|
|
set fileId [open $filename a]
|
|
puts $fileId $hosts
|
|
close $fileId
|
|
destroy $wi
|
|
}
|
|
button $wi.btm.cancel -text "Close" -command "destroy $wi"
|
|
pack $wi.btm.apply $wi.btm.cancel -side left
|
|
pack $wi.btm
|
|
|
|
focus $wi.mid.hosts
|
|
}
|
|
|
|
proc popupAddressConfig { } {
|
|
global plugin_img_add plugin_img_del g_prefs
|
|
set wi .addrconfig
|
|
|
|
catch {destroy $wi}
|
|
|
|
toplevel $wi
|
|
wm transient $wi .
|
|
wm resizable $wi 1 1
|
|
wm title $wi "IP Addresses"
|
|
|
|
# help text at top
|
|
frame $wi.top
|
|
set helptext "New interfaces are automatically assigned IP addresses from\n"
|
|
set helptext "$helptext the range selected below."
|
|
label $wi.top.help -text $helptext
|
|
pack $wi.top.help -side top -fill both -expand true
|
|
pack $wi.top -padx 4 -pady 4 -side top
|
|
|
|
frame $wi.f
|
|
foreach fam [list "IPv4" "IPv6"] {
|
|
set faml [string tolower $fam]
|
|
set f $wi.f.$faml
|
|
labelframe $f -text "$fam"
|
|
# list of address prefixes
|
|
frame $f.l
|
|
listbox $f.l.list -bg white -yscrollcommand "$f.l.scroll set" \
|
|
-exportselection 0
|
|
scrollbar $f.l.scroll -command "$f.l.list yview" -bd 1 -width 10
|
|
pack $f.l.list $f.l.scroll -side left -fill y -expand true
|
|
pack $f.l -side top -fill y -expand true
|
|
# controls for editing list
|
|
frame $f.edit
|
|
entry $f.edit.addr -bg white -width 20
|
|
button $f.edit.new -image $plugin_img_add \
|
|
-command "addressConfigHelper $wi $fam add"
|
|
button $f.edit.del -image $plugin_img_del \
|
|
-command "addressConfigHelper $wi $fam del"
|
|
pack $f.edit.addr $f.edit.new $f.edit.del -side left
|
|
pack $f.edit -side top
|
|
|
|
frame $f.butt
|
|
label $f.butt.l -text "Remove $fam:"
|
|
button $f.butt.delall -text "all" -command "delAddrs all $fam"
|
|
button $f.butt.delsel -text "selected" -command "delAddrs sel $fam"
|
|
pack $f.butt.l $f.butt.delall $f.butt.delsel -side left
|
|
pack $f.butt -side top
|
|
|
|
pack $f -side left
|
|
|
|
# populate list and select appropriate entry
|
|
if {![info exists g_prefs(gui_${faml}_addr)]} { setDefaultAddrs $faml }
|
|
set idx -1; set i 0
|
|
foreach addr $g_prefs(gui_${faml}_addrs) {
|
|
$f.l.list insert end $addr
|
|
if { $addr == $g_prefs(gui_${faml}_addr) } { set idx $i }
|
|
incr i
|
|
}
|
|
if { $idx < 0 } {
|
|
$f.l.list insert end $g_prefs(gui_${faml}_addr)
|
|
$f.l.list selection set end
|
|
} else {
|
|
$f.l.list selection set $idx
|
|
}
|
|
} ;# end foreach fam
|
|
pack $wi.f -side top
|
|
|
|
# buttons on the bottom
|
|
frame $wi.btm
|
|
button $wi.btm.apply -text "OK" \
|
|
-command "addressConfigHelper $wi \"\" apply"
|
|
button $wi.btm.def -text "Defaults" \
|
|
-command "setDefaultAddrs ipv4; setDefaultAddrs ipv6; destroy $wi; popupAddressConfig"
|
|
button $wi.btm.cancel -text "Cancel" -command "destroy $wi"
|
|
pack $wi.btm.apply $wi.btm.def $wi.btm.cancel -side left
|
|
pack $wi.btm
|
|
|
|
#focus $wi.mid.hosts
|
|
}
|
|
|
|
# listbox helper for adding and removing entries, and applying them
|
|
proc addressConfigHelper { wi fam cmd } {
|
|
global g_prefs
|
|
|
|
set f $wi.f.[string tolower $fam]
|
|
switch -exact -- $cmd {
|
|
add {
|
|
set addr [$f.edit.addr get]
|
|
$f.l.list insert end $addr
|
|
}
|
|
del {
|
|
set i [$f.l.list curselection]
|
|
if { $i == "" } { return }
|
|
$f.l.list delete $i
|
|
}
|
|
apply {
|
|
foreach fam [list "ipv4" "ipv6"] {
|
|
set f $wi.f.$fam
|
|
set i [$f.l.list curselection]
|
|
if { $i == "" } { set i 0 }
|
|
set addr [$f.l.list get $i]
|
|
set addrs [$f.l.list get 0 end]
|
|
array set g_prefs [list gui_${fam}_addr $addr]
|
|
array set g_prefs [list gui_${fam}_addrs $addrs]
|
|
}
|
|
destroy $wi
|
|
}
|
|
}
|
|
}
|
|
|
|
# set the default addresses for automatic allocation in the g_prefs array
|
|
# for the given address family
|
|
proc setDefaultAddrs { fam } {
|
|
global g_prefs
|
|
if { $fam == "ipv4" } {
|
|
set addrs [getDefaultIPv4Addrs]
|
|
} elseif { $fam == "ipv6" } {
|
|
set addrs [getDefaultIPv6Addrs]
|
|
} else {
|
|
return
|
|
}
|
|
array set g_prefs [list gui_${fam}_addr [lindex $addrs 0]]
|
|
array set g_prefs [list gui_${fam}_addrs $addrs]
|
|
}
|
|
|
|
proc popupMacAddressConfig { } {
|
|
set wi .macaddrconfig
|
|
global mac_addr_start
|
|
|
|
catch {destroy $wi}
|
|
|
|
toplevel $wi
|
|
wm transient $wi .
|
|
wm resizable $wi 1 1
|
|
wm title $wi "MAC Addresses"
|
|
|
|
# help text at top
|
|
frame $wi.top
|
|
set helptext "MAC addresses are automatically assigned starting with\n"
|
|
set helptext "$helptext 00:00:00:aa:00:nn, where nn starts with the below"
|
|
set helptext "$helptext value.\n You should change this value when tunneling"
|
|
set helptext "$helptext between \nemulations to prevent MAC address conflicts."
|
|
|
|
label $wi.top.help -text $helptext
|
|
pack $wi.top.help -side top -fill both -expand true
|
|
pack $wi.top -padx 4 -pady 4 -side top
|
|
|
|
if { ![info exists mac_addr_start] } { set mac_addr_start 0 }
|
|
frame $wi.f
|
|
label $wi.f.maclab -text "Starting MAC number:"
|
|
entry $wi.f.mac -width 5 -bg white -textvariable mac_addr_start
|
|
pack $wi.f.maclab $wi.f.mac $wi.f -side left
|
|
pack $wi.f -side top
|
|
|
|
frame $wi.btm
|
|
button $wi.btm.apply -text "close" -command "destroy $wi"
|
|
pack $wi.btm.apply -side left
|
|
pack $wi.btm
|
|
|
|
}
|
|
|
|
#
|
|
# Capture a window into an image
|
|
# Author: David Easton
|
|
#
|
|
proc captureWindow { win } {
|
|
|
|
|
|
regexp {([0-9]*)x([0-9]*)\+([0-9]*)\+([0-9]*)} [winfo geometry $win] - w h x y
|
|
|
|
# Make the base image based on the window
|
|
set image [image create photo -format window -data $win]
|
|
|
|
foreach child [winfo children $win] {
|
|
captureWindowSub $child $image 0 0
|
|
}
|
|
|
|
return $image
|
|
}
|
|
|
|
proc captureWindowSub { win image px py } {
|
|
|
|
if {![winfo ismapped $win]} {
|
|
return
|
|
}
|
|
|
|
regexp {([0-9]*)x([0-9]*)\+([0-9]*)\+([0-9]*)} [winfo geometry $win] - w h x y
|
|
|
|
incr px $x
|
|
incr py $y
|
|
|
|
# Make an image from this widget
|
|
set tempImage [image create photo -format window -data $win]
|
|
|
|
# Copy this image into place on the main image
|
|
$image copy $tempImage -to $px $py
|
|
image delete $tempImage
|
|
|
|
foreach child [winfo children $win] {
|
|
captureWindowSub $child $image $px $py
|
|
}
|
|
}
|
|
|
|
proc writeCanvasThumbnail { c fn } {
|
|
global execMode
|
|
set r false
|
|
if [ catch {
|
|
set img [captureWindow $c]
|
|
set imgthumb [image create photo]
|
|
# resize image to height 100
|
|
set w [image height $img]
|
|
$imgthumb copy $img -subsample [expr { int($w / 100)} ]
|
|
$imgthumb write $fn -format jpeg
|
|
image delete $img
|
|
image delete $imgthumb
|
|
set r true
|
|
} e ] {
|
|
if { $execMode == "interactive" } {
|
|
puts "warning: failed to create canvas thumbnail"
|
|
}
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# contributed code from CL from http://wiki.tcl.tk/557 fetched 6/11/10
|
|
proc _launchBrowser url {
|
|
global tcl_platform
|
|
|
|
# It *is* generally a mistake to switch on $tcl_platform(os), particularly
|
|
# in comparison to $tcl_platform(platform). For now, let's just regard it
|
|
# as a stylistic variation subject to debate.
|
|
switch $tcl_platform(os) {
|
|
Darwin {
|
|
set command [list open $url]
|
|
}
|
|
HP-UX -
|
|
Linux -
|
|
SunOS {
|
|
foreach executable {firefox mozilla netscape iexplorer opera lynx
|
|
w3m links epiphany galeon konqueror mosaic amaya
|
|
browsex elinks} {
|
|
set executable [auto_execok $executable]
|
|
if [string length $executable] {
|
|
# Do you want to mess with -remote? How about other browsers?
|
|
set command [list $executable $url &]
|
|
break
|
|
}
|
|
}
|
|
}
|
|
{Windows 95} -
|
|
{Windows NT} {
|
|
set command "[auto_execok start] {} [list $url]"
|
|
}
|
|
}
|
|
if [info exists command] {
|
|
if [catch {eval exec $command } err] {
|
|
tk_messageBox -icon error -message "error '$err' with '$command'"
|
|
}
|
|
} else {
|
|
tk_messageBox -icon error -message \
|
|
"Please tell CL that ($tcl_platform(os), $tcl_platform(platform)) is not yet ready for browsing."
|
|
}
|
|
}
|
|
|
|
# helper for registering a callback with a tk_optionMenu variable, when a user
|
|
# clicks on the menu and changes the value; if the global variable var is
|
|
# cleared, this callback is cancelled
|
|
# NOTE: when closing the window that calls this, ensure that var is cleared
|
|
proc tkOptionMenuCallback { ctl var cb args } {
|
|
if { ![winfo exists $ctl] } { return }
|
|
global $var
|
|
tkwait variable $var
|
|
# cancel callback when var is cleared
|
|
if { [set $var] == "" } { return }
|
|
# here is a hack to remove the outer list
|
|
if {[llength $args] == 1} { set args [lindex $args 0] }
|
|
$cb [set $var] $args
|
|
|
|
tkOptionMenuCallback $ctl $var $cb $args
|
|
}
|
|
|
|
# split a string on commas, while respecting single quote "'" quoting
|
|
# items should be in single quotes which are omitted from the resulting list
|
|
# e.g. 'foo', 'ba\'r', 'baz' ==> {foo, ba'r, baz}
|
|
proc safeCommaSplit { str } {
|
|
set item ""
|
|
set r []
|
|
set inquotes false
|
|
for {set i 0} {$i < [string length $str]} {incr i} {
|
|
set c [string index $str $i]
|
|
if { $c == "'" } {
|
|
# check for escaped quote and skip it
|
|
if { $i > 0 && [string index $str [expr $i-1]] == "\\" } {
|
|
set item "$item$c"
|
|
continue
|
|
}
|
|
if { !$inquotes } {
|
|
set inquotes true ;# begin quoted block
|
|
} else {
|
|
set inquotes false ;# end quoted block
|
|
}
|
|
continue
|
|
}
|
|
if { $c == "," && !$inquotes } { ;# comma outside quoted block
|
|
lappend r $item
|
|
set item ""
|
|
continue
|
|
}
|
|
set item "$item$c"
|
|
}
|
|
if { $item != "" } { lappend r $item } ;# last item in list
|
|
return $r
|
|
}
|
|
|
|
# convert a string in the Python tuple format into a TCL list
|
|
proc tupleStringToList { str } {
|
|
set str [string trim $str] ;# remove whitespace
|
|
set str [string trim $str "()"] ;# remove (...)
|
|
set quotedlist [safeCommaSplit $str] ;# [split $str ","] doesn't work here
|
|
set r ""
|
|
foreach item $quotedlist {
|
|
set item [string trim $item] ;# remove whitespace
|
|
# un-escape double and single quotes
|
|
set item [string map {\\\" \"} $item]
|
|
set item [string map {\\' '} $item]
|
|
if { $item != "" } { lappend r $item }
|
|
}
|
|
return $r
|
|
}
|
|
|
|
# convert a TCL list to the Python tuple format
|
|
proc listToTupleString { l } {
|
|
if { [llength $l] == 0 } { return {} } ;# don't return empty tuples "()"
|
|
set str "("
|
|
foreach item $l {
|
|
# escape double and single quotes
|
|
set item [string map {\" \\\"} $item]
|
|
set item [string map {' \\'} $item]
|
|
# enclose each item in single quotes
|
|
set str "$str'$item', "
|
|
}
|
|
set str "$str)"
|
|
return $str
|
|
}
|
|
|
|
proc exportPython { } {
|
|
global node_list link_list
|
|
|
|
foreach n $node_list {
|
|
set name [getNodeName $n]
|
|
set xy [getNodeCoords $n]
|
|
puts " $name = session.addobj(cls = pycore.nodes.class, name=\"$name\")"
|
|
puts " $name.setposition(x=[lindex $xy 0],y=[lindex $xy 1])"
|
|
}
|
|
|
|
foreach l $link_list {
|
|
set lnode1 [lindex [linkPeers $l] 0]
|
|
set lnode2 [lindex [linkPeers $l] 1]
|
|
set ifc1 [ifcByPeer $lnode1 $lnode2]
|
|
set ifc2 [ifcByPeer $lnode2 $lnode1]
|
|
set net "ptpnet"
|
|
if { [[typemodel $lnode1].layer] == "LINK" } {
|
|
set net [getNodeName $lnode1]
|
|
}
|
|
if { [[typemodel $lnode2].layer] == "LINK" } {
|
|
set net [getNodeName $lnode2]
|
|
}
|
|
if { [[typemodel $lnode1].layer] == "NETWORK" } {
|
|
set ipv4 [getIfcIPv4addr $lnode1 $ifc1]
|
|
set if1n [ifcNameToNum $ifc1]
|
|
puts -nonewline " [getNodeName $lnode1].newnetif(net=$net, "
|
|
puts "addrlist=\[\"$ipv4\"\], ifindex=$if1n)"
|
|
}
|
|
if { [[typemodel $lnode2].layer] == "NETWORK" } {
|
|
set ipv4 [getIfcIPv4addr $lnode2 $ifc2]
|
|
set if2n [ifcNameToNum $ifc2]
|
|
puts -nonewline " [getNodeName $lnode2].newnetif(net=$net, "
|
|
puts "addrlist=\[\"$ipv4\"\], ifindex=$if2n)"
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
proc execPythonFile { filename } {
|
|
set flags 0x10 ;# status request flag
|
|
sendRegMessage -1 $flags [list "exec" $filename]
|
|
addFileToMrulist $filename
|
|
|
|
tk_messageBox -type ok -message "Executed Python script '$filename'"
|
|
}
|
|
|
|
# ask the daemon to execute the selected file
|
|
proc execPython { with_options } {
|
|
global fileDialogBox_initial g_prefs
|
|
set ft {{ "CORE XML or Python scripts" {.py .xml} } { "All files" {*}}}
|
|
|
|
if { $fileDialogBox_initial == 0 } {
|
|
set fileDialogBox_initial 1
|
|
set dir $g_prefs(default_conf_path)
|
|
set fn [tk_getOpenFile -filetypes $ft -initialdir $dir]
|
|
} else {
|
|
set fn [tk_getOpenFile -filetypes $ft]
|
|
}
|
|
if { $fn == "" } { return }
|
|
if { $with_options } {
|
|
set prompt "Append any command-line options for running the Python"
|
|
set prompt "$prompt script:"
|
|
set fn [tk_inputBox "Python Script Options" $prompt $fn . 50]
|
|
if { $fn == "" } { return }
|
|
}
|
|
|
|
execPythonFile $fn
|
|
}
|
|
|
|
# open a dialog that prompts the user with a text entry
|
|
# this is a blocking dialog that returns "" for cancel, or the entry text for OK
|
|
proc tk_inputBox { title prompt default_text parent width} {
|
|
set w .input_box
|
|
catch {destroy $w}
|
|
toplevel $w
|
|
|
|
global g_input_box_btn_state
|
|
set g_input_box_btn_state 0
|
|
global g_input_box_text
|
|
set g_input_box_text $default_text
|
|
|
|
wm title $w $title
|
|
wm transient $w $parent
|
|
wm attributes $w -type dialog
|
|
|
|
ttk::frame $w.f
|
|
ttk::label $w.f.top -text $prompt
|
|
ttk::entry $w.f.ent -width $width -textvariable g_input_box_text
|
|
pack $w.f.top $w.f.ent -side top -padx 4 -pady 4
|
|
pack $w.f -side top
|
|
|
|
ttk::frame $w.btn
|
|
ttk::button $w.btn.ok -text "OK" -command {
|
|
global g_input_box_btn_state
|
|
set g_input_box_btn_state 1
|
|
}
|
|
ttk::button $w.btn.cancel -text "Cancel" -command {
|
|
global g_input_box_text
|
|
global g_input_box_btn_state
|
|
set g_input_box_text ""
|
|
set g_input_box_btn_state 2
|
|
}
|
|
pack $w.btn.ok $w.btn.cancel -side left -padx 4 -pady 4
|
|
pack $w.btn -side top
|
|
|
|
vwait g_input_box_btn_state
|
|
destroy $w
|
|
return $g_input_box_text
|
|
}
|
|
|
|
# from Practical Programming in Tcl and Tk, page 190
|
|
proc Call_Trace {{file stdout}} {
|
|
puts $file "*** Tcl Call Trace:"
|
|
for {set x [expr [info level]-1]} {$x > 0} {incr x -1} {
|
|
puts $file " $x: [info level $x]"
|
|
}
|
|
}
|
|
|
|
# toggle a boolean variable
|
|
proc toggle { v } {
|
|
upvar 1 $v var
|
|
set var [expr {!$var}]
|
|
}
|
|
|
|
# return the name of the text editor to use
|
|
# - the preference g_prefs(gui_text_editor) overrides any default
|
|
# - if want_default is specified, first return EDITOR environment variable,
|
|
# then find the first in the list of editors that exists on the system
|
|
set EDITORS "vim emacs gedit nano vi"
|
|
proc get_text_editor { want_default } {
|
|
global g_prefs env EDITORS
|
|
set ed ""
|
|
if { [info exists env(EDITOR)] } {
|
|
set ed $env(EDITOR)
|
|
}
|
|
if { !$want_default && [info exists g_prefs(gui_text_editor)] } {
|
|
set edpref $g_prefs(gui_text_editor)
|
|
# preference can be EDITOR, to use environment variable EDITOR
|
|
if { $edpref == "EDITOR" } {
|
|
set edpref $ed
|
|
}
|
|
if { $edpref != "" } {
|
|
return $edpref
|
|
}
|
|
# fall through since environment variable or pref not set
|
|
}
|
|
|
|
# first use any EDITOR variable
|
|
if { $ed != "" } {
|
|
if { $want_default } {
|
|
return "EDITOR"
|
|
} else {
|
|
return $ed
|
|
}
|
|
}
|
|
# return the first installed editor from EDITORS global
|
|
foreach ed $EDITORS {
|
|
if { [auto_execok $ed] != "" } {
|
|
return $ed
|
|
}
|
|
}
|
|
# none of the editors were found, just return the first one
|
|
return [lindex $EDITORS 0]
|
|
}
|
|
|
|
# return the name of the terminal program to use
|
|
# - the preference g_prefs(gui_term_prog) overrides any default
|
|
# - if want_default is specified, first return COLORTERM or TERM environment
|
|
# variable, then find the first in the list of terminals that exists on the
|
|
# system
|
|
set TERMS "{gnome-terminal --window --} {lxterminal -e} {konsole -e} {xterm -e}"
|
|
set TERMS "$TERMS {aterm -e} {eterm -e} {rxvt -e} {xfce4-terminal -x}"
|
|
|
|
proc get_term_prog { want_default } {
|
|
global g_prefs env TERMS
|
|
# initialize term = COLORTERM or TERM environment variables
|
|
set term ""
|
|
if { [info exists env(COLORTERM)] } {
|
|
if { ![string is integer $env(COLORTERM) ] } {
|
|
# under OpenSUSE, COLORTERM=1
|
|
set term [auto_execok $env(COLORTERM)]
|
|
}
|
|
}
|
|
if { $term == "" && [info exists env(TERM)] } {
|
|
set term [auto_execok $env(TERM)]
|
|
}
|
|
if { $term != "" } {
|
|
set arg "-e"
|
|
# gnome-terminal and xfce4-terminal have problems w/subsequent
|
|
# arguments after -e, needs -x
|
|
set basename [file tail $term]
|
|
if {[lsearch -exact \
|
|
{"gnome-terminal" "xfce4-terminal"} $basename] >= 0} {
|
|
set arg "-x"
|
|
}
|
|
set term "$term $arg"
|
|
}
|
|
|
|
if { !$want_default && [info exists g_prefs(gui_term_prog)] } {
|
|
set termpref $g_prefs(gui_term_prog)
|
|
# preference can be TERM, to adopt environment variable TERM
|
|
if { $termpref == "TERM" } {
|
|
set termpref $term
|
|
}
|
|
if { $termpref != "" } {
|
|
return $termpref ;# pre-configured preference or expanded TERM
|
|
}
|
|
# fall through since environment variable or preference not set
|
|
}
|
|
|
|
# first use any TERM variable
|
|
if { $term != "" } {
|
|
if { $want_default } {
|
|
return "TERM"
|
|
} else {
|
|
return $term
|
|
}
|
|
}
|
|
# return the first installed terminal from TERMS global
|
|
foreach term $TERMS {
|
|
if { [auto_execok [lindex $term 0]] != "" } {
|
|
return $term
|
|
}
|
|
}
|
|
# none of the terminals were found, just return the first one
|
|
return [lindex $TERMS 0]
|
|
}
|
|
|
|
# short session ID used by Python daemon for interface names
|
|
proc shortSessionID { sid } {
|
|
set ssid [ expr { ($sid >> 8) ^ ($sid & ((1<<8) - 1)) } ]
|
|
return [format "%x" $ssid]
|
|
}
|
|
|
|
|
|
proc delAddrs { mode fam } {
|
|
global node_list
|
|
if { $mode == "all" } {
|
|
delAddrsFromNodes $fam $node_list
|
|
} else {
|
|
set msg "Remove all $fam addresses from these nodes:"
|
|
popupSelectNodes $msg "" "delAddrsFromNodes $fam"
|
|
}
|
|
}
|
|
|
|
proc delAddrsFromNodes { fam nodes } {
|
|
foreach node $nodes {
|
|
foreach ifc [ifcList $node] {
|
|
if { $fam == "IPv4" } {
|
|
setIfcIPv4addr $node $ifc ""
|
|
} elseif { $fam == "IPv6" } {
|
|
setIfcIPv6addr $node $ifc ""
|
|
}
|
|
}
|
|
}
|
|
redrawAll
|
|
}
|
|
|
|
# fix for Tcl/Tk 8.5.8 and lower which doesn't have ttk::spinbox
|
|
# set spinbox [getspinbox]
|
|
# $spinbox $var -justify right -width 10 ...
|
|
#
|
|
proc getspinbox {} {
|
|
if { [info command ttk::spinbox] == "" } {
|
|
return spinbox
|
|
} else {
|
|
return ttk::spinbox
|
|
}
|
|
}
|
|
|
|
# find dialog for searching for nodes and links
|
|
proc popupFind {} {
|
|
set msg "find"
|
|
set initsel ""
|
|
set callback ""
|
|
global node_list
|
|
|
|
set w .find
|
|
catch {destroy $w}
|
|
toplevel $w -takefocus 1
|
|
wm transient $w .
|
|
wm title $w "Find"
|
|
|
|
ttk::frame $w.find -borderwidth 4
|
|
ttk::label $w.find.lab -text "Find:"
|
|
ttk::entry $w.find.text -width 40
|
|
pack $w.find.lab -side left
|
|
pack $w.find.text -side left -fill x -expand 1
|
|
pack $w.find -fill x -side top -padx 4 -pady 4
|
|
bind $w.find.text <Key-Return> "findButton $w"
|
|
|
|
ttk::frame $w.mid
|
|
ttk::treeview $w.mid.tree -columns {number name location details} \
|
|
-show headings -yscroll "$w.mid.vsb set" -xscroll "$w.mid.hsb set"
|
|
ttk::scrollbar $w.mid.vsb -orient vertical -command "$w.mid.tree yview"
|
|
ttk::scrollbar $w.mid.hsb -orient horizontal -command "$w.mid.tree xview"
|
|
pack $w.mid -side top -fill both -expand true -padx 4 -pady 4
|
|
grid $w.mid.tree $w.mid.vsb -in $w.mid -sticky nsew
|
|
grid $w.mid.hsb -in $w.mid -sticky nsew
|
|
grid column $w.mid 0 -weight 1
|
|
grid row $w.mid 0 -weight 1
|
|
|
|
bind $w.mid.tree <<TreeviewSelect>> "findTreeSelect $w.mid.tree"
|
|
|
|
set closecmd "drawNodeCircle {} {} {} {} findhi; destroy $w"
|
|
bind $w.find.text <Key-Escape> $closecmd
|
|
bind $w <Key-Escape> $closecmd
|
|
|
|
ttk::frame $w.fbot -borderwidth 4
|
|
ttk::button $w.fbot.find -text "Find" -command "findButton $w"
|
|
ttk::button $w.fbot.close -text "Close" -command $closecmd
|
|
pack $w.fbot.find $w.fbot.close -side left -padx 4 -pady 4
|
|
pack $w.fbot -side bottom
|
|
|
|
findTreeHeader $w.mid.tree
|
|
focus $w.find.text
|
|
}
|
|
|
|
# helper for find button, implements searching of nodes, links, and node names
|
|
# TODO: search IPv4/IPv6/MAC addresses, services, annotations, EMANE configs?
|
|
proc findButton { w } {
|
|
global node_list link_list
|
|
set terms [$w.find.text get]
|
|
set tree $w.mid.tree
|
|
|
|
findTreeHeader $tree
|
|
. config -cursor watch; update
|
|
set first ""
|
|
set nodename_list ""
|
|
foreach n $node_list { lappend nodename_list [getNodeName $n] }
|
|
|
|
foreach search [list node nodename link] {
|
|
set ${search}_results [lsearch -nocase -all -glob \
|
|
[set ${search}_list] "*$terms*"]
|
|
# populate results
|
|
foreach result [set ${search}_results] {
|
|
if { $result == -1 } { continue }
|
|
set search_list ${search}_list
|
|
if { ${search} == "nodename" } { set search_list node_list }
|
|
set obj [lindex [set $search_list] $result]
|
|
if { $first == "" } { set first $obj }
|
|
|
|
set num $obj
|
|
if { $search == "link" } {
|
|
set peers [linkPeers $obj]
|
|
set name "[lindex $peers 0]-[lindex $peers 1]"
|
|
set coords [getNodeCoords [lindex $peers 0]]
|
|
set details [getLinkBandwidthString $obj]
|
|
set details "$details [getLinkDelayString $obj]"
|
|
} else {
|
|
set name [getNodeName $obj]
|
|
set coords [getNodeCoords $obj]
|
|
set details [ipv4List $obj false]
|
|
set details "$details [ipv6List $obj false]"
|
|
}
|
|
set coords "<[lindex $coords 0], [lindex $coords 1]>"
|
|
if { ![$tree exists $obj] } {
|
|
$tree insert {} end -id $obj \
|
|
-values [list $num $name $coords $details]
|
|
}
|
|
}
|
|
}
|
|
|
|
if { $first == "" } {
|
|
$tree insert {} end -id none -values [list "" "" "" "no results found"]
|
|
} else {
|
|
$tree selection set $first
|
|
}
|
|
|
|
. config -cursor left_ptr
|
|
}
|
|
|
|
# helper clears treeview and populates column header row
|
|
proc findTreeHeader { tree } {
|
|
$tree delete [$tree children {}]
|
|
set widths {75 75 125 350}; set i 0
|
|
foreach col {number name location details} {
|
|
$tree heading $col -text $col
|
|
set width [lindex $widths $i]; incr i
|
|
$tree column $col -width $width
|
|
}
|
|
drawNodeCircle "" "" "" "" findhi
|
|
}
|
|
|
|
# helper handles treeview selection changes in the Find dialog
|
|
proc findTreeSelect { ctl } {
|
|
global curcanvas
|
|
drawNodeCircle "" "" "" "" findhi
|
|
set obj [$ctl selection]
|
|
if { $obj == "none" } { return }
|
|
|
|
if { [string range $obj 0 0] == "l" } {
|
|
lassign [linkPeers $obj] node node2
|
|
} else {
|
|
set node $obj
|
|
set node2 ""
|
|
}
|
|
|
|
# highlight node(s) and reposition canvas view so items are visible
|
|
set target_canvas [getNodeCanvas $node]
|
|
if { $target_canvas != $curcanvas } {
|
|
set curcanvas $target_canvas
|
|
switchCanvas none
|
|
}
|
|
drawNodeCircle $node 30 red findhi ""
|
|
if { $node2 != "" } { drawNodeCircle $node2 30 red findhi "" }
|
|
canvasSee .c $node
|
|
}
|
|
|
|
|