[1273] | 1 | # ---------------------------------------------------------------------- |
---|
| 2 | # LIBRARY: statemachine |
---|
| 3 | # |
---|
| 4 | # This object comes in handy when building the state machines that |
---|
| 5 | # drive the behavior of clients and servers in the peer-to-peer system. |
---|
| 6 | # Each state machine has a number of recognized states and trasitions |
---|
| 7 | # between the states that kick off actions within the system. |
---|
| 8 | # ---------------------------------------------------------------------- |
---|
| 9 | # Michael McLennan (mmclennan@purdue.edu) |
---|
| 10 | # ====================================================================== |
---|
[3177] | 11 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
---|
[1273] | 12 | # |
---|
| 13 | # See the file "license.terms" for information on usage and |
---|
| 14 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 15 | # ====================================================================== |
---|
| 16 | package require Itcl |
---|
| 17 | |
---|
| 18 | # ====================================================================== |
---|
| 19 | # CLASS: StateMachine |
---|
| 20 | # ====================================================================== |
---|
| 21 | itcl::class StateMachine { |
---|
| 22 | private variable _states ;# maps states to -enter/-leave commands |
---|
| 23 | private variable _trans ;# maps s1->s2 transitions to commands |
---|
| 24 | private variable _current "" |
---|
| 25 | private variable _slots ;# maps statedata name => value |
---|
| 26 | private variable _intrans 0 |
---|
| 27 | |
---|
| 28 | constructor {args} { |
---|
| 29 | eval configure $args |
---|
| 30 | set _states(all) "" |
---|
| 31 | } |
---|
| 32 | |
---|
| 33 | public method state {name options} |
---|
| 34 | public method transition {name options} |
---|
| 35 | public method current {} { return $_current } |
---|
| 36 | public method all {} { return $_states(all) } |
---|
| 37 | public method goto {state} |
---|
| 38 | public method statedata {args} |
---|
| 39 | } |
---|
| 40 | |
---|
| 41 | # ---------------------------------------------------------------------- |
---|
| 42 | # USAGE: state <name> ?-option value -option value ...? |
---|
| 43 | # |
---|
| 44 | # Defines a new state in the state machine. Recognizes the following |
---|
| 45 | # options: |
---|
| 46 | # -onenter ... command invoked when state is entered |
---|
| 47 | # -onleave ... command invoked when state is left |
---|
| 48 | # ---------------------------------------------------------------------- |
---|
| 49 | itcl::body StateMachine::state {name args} { |
---|
| 50 | array set options { |
---|
| 51 | -onenter "" |
---|
| 52 | -onleave "" |
---|
| 53 | } |
---|
| 54 | foreach {key val} $args { |
---|
| 55 | if {![info exists options($key)]} { |
---|
| 56 | error "bad option \"$key\": should be [join [lsort [array names options]] {, }]" |
---|
| 57 | } |
---|
| 58 | set options($key) $val |
---|
| 59 | } |
---|
| 60 | |
---|
| 61 | if {![regexp {^[-a-zA-Z0-9_]+$} $name]} { |
---|
| 62 | error "bad state name \"$name\": should be alphanumeric, including - or _" |
---|
| 63 | } |
---|
| 64 | |
---|
| 65 | if {[lsearch $_states(all) $name] >= 0} { |
---|
| 66 | error "state \"$name\" already defined" |
---|
| 67 | } |
---|
| 68 | lappend _states(all) $name |
---|
| 69 | set _states($name-onenter) $options(-onenter) |
---|
| 70 | set _states($name-onleave) $options(-onleave) |
---|
| 71 | |
---|
| 72 | # start in the first state by default |
---|
| 73 | if {$_current == ""} { |
---|
| 74 | goto $name |
---|
| 75 | } |
---|
| 76 | return $name |
---|
| 77 | } |
---|
| 78 | |
---|
| 79 | # ---------------------------------------------------------------------- |
---|
| 80 | # USAGE: transition <name> ?-option value -option value ...? |
---|
| 81 | # |
---|
| 82 | # Defines the transition from one state to another. The transition |
---|
| 83 | # <name> should be of the form "s1->s2", where "s1" and "s2" are |
---|
| 84 | # recognized state names. Recognizes the following options: |
---|
| 85 | # -onchange ... command invoked when transition is followed |
---|
| 86 | # ---------------------------------------------------------------------- |
---|
| 87 | itcl::body StateMachine::transition {name args} { |
---|
| 88 | array set options { |
---|
| 89 | -onchange "" |
---|
| 90 | } |
---|
| 91 | foreach {key val} $args { |
---|
| 92 | if {![info exists options($key)]} { |
---|
| 93 | error "bad option \"$key\": should be [join [lsort [array names options]] {, }]" |
---|
| 94 | } |
---|
| 95 | set options($key) $val |
---|
| 96 | } |
---|
| 97 | |
---|
| 98 | if {![regexp {^([-a-zA-Z0-9_]+)->([-a-zA-Z0-9_]+)$} $name match state1 state2]} { |
---|
| 99 | error "bad transition name \"$name\": should have the form s1->s2" |
---|
| 100 | } |
---|
| 101 | if {[lsearch $_states(all) $state1] < 0} { |
---|
| 102 | error "unrecognized starting state \"$state1\" for transition" |
---|
| 103 | } |
---|
| 104 | if {[lsearch $_states(all) $state2] < 0} { |
---|
| 105 | error "unrecognized ending state \"$state2\" for transition" |
---|
| 106 | } |
---|
| 107 | |
---|
| 108 | set _trans($state1->$state2-onchange) $options(-onchange) |
---|
| 109 | return $name |
---|
| 110 | } |
---|
| 111 | |
---|
| 112 | # ---------------------------------------------------------------------- |
---|
| 113 | # USAGE: goto <name> |
---|
| 114 | # |
---|
| 115 | # Forces the state machine to undergo a transition from the current |
---|
| 116 | # state to the new state <name>. If the current state has a -onleave |
---|
| 117 | # hook, it is executed first. If there is a transition between the |
---|
| 118 | # states with a -onchange hook, it is executed next. If the new |
---|
| 119 | # state has a -onenter hook, it is executed last. If any of the |
---|
| 120 | # command hooks along the way fail, then the state machine will |
---|
| 121 | # drop back to its current state and return the error. |
---|
| 122 | # ---------------------------------------------------------------------- |
---|
| 123 | itcl::body StateMachine::goto {state} { |
---|
| 124 | if {$_intrans} { |
---|
| 125 | error "can't change states while making a transition" |
---|
| 126 | } |
---|
| 127 | |
---|
| 128 | # |
---|
| 129 | # NOTE: Use _'s for all local variables in this routine. We eval |
---|
| 130 | # the code fragments or -onenter, -onleave, -onchange directly |
---|
| 131 | # in the context of this method. This keeps them from polluting |
---|
| 132 | # the global scope and gives them access to the "statedata" |
---|
| 133 | # method. But it could have side effects if the code fragments |
---|
| 134 | # accidentally redefined local variables. So start all local |
---|
| 135 | # variables with _ to avoid any collisions. |
---|
| 136 | # |
---|
| 137 | set _sname $state |
---|
| 138 | |
---|
| 139 | if {[lsearch $_states(all) $_sname] < 0} { |
---|
| 140 | error "bad state name \"$_sname\": should be one of [join [lsort $_states(all)] {, }]" |
---|
| 141 | } |
---|
| 142 | set _intrans 1 |
---|
| 143 | |
---|
| 144 | # execute any -onleave hook for the current state |
---|
| 145 | set _goback 0 |
---|
| 146 | if {"" != $_current && "" != $_states($_current-onleave)} { |
---|
| 147 | if {[catch $_states($_current-onleave) _result]} { |
---|
| 148 | set _goback 1 |
---|
| 149 | } |
---|
| 150 | } |
---|
| 151 | |
---|
| 152 | # execute any -onchange hook for the transition |
---|
| 153 | if {!$_goback && [info exists _trans($_current->$_sname-onchange)]} { |
---|
| 154 | if {[catch $_trans($_current->$_sname-onchange) _result]} { |
---|
| 155 | set _goback 1 |
---|
| 156 | } |
---|
| 157 | } |
---|
| 158 | |
---|
| 159 | # execute any -onenter hook for the new state |
---|
| 160 | if {!$_goback && "" != $_states($_sname-onenter)} { |
---|
| 161 | if {[catch $_states($_sname-onenter) _result]} { |
---|
| 162 | set _goback 1 |
---|
| 163 | } |
---|
| 164 | } |
---|
| 165 | |
---|
| 166 | if {$_goback} { |
---|
| 167 | if {"" != $_current && "" != $_states($_current-onenter)} { |
---|
| 168 | catch $_states($_current-onenter) |
---|
| 169 | } |
---|
| 170 | set _intrans 0 |
---|
| 171 | error $_result "$_result\n (while transitioning from $_current to $_sname)" |
---|
| 172 | } |
---|
| 173 | |
---|
| 174 | set _intrans 0 |
---|
| 175 | set _current $_sname |
---|
| 176 | return $_current |
---|
| 177 | } |
---|
| 178 | |
---|
| 179 | # ---------------------------------------------------------------------- |
---|
| 180 | # USAGE: statedata ?<name>? ?<value>? |
---|
| 181 | # |
---|
| 182 | # Used to get/set special data values stored within the state |
---|
| 183 | # machine. These are like local variables, but can be shared |
---|
| 184 | # across the code fragments associated with states and transitions. |
---|
| 185 | # We could also use global variables for this, but this allows |
---|
| 186 | # each state machine to store its own values. |
---|
| 187 | # ---------------------------------------------------------------------- |
---|
| 188 | itcl::body StateMachine::statedata {args} { |
---|
| 189 | switch [llength $args] { |
---|
| 190 | 0 { |
---|
| 191 | return [array get _slots] |
---|
| 192 | } |
---|
| 193 | 1 { |
---|
| 194 | set name [lindex $args 0] |
---|
| 195 | if {[info exists _slots($name)]} { |
---|
| 196 | return $_slots($name) |
---|
| 197 | } |
---|
| 198 | return "" |
---|
| 199 | } |
---|
| 200 | 2 { |
---|
| 201 | set name [lindex $args 0] |
---|
| 202 | set value [lindex $args 1] |
---|
| 203 | set _slots($name) $value |
---|
| 204 | return $value |
---|
| 205 | } |
---|
| 206 | default { |
---|
| 207 | error "wrong # args: should be \"statedata ?name? ?value?\"" |
---|
| 208 | } |
---|
| 209 | } |
---|
| 210 | } |
---|