From f01ddd7c16df4cdb715a083b8d534014c979ce94 Mon Sep 17 00:00:00 2001 From: ahrenholz Date: Mon, 2 Dec 2013 21:14:14 +0000 Subject: [PATCH] GUI support for unidirectional link effects; GUI support for link jitter (Boeing r1796,1797) --- gui/api.tcl | 153 +++++++++++++++++++----- gui/cfgparse.tcl | 23 ++-- gui/editor.tcl | 297 ++++++++++++++++++++++++++++++++++++++--------- gui/linkcfg.tcl | 205 +++++++++++++++++++++++++------- 4 files changed, 533 insertions(+), 145 deletions(-) diff --git a/gui/api.tcl b/gui/api.tcl index f9b0fade..35dd39d4 100755 --- a/gui/api.tcl +++ b/gui/api.tcl @@ -547,15 +547,15 @@ proc parseLinkMessage { data len flags } { array set typenames { 1 node1num 2 node2num 3 delay 4 bw 5 per \ 6 dup 7 jitter 8 mer 9 burst 10 session \ - 16 mburst 32 ltype 33 guiattr \ + 16 mburst 32 ltype 33 guiattr 34 uni \ 35 emuid1 36 netid 37 key \ 48 if1num 49 if1ipv4 50 if1ipv4mask 51 if1mac \ 52 if1ipv6 53 if1ipv6mask \ 54 if2num 55 if2ipv4 56 if2ipv4mask 57 if2mac \ 64 if2ipv6 65 if2ipv6mask } array set typesizes { node1num 4 node2num 4 delay 8 bw 8 per -1 \ - dup -1 jitter 2 mer 2 burst 2 session -1 \ - mburst 2 ltype 4 guiattr -1 \ + dup -1 jitter 8 mer 2 burst 2 session -1 \ + mburst 2 ltype 4 guiattr -1 uni 2 \ emuid1 4 netid 4 key 4 \ if1num 2 if1ipv4 4 if1ipv4mask 2 if1mac 8 \ if1ipv6 16 if1ipv6mask 2 \ @@ -563,7 +563,7 @@ proc parseLinkMessage { data len flags } { if2ipv6 16 if2ipv6mask 2 } array set vals { node1num -1 node2num -1 delay 0 bw 0 per "" \ dup "" jitter 0 mer 0 burst 0 session "" \ - mburst 0 ltype 0 guiattr "" \ + mburst 0 ltype 0 guiattr "" uni 0 \ emuid1 -1 netid -1 key -1 \ if1num -1 if1ipv4 -1 if1ipv4mask 24 if1mac -1 \ if1ipv6 -1 if1ipv6mask 64 \ @@ -726,20 +726,6 @@ proc apiLinkAddModify { node1 node2 vals_ref add } { set c .c upvar $vals_ref vals - set labelstr ""; # build a label string - if {$vals(bw) > 0} { set labelstr "$labelstr$vals(bw) " } - if {$vals(delay) > 0} { set labelstr \ - "$labelstr[expr $vals(delay)/1000] ms " } - if {$vals(per) > 0} { set labelstr "${labelstr}E=$vals(per)% " } - if {$vals(dup) > 0} { set labelstr "${labelstr}D=$vals(dup)% " } - if {$vals(jitter) > 0} { - set labelstr "${labelstr}J=[expr $vals(jitter)/1000] ms " } - - set params ""; # parameters to send to ng_wlan netgraph node - if { $labelstr != "" } { - set params "delay=$vals(delay) bandwidth=$vals(bw) per=$vals(per)" - set params "$params duplicate=$vals(dup) jitter=$vals(jitter)" - } if {$vals(key) > -1} { if { [nodeType $node1] == "tunnel" } { netconfInsertSection $node1 [list "tunnel-key" $vals(key)] @@ -753,11 +739,33 @@ proc apiLinkAddModify { node1 node2 vals_ref add } { set wired_link [linkByPeers $node1 $node2] if { $wired_link != "" && $add == 0 } { ;# wired link exists, modify it #puts "modify wired link" - setLinkBandwidth $wired_link $vals(bw) - setLinkDelay $wired_link $vals(delay) - setLinkBER $wired_link $vals(per) - setLinkDup $wired_link $vals(dup) - setLinkJitter $wired_link $vals(jitter) + if { $vals(uni) == 1 } { ;# unidirectional link effects message + set peers [linkPeers $wired_link] + if { $node1 == [lindex $peers 0] } { ;# downstream n1 <-- n2 + set bw [list $vals(bw) [getLinkBandwidth $wired_link up]] + set delay [list $vals(delay) [getLinkDelay $wired_link up]] + set per [list $vals(per) [getLinkBER $wired_link up]] + set dup [list $vals(dup) [getLinkBER $wired_link up]] + set jitter [list $vals(jitter) [getLinkJitter $wired_link up]] + } else { ;# upstream n1 --> n2 + set bw [list [getLinkBandwidth $wired_link] $vals(bw)] + set delay [list [getLinkDelay $wired_link] $vals(delay)] + set per [list [getLinkBER $wired_link] $vals(per)] + set dup [list [getLinkBER $wired_link] $vals(dup)] + set jitter [list $vals(jitter) [getLinkJitter $wired_link]] + } + setLinkBandwidth $wired_link $bw + setLinkDelay $wired_link $delay + setLinkBER $wired_link $per + setLinkDup $wired_link $dup + setLinkJitter $wired_link $jitter + } else { + setLinkBandwidth $wired_link $vals(bw) + setLinkDelay $wired_link $vals(delay) + setLinkBER $wired_link $vals(per) + setLinkDup $wired_link $vals(dup) + setLinkJitter $wired_link $vals(jitter) + } updateLinkLabel $wired_link updateLinkGuiAttr $wired_link $vals(guiattr) return @@ -1896,7 +1904,7 @@ proc sendNodeDelMessage { channel node } { # send a message to build, modify, or delete a link # type should indicate add/delete/link/unlink -proc sendLinkMessage { channel link type } { +proc sendLinkMessage { channel link type {sendboth true} } { global showAPI set prmsg $showAPI @@ -1915,6 +1923,12 @@ proc sendLinkMessage { channel link type } { set node1_num [string range $node1 1 end] set node2_num [string range $node2 1 end] + # flag for sending unidirectional link messages + set uni 0 + if { $sendboth && [isLinkUni $link] } { + set uni 1 + } + # set flags and link message type from supplied type parameter set flags 0 set ltype 1 ;# add/delete a link (not wireless link/unlink) @@ -1948,6 +1962,8 @@ proc sendLinkMessage { channel link type } { set len [expr {8+8+8}] set delay [getLinkDelay $link] if { $delay == "" } { set delay 0 } + set jitter [getLinkJitter $link] + if { $jitter == "" } { set jitter 0 } set bw [getLinkBandwidth $link] if { $bw == "" } { set bw 0 } set per [getLinkBER $link]; # PER and BER @@ -1959,16 +1975,20 @@ proc sendLinkMessage { channel link type } { set dup_len 0 set dup_msg [buildStringTLV 0x6 $dup dup_len] if { $type != "delete" } { - incr len [expr {12+12+$per_len+$dup_len}] ;# delay,bw,per,dup + incr len [expr {12+12+$per_len+$dup_len+12}] ;# delay,bw,per,dup,jitter if {$prmsg==1 } { - puts -nonewline "$delay,$bw,$per,$dup," + puts -nonewline "$delay,$bw,$per,$dup,$jitter," } } - # TODO: jitter, mer, burst, mburst + # TODO: mer, burst, mburst if { $prmsg == 1 } { puts -nonewline "type=$ltype," } + if { $uni } { + incr len 4 + if { $prmsg == 1 } { puts -nonewline "uni=$uni," } + } if { $netid > -1 } { incr len 8 - if { $prmsg == 1 } { puts -nonewline ",netid=$netid" } + if { $prmsg == 1 } { puts -nonewline "netid=$netid," } } if { $key != "" } { incr len 8 @@ -2012,12 +2032,18 @@ proc sendLinkMessage { channel link type } { puts -nonewline $channel [binary format c2sW {0x4 8} 0 $bw] puts -nonewline $channel $per_msg puts -nonewline $channel $dup_msg + puts -nonewline $channel [binary format c2sW {0x7 8} 0 $jitter] } - # TODO: jitter, mer, burst, mburst + # TODO: mer, burst, mburst # link type puts -nonewline $channel [binary format c2sI {0x20 4} 0 $ltype] + # unidirectional flag + if { $uni } { + puts -nonewline $channel [binary format c2S {0x22 2} $uni] + } + # network ID if { $netid > -1 } { puts -nonewline $channel [binary format c2sI {0x24 4} 0 $netid] @@ -2061,6 +2087,73 @@ proc sendLinkMessage { channel link type } { if { $prmsg==1 } { puts ")" } flushChannel channel "Error sending link message" + + ########################################################## + # send a second Link Message for unidirectional link effects + if { $uni < 1 } { + return + } + # first calculate length and possibly print the message + set flags 0 + if { $prmsg == 1 } { + puts -nonewline ">LINK(flags=$flags,$node2_num-$node1_num," + } + set len [expr {8+8+8}] ;# len = node2num, node1num (swapped), type + set delay [getLinkDelay $link up] + if { $delay == "" } { set delay 0 } + set jitter [getLinkJitter $link up] + if { $jitter == "" } { set jitter 0 } + set bw [getLinkBandwidth $link up] + if { $bw == "" } { set bw 0 } + set per [getLinkBER $link up]; # PER and BER + if { $per == "" } { set per 0 } + set per_len 0 + set per_msg [buildStringTLV 0x5 $per per_len] + set dup [getLinkDup $link up] + if { $dup == "" } { set dup 0 } + set dup_len 0 + set dup_msg [buildStringTLV 0x6 $dup dup_len] + incr len [expr {12+12+$per_len+$dup_len+12}] ;# delay,bw,per,dup,jitter + if {$prmsg==1 } { + puts -nonewline "$delay,$bw,$per,$dup,$jitter," + } + if { $prmsg == 1 } { puts -nonewline "type=$ltype," } + incr len 4 ;# unidirectional flag + if { $prmsg == 1 } { puts -nonewline "uni=$uni," } + # note that if1num / if2num are reversed here due to reversed node nums + if { $if2num >= 0 && ([[typemodel $node2].layer] == "NETWORK" || \ + [nodeType $node2] == "tunnel") } { + incr len 4 + if { $prmsg == 1 } { puts -nonewline "if1n=$if2num," } + } + if { $if1num >= 0 && ([[typemodel $node1].layer] == "NETWORK" || \ + [nodeType $node1] == "tunnel") } { + incr len 4 + if { $prmsg == 1 } { puts -nonewline "if2n=$if1num," } + } + # build and send the link message + set msg [binary format ccSc2sIc2sI \ + {0x2} $flags $len \ + {0x1 4} 0 $node2_num \ + {0x2 4} 0 $node1_num ] + puts -nonewline $channel $msg + puts -nonewline $channel [binary format c2sW {0x3 8} 0 $delay] + puts -nonewline $channel [binary format c2sW {0x4 8} 0 $bw] + puts -nonewline $channel $per_msg + puts -nonewline $channel $dup_msg + puts -nonewline $channel [binary format c2sW {0x7 8} 0 $jitter] + puts -nonewline $channel [binary format c2sI {0x20 4} 0 $ltype] + puts -nonewline $channel [binary format c2S {0x22 2} $uni] + if { $if2num >= 0 && ([[typemodel $node2].layer] == "NETWORK" || \ + [nodeType $node2] == "tunnel") } { + puts -nonewline $channel [ binary format c2S {0x30 2} $if2num ] + } + if { $if1num >= 0 && ([[typemodel $node1].layer] == "NETWORK" || \ + [nodeType $node1] == "tunnel") } { + puts -nonewline $channel [ binary format c2S {0x36 2} $if1num ] + } + if { $prmsg==1 } { puts ")" } + flushChannel channel "Error sending link message" } # helper to get IPv4, IPv6, MAC address and increment length @@ -2539,7 +2632,7 @@ proc shutdownSession {} { continue; # remote routers are ctrl. by GUI; TODO: move to daemon } - sendLinkMessage $sock $link delete + sendLinkMessage $sock $link delete false } # shut down all nodes foreach node $node_list { diff --git a/gui/cfgparse.tcl b/gui/cfgparse.tcl index 2ef5f7ed..b8b27032 100755 --- a/gui/cfgparse.tcl +++ b/gui/cfgparse.tcl @@ -704,21 +704,16 @@ proc loadCfg { cfg } { mirror { lappend $object "mirror $value" } - bandwidth { - lappend $object "bandwidth $value" - } - delay { - lappend $object "delay $value" - } - ber { - lappend $object "ber $value" - } - duplicate { - lappend $object "duplicate $value" - } + bandwidth - + delay - + ber - + duplicate - jitter { - # Boeing - jitter - lappend $object "jitter $value" + if { [llength $value] > 1 } { ;# down/up-stream + lappend $object "$field {$value}" + } else { + lappend $object "$field $value" + } } color { lappend $object "color $value" diff --git a/gui/editor.tcl b/gui/editor.tcl index 9bf28880..e048fbdb 100755 --- a/gui/editor.tcl +++ b/gui/editor.tcl @@ -723,20 +723,21 @@ proc updateIfcLabel { lnode1 lnode2 } { proc updateLinkLabel { link } { global showLinkLabels - set labelstr "" + set bwstr [getLinkBandwidthString $link] set delstr [getLinkDelayString $link] - set ber [getLinkBER $link] - set dup [getLinkDup $link] - set labelstr "$labelstr[getLinkBandwidthString $link] " + set berstr [getLinkBERString $link] + set dupstr [getLinkDupString $link] + set labelstr " " + if { "$bwstr" != "" } { + set labelstr "$labelstr$bwstr " + } if { "$delstr" != "" } { set labelstr "$labelstr$delstr " } - if { "$ber" != "" } { - set berstr "loss=$ber%" + if { "$berstr" != "" } { set labelstr "$labelstr$berstr " } - if { "$dup" != "" } { - set dupstr "dup=$dup%" + if { "$dupstr" != "" } { set labelstr "$labelstr$dupstr " } set labelstr \ @@ -2758,22 +2759,34 @@ proc popupConfigDialog { c } { pack $wi.ftop -side top set spinbox [getspinbox] - ttk::frame $wi.bandwidth -borderwidth 4 + global g_link_config_uni_state + set g_link_config_uni_state "bid" + + ttk::frame $wi.preset -borderwidth 4 global link_preset_val set link_preset_val unlimited - set linkpreMenu [tk_optionMenu $wi.bandwidth.linkpre link_preset_val a] - pack $wi.bandwidth.linkpre -side top + set linkpreMenu [tk_optionMenu $wi.preset.linkpre link_preset_val a] + # unidirectional links not always supported + if { [isUniSupported $n0 $n1] } { + set unistate normal + } else { + set unistate disabled + } + ttk::button $wi.preset.uni -text "Unidir. >>" -state $unistate \ + -command "linkConfigUni $wi" + pack $wi.preset.uni $wi.preset.linkpre -side right linkPresets $wi $linkpreMenu init - ttk::label $wi.bandwidth.label -anchor e \ - -text "Bandwidth (bps):" + pack $wi.preset -side top -anchor e + + ttk::frame $wi.bandwidth -borderwidth 4 + ttk::label $wi.bandwidth.label -anchor e -text "Bandwidth (bps):" $spinbox $wi.bandwidth.value -justify right -width 10 \ -validate focus -invalidcommand "focusAndFlash %W" $wi.bandwidth.value insert 0 [getLinkBandwidth $target] $wi.bandwidth.value configure \ -validatecommand {checkIntRange %P 0 1000000000} \ -from 0 -to 1000000000 -increment 1000000 - pack $wi.bandwidth.value $wi.bandwidth.label \ - -side right + pack $wi.bandwidth.value $wi.bandwidth.label -side right pack $wi.bandwidth -side top -anchor e ttk::frame $wi.delay -borderwidth 4 @@ -2787,11 +2800,22 @@ proc popupConfigDialog { c } { pack $wi.delay.value $wi.delay.label -side right pack $wi.delay -side top -anchor e + ttk::frame $wi.jitter -borderwidth 4 + ttk::label $wi.jitter.label -anchor e -text "Jitter (us):" + $spinbox $wi.jitter.value -justify right -width 10 \ + -validate focus -invalidcommand "focusAndFlash %W" + $wi.jitter.value insert 0 [getLinkJitter $target] + $wi.jitter.value configure \ + -validatecommand {checkIntRange %P 0 10000000} \ + -from 0 -to 10000000 -increment 5 + pack $wi.jitter.value $wi.jitter.label -side right + pack $wi.jitter -side top -anchor e + ttk::frame $wi.ber -borderwidth 4 if { [lindex $systype 0] == "Linux" } { set bertext "Loss (%):" - set berinc 1 - set bermax 100 + set berinc 0.1 + set bermax 100.0 } else { ;# netgraph uses BER set bertext "BER (1/N):" set berinc 1000 @@ -2802,8 +2826,8 @@ proc popupConfigDialog { c } { -validate focus -invalidcommand "focusAndFlash %W" $wi.ber.value insert 0 [getLinkBER $target] $wi.ber.value configure \ - -validatecommand "checkFloatRange %P 0 $bermax" \ - -from 0 -to $bermax -increment $berinc + -validatecommand "checkFloatRange %P 0.0 $bermax" \ + -from 0.0 -to $bermax -increment $berinc pack $wi.ber.value $wi.ber.label -side right pack $wi.ber -side top -anchor e @@ -2836,6 +2860,7 @@ proc popupConfigDialog { c } { set link_color [getLinkColor $target] tk_optionMenu $wi.color.value link_color \ Red Green Blue Yellow Magenta Cyan Black + $wi.color.value configure -width 8 pack $wi.color.value $wi.color.label -side right pack $wi.color -side top -anchor e @@ -2849,6 +2874,26 @@ proc popupConfigDialog { c } { -from 1 -to 8 -increment 1 pack $wi.width.value $wi.width.label -side right pack $wi.width -side top -anchor e + + # auto-expand upstream if values exist + set bw [getLinkBandwidth $target up] + set dl [getLinkDelay $target up] + set jt [getLinkJitter $target up] + set ber [getLinkBER $target up] + set dup [getLinkDup $target up] + if { $bw > 0 || $dl > 0 || $jt > 0 || $ber > 0 || $dup > 0 } { + linkConfigUni $wi + $wi.bandwidth.value2 delete 0 end + $wi.bandwidth.value2 insert 0 $bw + $wi.delay.value2 delete 0 end + $wi.delay.value2 insert 0 $dl + $wi.jitter.value2 delete 0 end + $wi.jitter.value2 insert 0 $jt + $wi.ber.value2 delete 0 end + $wi.ber.value2 insert 0 $ber + $wi.dup.value2 delete 0 end + $wi.dup.value2 insert 0 $dup + } } } ;# end switch @@ -2872,6 +2917,121 @@ proc popupConfigDialog { c } { # bind $wi "popupConfigApply $wi $object_type $target 0" } + +proc linkConfigUni { wi } { + global g_link_config_uni_state + + set capt [lindex [$wi.preset.uni configure -text] 4] + + if { $capt == "Unidir. >>" } { + set g_link_config_uni_state "uni" + $wi.preset.uni configure -text "<< Bidir." + set spinbox [getspinbox] + + if { ![winfo exists $wi.bandwidth.value2] } { + $spinbox $wi.bandwidth.value2 -justify right \ + -width 10 -validate focus -invalidcommand "focusAndFlash %W" + $wi.bandwidth.value2 configure \ + -validatecommand {checkIntRange %P 0 1000000000} \ + -from 0 -to 1000000000 -increment 1000000 + } + $wi.bandwidth.value2 delete 0 end + $wi.bandwidth.value2 insert 0 [$wi.bandwidth.value get] + pack $wi.bandwidth.value2 -side right + pack $wi.bandwidth.value2 -before $wi.bandwidth.value + + if { ![winfo exists $wi.delay.value2] } { + $spinbox $wi.delay.value2 -justify right -width 10 \ + -validate focus -invalidcommand "focusAndFlash %W" + $wi.delay.value2 configure \ + -validatecommand {checkIntRange %P 0 10000000} \ + -from 0 -to 10000000 -increment 5 + } + $wi.delay.value2 delete 0 end + $wi.delay.value2 insert 0 [$wi.delay.value get] + pack $wi.delay.value2 -side right + pack $wi.delay.value2 -before $wi.delay.value + + if { ![winfo exists $wi.jitter.value2] } { + $spinbox $wi.jitter.value2 -justify right -width 10 \ + -validate focus -invalidcommand "focusAndFlash %W" + $wi.jitter.value2 configure \ + -validatecommand {checkIntRange %P 0 10000000} \ + -from 0 -to 10000000 -increment 5 + } + $wi.jitter.value2 delete 0 end + $wi.jitter.value2 insert 0 [$wi.jitter.value get] + pack $wi.jitter.value2 -side right + pack $wi.jitter.value2 -before $wi.jitter.value + + if { ![winfo exists $wi.ber.value2] } { + $spinbox $wi.ber.value2 -justify right -width 10 \ + -validate focus -invalidcommand "focusAndFlash %W" + $wi.ber.value2 configure \ + -validatecommand "checkFloatRange %P 0.0 100.0" \ + -from 0.0 -to 100.0 -increment 0.1 + } + $wi.ber.value2 delete 0 end + $wi.ber.value2 insert 0 [$wi.ber.value get] + pack $wi.ber.value2 -side right + pack $wi.ber.value2 -before $wi.ber.value + + if { ![winfo exists $wi.dup.value2] } { + $spinbox $wi.dup.value2 -justify right -width 10 \ + -validate focus -invalidcommand "focusAndFlash %W" + $wi.dup.value2 configure \ + -validatecommand {checkFloatRange %P 0 50} \ + -from 0 -to 50 -increment 1 + } + $wi.dup.value2 delete 0 end + $wi.dup.value2 insert 0 [$wi.dup.value get] + pack $wi.dup.value2 -side right + pack $wi.dup.value2 -before $wi.dup.value + + if { ![winfo exists $wi.unilabel] } { + ttk::frame $wi.unilabel + set txt " downstream / upstream " + ttk::label $wi.unilabel.updown -text $txt + } + pack $wi.unilabel.updown -side right -anchor e + pack $wi.unilabel -after $wi.preset + + } else { + set g_link_config_uni_state "bid" + $wi.preset.uni configure -text "Unidir. >>" + pack forget $wi.bandwidth.value2 + pack forget $wi.delay.value2 + pack forget $wi.jitter.value2 + pack forget $wi.ber.value2 + pack forget $wi.dup.value2 + pack forget $wi.unilabel.updown $wi.unilabel + } +} + +# unidirectional links are not always supported +proc isUniSupported { n1 n2 } { + set blacklist [list "hub" "lanswitch"] + set type1 [nodeType $n1] + set type2 [nodeType $n2] + # not yet supported for GRE tap device + if { $type1 == "tunnel" || $type2 == "tunnel" } { + return false + } + # unidirectional links are supported between two switches/hubs + if { [lsearch $blacklist $type1] != -1 && \ + [lsearch $blacklist $type2] != -1 } { + return true + } + # unidirectional links not supported between hub/switch and something else + if { [lsearch $blacklist $type1] != -1 || \ + [lsearch $blacklist $type2] != -1 } { + return false + } + # unidirectional links are supported between routers, rj45s, etc. + # WLANs not included here because they have no link dialog + return true +} + # toggle the state of the mac address entry, and insert MAC address template proc macEntryHelper { wi ifc } { set fr $wi.ifaces.c.if$ifc @@ -3056,39 +3216,25 @@ proc popupConfigApply { wi object_type target phase } { } link { + global g_link_config_uni_state set mirror [getLinkMirror $target] - set bw [$wi.bandwidth.value get] - if { $bw != [getLinkBandwidth $target] } { - setLinkBandwidth $target [$wi.bandwidth.value get] - if { $mirror != "" } { - setLinkBandwidth $mirror [$wi.bandwidth.value get] - } + + if { [setIfChanged $target $mirror $wi "bandwidth" "LinkBandwidth"] } { set changed 1 } - set dly [$wi.delay.value get] - if { $dly != [getLinkDelay $target] } { - setLinkDelay $target [$wi.delay.value get] - if { $mirror != "" } { - setLinkDelay $mirror [$wi.delay.value get] - } + if { [setIfChanged $target $mirror $wi "delay" "LinkDelay"] } { set changed 1 } - set ber [$wi.ber.value get] - if { $ber != [getLinkBER $target] } { - setLinkBER $target [$wi.ber.value get] - if { $mirror != "" } { - setLinkBER $mirror [$wi.ber.value get] - } + if { [setIfChanged $target $mirror $wi "ber" "LinkBER"] } { set changed 1 } - set dup [$wi.dup.value get] - if { $dup != [getLinkDup $target] } { - setLinkDup $target [$wi.dup.value get] - if { $mirror != "" } { - setLinkDup $mirror [$wi.dup.value get] - } + if { [setIfChanged $target $mirror $wi "dup" "LinkDup"] } { set changed 1 } + if { [setIfChanged $target $mirror $wi "jitter" "LinkJitter"] } { + set changed 1 + } + if { $link_color != [getLinkColor $target] } { setLinkColor $target $link_color if { $mirror != "" } { @@ -3098,9 +3244,9 @@ proc popupConfigApply { wi object_type target phase } { } set width [$wi.width.value get] if { $width != [getLinkWidth $target] } { - setLinkWidth $target [$wi.width.value get] + setLinkWidth $target $width if { $mirror != "" } { - setLinkWidth $mirror [$wi.width.value get] + setLinkWidth $mirror $width } set changed 1 } @@ -3114,6 +3260,30 @@ proc popupConfigApply { wi object_type target phase } { popdownConfig $wi } +# helper for Link Config dialog +# ctl must exist as $wi.$ctl.value{2}, and {get,set}$procname must be valid +# returns true when value has changed, false otherwise +proc setIfChanged { target mirror wi ctl procname } { + global g_link_config_uni_state + + set val [$wi.$ctl.value get] + if { $g_link_config_uni_state == "uni" } { + set val [list $val [$wi.$ctl.value2 get]] + } + set oldval [get$procname $target] + set oldval2 [get$procname $target "up"] + if { $oldval2 != "" } { + set oldval [list $oldval $oldval2] + } + if { $val != $oldval } { + set$procname $target $val + if { $mirror != "" } { + set$procname $mirror $val + } + return true + } + return false +} #****f* editor.tcl/printCanvas # NAME @@ -4400,8 +4570,8 @@ proc drawWallpaper { c f style } { set cy [expr [lindex [getCanvasSize $curcanvas] 1]-2] } set f [absPathname $f] - if { [ catch { set img [image create photo -file $f] } ] } { - puts "Error: couldn't open wallpaper file $f" + if { [ catch { set img [image create photo -file $f] } e ] } { + puts "Error: couldn't open wallpaper file $f: $e" return } set imgx [image width $img] @@ -4511,18 +4681,19 @@ proc rj45ifclist { wi node wasclicked } { # link preset values - bandwidth delay ber duplicate array set link_presets { - "unlimited" { 0 0 0 0 } - "1000M" { 1000000000 100 0 0} - "100M" { 100000000 110 0 0} - "10M" { 10000000 160 0 0} - "512kbps" { 512000 50000 0 0} - "256kbps" { 256000 75000 0 0} - "64kbps" { 64000 80000 0 0} + "unlimited" { 0 0 0 0 0 } + "1000M" { 1000000000 100 0 0.0 0.0} + "100M" { 100000000 110 0 0.0 0.0} + "10M" { 10000000 160 0 0.0 0.0} + "512kbps" { 512000 50000 0 0.0 0.0} + "256kbps" { 256000 75000 0 0.0 0.0} + "64kbps" { 64000 80000 0 0.0 0.0} } # link presets proc linkPresets { wi linkpreMenu cmd } { global link_presets link_preset_val + global g_link_config_uni_state if { $cmd == "init" } { ;# populate the list with presets and exit $linkpreMenu delete 0 @@ -4538,12 +4709,26 @@ proc linkPresets { wi linkpreMenu cmd } { set params $link_presets($link_preset_val) $wi.bandwidth.value delete 0 end $wi.delay.value delete 0 end + $wi.jitter.value delete 0 end $wi.ber.value delete 0 end $wi.dup.value delete 0 end $wi.bandwidth.value insert 0 [lindex $params 0] $wi.delay.value insert 0 [lindex $params 1] - $wi.ber.value insert 0 [lindex $params 2] - $wi.dup.value insert 0 [lindex $params 3] + $wi.jitter.value insert 0 [lindex $params 2] + $wi.ber.value insert 0 [lindex $params 3] + $wi.dup.value insert 0 [lindex $params 4] + if { $g_link_config_uni_state == "uni" } { + $wi.bandwidth.value2 delete 0 end + $wi.delay.value2 delete 0 end + $wi.jitter.value2 delete 0 end + $wi.ber.value2 delete 0 end + $wi.dup.value2 delete 0 end + $wi.bandwidth.value2 insert 0 [lindex $params 0] + $wi.delay.value2 insert 0 [lindex $params 1] + $wi.jitter.value2 insert 0 [lindex $params 2] + $wi.ber.value2 insert 0 [lindex $params 3] + $wi.dup.value2 insert 0 [lindex $params 4] + } } set last_nodeHighlights [clock clicks -milliseconds] diff --git a/gui/linkcfg.tcl b/gui/linkcfg.tcl index f95b32fd..67c75b42 100755 --- a/gui/linkcfg.tcl +++ b/gui/linkcfg.tcl @@ -179,11 +179,13 @@ proc removeLink { link } { # * bandwidth -- The value of link bandwidth in bits per second. #**** -proc getLinkBandwidth { link } { +proc getLinkBandwidth { link {dir "down"} } { global $link set entry [lsearch -inline [set $link] "bandwidth *"] - return [lindex $entry 1] + set val [lindex $entry 1] ;# one or more values + if { $dir == "up" } { return [lindex $val 1] } + return [lindex $val 0] } #****f* linkcfg.tcl/getLinkBandwidthString @@ -204,25 +206,39 @@ proc getLinkBandwidth { link } { proc getLinkBandwidthString { link } { global $link set bandstr "" + set sep "" set bandwidth [getLinkBandwidth $link] - if { $bandwidth > 0 } { - if { $bandwidth >= 660000000 } { - set bandstr "[format %.2f [expr {$bandwidth / 1000000000.0}]] Gbps" - } elseif { $bandwidth >= 99000000 } { - set bandstr "[format %d [expr {$bandwidth / 1000000}]] Mbps" - } elseif { $bandwidth >= 9900000 } { - set bandstr "[format %.2f [expr {$bandwidth / 1000000.0}]] Mbps" - } elseif { $bandwidth >= 990000 } { - set bandstr "[format %d [expr {$bandwidth / 1000}]] Kbps" - } elseif { $bandwidth >= 9900 } { - set bandstr "[format %.2f [expr {$bandwidth / 1000.0}]] Kbps" - } else { - set bandstr "$bandwidth bps" - } + set bandwidthup [getLinkBandwidth $link up] + if { $bandwidthup > 0 } { + set bandwidth [list $bandwidth $bandwidthup] + set sep " / " + } + foreach bw $bandwidth { + if { $bandstr != "" } { set bandstr "$bandstr$sep" } + set bandstr "$bandstr[getSIStringValue $bw "bps"]" } return $bandstr } +proc getSIStringValue { val suffix } { + if { $val <= 0 } { + return "" + } + if { $val >= 660000000 } { + return "[format %.2f [expr {$val / 1000000000.0}]] G$suffix" + } elseif { $val >= 99000000 } { + return "[format %d [expr {$val / 1000000}]] M$suffix" + } elseif { $val >= 9900000 } { + return "[format %.2f [expr {$val / 1000000.0}]] M$suffix" + } elseif { $val >= 990000 } { + return "[format %d [expr {$val / 1000}]] K$suffix" + } elseif { $val >= 9900 } { + return "[format %.2f [expr {$val / 1000.0}]] K$suffix" + } else { + return "$val $suffix" + } +} + #****f* linkcfg.tcl/setLinkBandwidth # NAME # setLinkBandwidth -- set link bandwidth @@ -242,13 +258,11 @@ proc setLinkBandwidth { link value } { if { $value <= 0 } { set $link [lreplace [set $link] $i $i] } else { + if { [llength $value] > 1 } { set value "{$value}" } set $link [lreplace [set $link] $i $i "bandwidth $value"] } } -# -# Marko - XXX document! -# proc getLinkColor { link } { global $link defLinkColor @@ -298,11 +312,13 @@ proc setLinkWidth { link value } { # * delay -- The value of link delay in microseconds. #**** -proc getLinkDelay { link } { +proc getLinkDelay { link {dir "down"} } { global $link set entry [lsearch -inline [set $link] "delay *"] - return [lindex $entry 1] + set val [lindex $entry 1] ;# one or more values + if { $dir == "up" } { return [lindex $val 1] } + return [lindex $val 0] } #****f* linkcfg.tcl/getLinkDelayString @@ -322,20 +338,49 @@ proc getLinkDelay { link } { proc getLinkDelayString { link } { global $link - + set plusminus "\261" + set delaystr "" + set sep "" set delay [getLinkDelay $link] - if { "$delay" != "" } { - if { $delay >= 10000 } { - set delstr "[expr {$delay / 1000}] ms" - } elseif { $delay >= 1000 } { - set delstr "[expr {$delay * .001}] ms" - } else { - set delstr "$delay us" - } - } else { - set delstr "" + set delayup [getLinkDelay $link up] + set jitter [getLinkJitter $link] + set jitterup [getLinkJitter $link up] + if { $jitter > 0 && $delay == "" } { set delay 0 } + if { $jitterup > 0 && $delayup == "" } { set delayup 0 } + if { $delayup > 0 || $jitterup > 0 } { + set delay [list $delay $delayup] + set jitter [list $jitter $jitterup] + set sep " / " + } + set i 0 + foreach d $delay { + if { $delaystr != "" } { set delaystr "$delaystr$sep" } + if { [lindex $jitter $i] != "" } { + set jstr " ($plusminus" + set jstr "$jstr[getSIMicrosecondValue [lindex $jitter $i]])" + } else { + set jstr "" + } + #set dstr "[getSIMicrosecondValue $d]" + #if { $dstr == "" && $jstr != "" } { set dstr "0 us" } + #set delaystr "$delaystr$dstr$jstr" + set delaystr "$delaystr[getSIMicrosecondValue $d]$jstr" + incr i + } + return $delaystr +} + +proc getSIMicrosecondValue { val } { + if { $val == "" } { + return "" + } + if { $val >= 10000 } { + return "[expr {$val / 1000}] ms" + } elseif { $val >= 1000 } { + return "[expr {$val * .001}] ms" + } else { + return "$val us" } - return $delstr } #****f* linkcfg.tcl/setLinkDelay @@ -354,9 +399,10 @@ proc setLinkDelay { link value } { global $link set i [lsearch [set $link] "delay *"] - if { $value <= 0 } { + if { [checkEmptyZeroValues $value] } { set $link [lreplace [set $link] $i $i] } else { + if { [llength $value] > 1 } { set value "{$value}" } set $link [lreplace [set $link] $i $i "delay $value"] } } @@ -374,11 +420,27 @@ proc setLinkDelay { link value } { # * BER -- The value of 1/BER of the link. #**** -proc getLinkBER { link } { +proc getLinkBER { link {dir "down"} } { global $link set entry [lsearch -inline [set $link] "ber *"] - return [lindex $entry 1] + set val [lindex $entry 1] ;# one or more values + if { $dir == "up" } { return [lindex $val 1] } + return [lindex $val 0] +} + +proc getLinkBERString { link } { + set ber [getLinkBER $link] + set berup [getLinkBER $link up] + if { $ber == "" && $berup == "" } { return "" } + set berstr "loss=" + if { $ber != "" } { + set berstr "$berstr$ber%" + } + if { $berup != "" } { + set berstr "$berstr / $berup%" + } + return $berstr } #****f* linkcfg.tcl/setLinkBER @@ -397,9 +459,13 @@ proc setLinkBER { link value } { global $link set i [lsearch [set $link] "ber *"] - if { $value <= 0 } { + if { [llength $value] > 1 && [lindex $value 0] <= 0 && \ + [lindex $value 1] <= 0 } { + set $link [lreplace [set $link] $i $i] + } elseif { $value <= 0 } { set $link [lreplace [set $link] $i $i] } else { + if { [llength $value] > 1 } { set value "{$value}" } set $link [lreplace [set $link] $i $i "ber $value"] } } @@ -417,11 +483,27 @@ proc setLinkBER { link value } { # * duplicate -- The percentage of the link packet duplicate value. #**** -proc getLinkDup { link } { +proc getLinkDup { link {dir "down"} } { global $link set entry [lsearch -inline [set $link] "duplicate *"] - return [lindex $entry 1] + set val [lindex $entry 1] ;# one or more values + if { $dir == "up" } { return [lindex $val 1] } + return [lindex $val 0] +} + +proc getLinkDupString { link } { + set dup [getLinkDup $link] + set dupup [getLinkDup $link up] + if { $dup == "" && $dupup == "" } { return "" } + set dupstr "dup=" + if { $dup != "" } { + set dupstr "$dupstr$dup%" + } + if { $dupup != "" } { + set dupstr "$dupstr / $dupup%" + } + return $dupstr } #****f* linkcfg.tcl/setLinkDup @@ -440,13 +522,29 @@ proc setLinkDup { link value } { global $link set i [lsearch [set $link] "duplicate *"] - if { $value <= 0 || $value > 50 } { + if { [checkEmptyZeroValues $value] } { set $link [lreplace [set $link] $i $i] } else { + if { [llength $value] > 1 } { set value "{$value}" } set $link [lreplace [set $link] $i $i "duplicate $value"] } } +# Returns true if link has unidirectional link effects, where +# upstream values may differ from downstream. +proc isLinkUni { link } { + set bw [getLinkBandwidth $link up] + set dl [getLinkDelay $link up] + set jt [getLinkJitter $link up] + set ber [getLinkBER $link up] + set dup [getLinkDup $link up] + if { $bw > 0 || $dl > 0 || $jt > 0 || $ber > 0 || $dup > 0 } { + return true + } else { + return false + } +} + #****f* linkcfg.tcl/getLinkMirror # NAME # getLinkMirror -- get link's mirror link @@ -588,7 +686,7 @@ proc mergeLink { link } { set mirror_link [getLinkMirror $link] if { $mirror_link == "" } { - puts "XXX mergeLink called for non-pseudo link!!!" + puts "error: mergeLink called for non-pseudo link" return } set link1_peers [linkPeers $link] @@ -836,25 +934,42 @@ proc linkByIfc { node ifc } { return [list $link $dir] } -# Boeing: jitter -proc getLinkJitter { link } { +proc getLinkJitter { link {dir "down"} } { global $link set entry [lsearch -inline [set $link] "jitter *"] - return [lindex $entry 1] + set val [lindex $entry 1] ;# one or more values + if { $dir == "up" } { return [lindex $val 1] } + return [lindex $val 0] } proc setLinkJitter { link value } { global $link set i [lsearch [set $link] "jitter *"] - if { $value <= 0 } { + if { [llength $value] <= 1 && $value <= 0 } { + set $link [lreplace [set $link] $i $i] + } elseif { [llength $value] > 1 && [lindex $value 0] <= 0 && \ + [lindex $value 1] <= 0 } { set $link [lreplace [set $link] $i $i] } else { + if { [llength $value] > 1 } { set value "{$value}" } set $link [lreplace [set $link] $i $i "jitter $value"] } } +# Check for empty or zero values in value. +# Value may be a single value or list where the first two values will be +# inspected; returns true for empty or zero values, false otherwise. +proc checkEmptyZeroValues { value } { + set isempty true + foreach v $value { + if { $v == "" } { continue } ;# this catches common case "{} {}" + if { $v > 0 } { set isempty false } + } + return $isempty +} + # get any type of link attribute proc getLinkOpaque { link key } { global $link