source: trunk/p2p/statemachine.tcl @ 4503

Last change on this file since 4503 was 3177, checked in by mmc, 8 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.

File size: 7.5 KB
Line 
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# ======================================================================
11#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
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# ======================================================================
16package require Itcl
17
18# ======================================================================
19#  CLASS: StateMachine
20# ======================================================================
21itcl::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# ----------------------------------------------------------------------
49itcl::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# ----------------------------------------------------------------------
87itcl::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# ----------------------------------------------------------------------
123itcl::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# ----------------------------------------------------------------------
188itcl::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}
Note: See TracBrowser for help on using the repository browser.