From 402c56ca535bced6565b3613ae9328c081e6f6d6 Mon Sep 17 00:00:00 2001 From: marko Date: Sun, 22 Jun 2008 23:29:45 +0000 Subject: [PATCH] Implement a simple discrete event scheduler to be used for node and link reconfiguration at predefined points in time. Bug found by: Submitted by: Reviewed by: Approved by: Obtained from: --- cfgparse.tcl | 48 +++++++++++++++- eventsched.tcl | 149 +++++++++++++++++++++++++++++++++++++++++++++++++ imunes.tcl | 7 ++- install.sh | 3 +- 4 files changed, 202 insertions(+), 5 deletions(-) create mode 100644 eventsched.tcl diff --git a/cfgparse.tcl b/cfgparse.tcl index ead9439..23edd77 100755 --- a/cfgparse.tcl +++ b/cfgparse.tcl @@ -26,7 +26,7 @@ # and Technology through the research contract #IP-2003-143. # -# $Id: cfgparse.tcl,v 1.39 2008/01/08 12:35:30 marko Exp $ +# $Id: cfgparse.tcl,v 1.40 2008/06/22 23:29:45 marko Exp $ #****h* imunes/cfgparse.tcl @@ -129,6 +129,14 @@ proc dumpCfg {method dest} { } } dumpputs $method $dest " \}" + } elseif { "[lindex $element 0]" == "events" } { + dumpputs $method $dest " events \{" + foreach line [lindex $element 1] { + if { $line != {} } { + dumpputs $method $dest " $line" + } + } + dumpputs $method $dest " \}" } else { dumpputs $method $dest " $element" } @@ -143,7 +151,17 @@ proc dumpCfg {method dest} { upvar 0 ::cf::[set ::curcfg]::$elem lelem dumpputs $method $dest "$obj $elem \{" foreach element $lelem { - dumpputs $method $dest " $element" + if { "[lindex $element 0]" == "events" } { + dumpputs $method $dest " events \{" + foreach line [lindex $element 1] { + if { $line != {} } { + dumpputs $method $dest " $line" + } + } + dumpputs $method $dest " \}" + } else { + dumpputs $method $dest " $element" + } } dumpputs $method $dest "\}" dumpputs $method $dest "" @@ -332,6 +350,19 @@ proc loadCfg { cfg } { canvas { lappend $object "canvas $value" } + events { + set cfg "" + foreach zline [split $value { +}] { + if { [string index "$zline" 0] == " " } { + set zline [string replace "$zline" 0 0] + } + set zline [string trim $zline] + lappend cfg $zline + } + set cfg [lrange $cfg 1 [expr {[llength $cfg] - 2}]] + lappend $object "events {$cfg}" + } } } elseif {"$class" == "link"} { switch -exact -- $field { @@ -359,6 +390,19 @@ proc loadCfg { cfg } { width { lappend $object "width $value" } + events { + set cfg "" + foreach zline [split $value { +}] { + if { [string index "$zline" 0] == " " } { + set zline [string replace "$zline" 0 0] + } + set zline [string trim $zline] + lappend cfg $zline + } + set cfg [lrange $cfg 1 [expr {[llength $cfg] - 2}]] + lappend $object "events {$cfg}" + } } } elseif {"$class" == "canvas"} { switch -exact -- $field { diff --git a/eventsched.tcl b/eventsched.tcl new file mode 100644 index 0000000..f1c0404 --- /dev/null +++ b/eventsched.tcl @@ -0,0 +1,149 @@ +# +# Copyright 2008 University of Zagreb, Croatia. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions +# are met: +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# THIS SOFTWARE IS PROVIDED BY AUTHOR AND CONTRIBUTORS ``AS IS'' AND +# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +# ARE DISCLAIMED. IN NO EVENT SHALL AUTHOR OR CONTRIBUTORS BE LIABLE +# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +# SUCH DAMAGE. +# + +# $Id: eventsched.tcl,v 1.1 2008/06/22 23:29:45 marko Exp $ + + +set sched_init_done 0 + +proc evsched {} { + global sched_init_done event_t0 eventqueue + + # XXX temp hack, init should be done when experiment is started + if { $sched_init_done == 0 } { + sched_init + } + + set curtime [expr [clock seconds] - $event_t0] + set changed 0 + set need_sort 1 + + foreach event $eventqueue { + set deadline [lindex $event 0] + if { $deadline > $curtime } { + break + } + + # Dequeue the current event + set eventqueue [lrange $eventqueue 1 end] + + set class [lindex $event 1] + set object [lindex $event 2] + set target [lindex $event 3] + set params [lrange $event 4 end] + + # XXX only constant values are supported + + if { $class == "node" } { + # XXX nothing implemented yet + } elseif { $class == "link" } { + if { [lindex $params 0] == "rand" } { + set lo [lindex $params 1] + set hi [lindex $params 2] + set next [expr $deadline + [lindex $params 3]] + set value [expr round($lo + ($hi - $lo) * rand())] + if { $next > $deadline } { + set nextev \ + [lsearch $eventqueue "* $class $object $target *"] + if { $nextev > -1 && \ + [lindex [lindex $eventqueue $nextev] 0] > $next } { + lappend eventqueue "$next [lrange $event 1 end]" + set need_sort 1 + } + } + } else { + set value [lindex $params 0] + } + switch -exact -- $target { + bandwidth { + setLinkBandwidth $object $value + } + delay { + setLinkDelay $object $value + } + ber { + setLinkBER $object $value + } + duplicate { + setLinkDup $object $value + } + color { + setLinkColor $object $value + } + } + #execSetLinkParams $eid $object + set changed 1 + } + } + + if { $changed == 1 } { + redrawAll + } + + if { $need_sort == 1 } { + set eventqueue [lsort -index 0 -integer $eventqueue] + } + + after 1000 evsched +} + + +proc sched_init {} { + upvar 0 ::cf::[set ::curcfg]::node_list node_list + upvar 0 ::cf::[set ::curcfg]::link_list link_list + global sched_init_done + global eventqueue event_t0 + + set eventqueue {} + + foreach link $link_list { + set evlist [getLinkEvents $link] + foreach event $evlist { + lappend eventqueue \ + "[lindex $event 0] link $link [lrange $event 1 end]" + } + } + + foreach node $node_list { + set evlist [getLinkEvents $node] + foreach event $evlist { + lappend eventqueue \ + "[lindex $event 0] node $node [lrange $event 1 end]" + } + } + + set eventqueue [lsort -index 0 -integer $eventqueue] + + set sched_init_done 1 + set event_t0 [clock seconds] +} + + +proc getLinkEvents { link } { + upvar 0 ::cf::[set ::curcfg]::$link $link + + set entry [lsearch -inline [set $link] "events *"] + return [lindex $entry 1] +} diff --git a/imunes.tcl b/imunes.tcl index f86e900..29a130c 100755 --- a/imunes.tcl +++ b/imunes.tcl @@ -26,7 +26,7 @@ # and Technology through the research contract #IP-2003-143. # -# $Id: imunes.tcl,v 1.36 2008/01/08 14:21:00 marko Exp $ +# $Id: imunes.tcl,v 1.37 2008/06/22 23:29:45 marko Exp $ #****h* imunes/imunes.tcl @@ -101,6 +101,7 @@ if { $ROOTDIR == "." } { set BINDIR "bin" } +source "$ROOTDIR/$LIBDIR/canvas.tcl" source "$ROOTDIR/$LIBDIR/linkcfg.tcl" source "$ROOTDIR/$LIBDIR/nodecfg.tcl" source "$ROOTDIR/$LIBDIR/ipv4.tcl" @@ -108,7 +109,7 @@ source "$ROOTDIR/$LIBDIR/ipv6.tcl" source "$ROOTDIR/$LIBDIR/ipsec.tcl" source "$ROOTDIR/$LIBDIR/cfgparse.tcl" source "$ROOTDIR/$LIBDIR/exec.tcl" -source "$ROOTDIR/$LIBDIR/canvas.tcl" +source "$ROOTDIR/$LIBDIR/eventsched.tcl" source "$ROOTDIR/$LIBDIR/quagga.tcl" source "$ROOTDIR/$LIBDIR/xorp.tcl" @@ -253,6 +254,8 @@ if {$execMode == "interactive"} { updateProjectMenu # Fire up the animation loop animate + # Event scheduler - should be started / stopped on per-experiment base? + evsched } else { if {$argv != ""} { set fileId [open $argv r] diff --git a/install.sh b/install.sh index 220bbf9..f38cacc 100755 --- a/install.sh +++ b/install.sh @@ -26,7 +26,8 @@ lib_files="nodecfg.tcl linkcfg.tcl cfgparse.tcl ipv4.tcl ipv6.tcl exec.tcl \ canvas.tcl editor.tcl filemgmt.tcl help.tcl initgui.tcl \ copypaste.tcl quagga.tcl xorp.tcl static.tcl pc.tcl host.tcl \ lanswitch.tcl rj45.tcl hub.tcl ns2imunes.tcl ipsec.tcl \ - topogen.tcl annotations.tcl gpgui.tcl graph_partitioning.tcl" + topogen.tcl annotations.tcl gpgui.tcl graph_partitioning.tcl \ + eventsched.tcl" tiny_icons="oval.gif delete.gif frswitch.gif host.gif hub.gif \ lanswitch.gif link.gif pc.gif rectangle.gif rj45.gif \ -- 2.39.5