core-extra/gui/util.tcl

#
# Copyright 2005-2014 the Boeing Company.
# See the LICENSE file included in this distribution.
#

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)"
	puts "    pkg_add -r libimg   (FreeBSD)\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 vtysh 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] {
    	if {[lindex $systype 0] == "Linux" } { ;# Linux
	    set net [lindex [split $statrte] 0]
	    set gw [lindex [split $statrte] 1]
	    lappend cfg "/sbin/ip -4 route add $net via $gw"
	} else { ;# FreeBSD
	    lappend cfg "route -q add -inet $statrte"
	}
    }

    foreach statrte [getStatIPv6routes $node] {
    	if { [lindex $systype 0] == "Linux" } { ;# Linux
	    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"
	} else { ;# FreeBSD
	    lappend cfg "route -q add -inet6 $statrte"
	}
    }

}

proc getServiceStartString { } {
    global systype

    setSystype

    if { [lindex $systype 0] == "Linux" } { ;# Linux
	return "/etc/init.d/core-daemon start"
    } else { ;# FreeBSD
	return "/usr/local/etc/rc.d/core onestart"
    }
}

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 -x} {lxterminal -e} {konsole -e} {xterm -e}"
set TERMS "$TERMS {aterm -e} {eterm -e} {rxvt -e} {xfce4-terminal -e}"

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 has problem w/subsequent arguments after -e, needs -x
	if { [file tail $term] == "gnome-terminal" } { 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
}