Concept edit
So basically I wanted to build a construct that would allow....when {[thing2 get temperature] > 100} do {thing1 set alarm on}So we need a few things in order for this to work...- to know when the underlying temperature variable that the 'thing2 get temperature' ensemble is modified.
- to know when interest is expressed in that variable at the time the callback is created. (when processing the when...do created by the user)
- to be able to easily guarantee the values which we may want to be using as constraints will actually match criteria (so that alarm is not set to yes. (this is a little more of my preference than an actual requirement. It just seems more tidy if this were possible.)
subjectLogicObserver.tcl
package provides subjectLogicObserver 0.1
# TODO:
# -- Write Handler for destruction of a variable
# -- Write Handler for array (hashtable) modification.
# -- Add expression result cache to prevent calculation of something
# which hasn't changed. Need some way to track invalidation of cache
# entries.. (there is a point where this is noted below)
# COMPLETED:
# -- Add dependency management (preferably with TCL's internal package require)
# so that when-do's will not be evaluated for 'expressesInterest' until the
# dependent objects/variable traces have been created and traces set.
# *** COMPLETED: Added afterIdle_whenDo
# -- Add subject type enforcement (as defined with where commands...)
# *** COMPLETED: Added 'where ... in' and 'where ... is' ensembles.
# NOTES: Currently this implementation only watches subjects as individual keys
# in an array and scalar subjects... will be adding full array support
# in the near future.
namespace eval ::esos::where {
namespace export in between is
namespace ensemble create -command ::where -parameters var
proc in {var list {{?do?} {}} {{?script?} {}}} {
if {[string length ${?do?}] == 0 && [string length ${?script?}] == 0} {
return [expr {[lsearch $list $var] > -1}]
}
set varname [lindex [info level 0] 1]
set matches [lsearch -all -inline $list $var]
#perform foreach on matching items in list
if {${?do?} == "do"} {
tailcall foreach {*}[list $varname $matches ${?script?}]
}
#shortcut ... for foreach on matching items in list without 'do' in command
if {[string length ${?do?}] > 0} {
tailcall foreach {*}[list $varname $matches ${?script?}]
}
}
#
# simple invocation (need to work out some specifics on implementation above)
proc in {var list} {
return [expr [lsearch $list $var] > -1]
}
proc between {var lowerbound upperbound} {
set argcount 0
set syntax {should be "where var between lowerbound upperbound"}
foreach v [list var lowerbound upperbound] {
incr argcount [string is double [set $v]]
}
if {$argcount != 3} {
return -code error [format {expected numeric values: %s} $syntax]
}
return expr [expr {$var < $upperbound && $var > $lowerbound}]
}
proc is {var type} {
return [string is $type $var]
}
}
namespace eval ::esos::subjectLogicObserver {
namespace export when subject
namespace ensemble create -command ::subject -map [list create [namespace current]::create]
namespace ensemble create -command ::when -map [list do [namespace current]::afterIdle_whenDo] -parameters expr
# subject is watched varable..
# priority should be weight of expr dependancy complexity
# bump priority based on quantity of times callback gets scheduled
# value is {expression priority callback}
variable conditionMap
variable subjectConstraint
variable SubjectValues
variable LOGFD
variable LOGFILE
variable DEBUG
array set subjectConstraint {}
array set SubjectValues {}
#### TODO: REPLACE DEBUGGING/LOG PROCEDURE BELOW WITH GENERIC FACILITY.
#ENABLE/DISABLE DEBUGGING OUTPUT
set DEBUG false
set LOGFILE {}
if {$LOGFILE == {}} {
proc log {args} {
puts stderr [join $args { }]
}
} else {
set LOGFD [open $LOGFILE w+]
proc log {args} [format {
puts %s [join $args { }]
} $LOGFD]
}
if {[info exists DEBUG] && $DEBUG} {
proc debug {args} {
set caller(logtype) [lindex $args 0]
array set caller [info frame -1]
set caller(message) [format {%s @ line %s: %s} \
$caller(proc) $caller(line) $args]
puts $caller(message)
}
} else {
proc debug {args} {
return
}
}
}
## HELPER PROCS ################################################################
# gets caller info from parent's parent frame
proc ::esos::subjectLogicObserver::callerinfo {arrayName} {
debug updating $arrayName
upvar $arrayName result
foreach {k v} [info frame -2] {
set result(caller$k) $v
}
}
# fully qualify the subject and determine if scalar or array (hash table)...
proc ::esos::subjectLogicObserver::qualifySubject {subjectName subjectKey} {
if {"$subjectKey" == ""} {
debug derived subject:$subjectName
set subject [uplevel 2 [list namespace which -variable $subjectName]]
} {
debug derived subject:$subjectName\($subjectKey\)
set subject [uplevel 2 [list namespace which -variable $subjectName]\($subjectKey\)]
}
}
# validate constraint
proc ::esos::subjectLogicObserver::validateConstraint {subject} {
variable subjectConstraint
debug entered...
set namespace [namespace qualifiers $subject]
debug namespace inscope $namespace $subjectConstraint($subject)
return [namespace inscope $namespace $subjectConstraint($subject)]
}
## IMPLEMENTATION PROCS ########################################################
proc ::esos::subjectLogicObserver::create {args} {
debug entered...
variable subjectConstraint
variable SubjectValues
set syntax {wrong # args: "subject create subjectName constraint ... ?subjectName constraint?"}
set arglen [llength $args]
# must supply argument
if {$arglen < 1} { return -code error $argserr }
# multiple args are binary tupples of {event contraint}
if {$arglen > 1} {
# must be divisible by 2
if {[llength $args] % 2 == 1} { return -code error $argserr }
} else {
# single arg container of tupples of {event constraint}
set args [lindex $args 0]
}
set subjectNamespace [uplevel {namespace current}]
foreach {subjectName constraint} $args {
#############################################
# ALWAYS FULLY QUALIFY SUBJECT AND CALLBACK #
#############################################
# fully qualify subject variable.
set subject [set subjectNamespace]::[set subjectName]
# create the subject (traced variable) in the correct namespace
set $subject [list]
# create shadow variable for storing last good value
set SubjectValues($subject) {}
debug subject shadow variable local storage: $subject -> SubjectValues($subject)
set subjectConstraint($subject) $constraint
debug constraint bound to subject: $constraint
debug '$subject' subject variable created...
# observer "creates" with to watch subject through the
# execution of the expression (which will trigger the
# following trace when the variable is read
trace add variable $subject read [namespace current]::subjectObserver_expressesInterest
debug subject $subject trace reads -> [namespace current]::subjectObserver_expressesInterest
# evaluate callbacks when object written to.
trace add variable $subject write [namespace current]::subjectChanged_Handler
debug subject $subject trace writes -> [namespace current]::subjectChanged_Handler
# deal with out of band destruction of subject
trace add variable $subject unset [namespace current]::subjectUnset_Handler
debug subject $subject trace unsets -> [namespace current]::subjectUnset_Handler
# deal with out of band modification of subject via 'array' command
trace add variable $subject array [namespace current]::subjectArraymod_Handler
debug subject $subject trace array events -> [namespace current]::subjectArraymod_Handler
}
}
# this executes the expr on behalf of the createing observer
# kickstarting the registration process when the trace fires as
# the subject variable event triggers are read. Now anytime the
# publishing service writes to the variable, the trace executes
# evaluating any interested parties' expression to determine
# if we should schedule the callback for execution.
#
# the real beauty in this approach is we can use complex logic
# that just relies on the subjects in the observer or are even
# obscured by the subject publisher with procs that rely on
# the subject variables. This should be extremely scalable and
# quite user friendly as the service developer shouldn't have
# to think about anything beyond writing a boolean expression
# which when true runs a defined callback.
proc ::esos::subjectLogicObserver::whenDo {expr script} {
debug evaluating when $expr -> $script
# run the expression and pass exception, to help identify
# interested observers.
if {[catch [list expr $expr] res]} {
return -code error $res
}
debug evaluation completed successfully with $res.
}
# This is the public facing implementation of the whenDo
# procedure above. This simply waits until the system has
# become idle to begin processing 'when...do' statements as we
# want to make sure any codependant subjects we will be
# watching will have the opportunity to set themselves up.
proc ::esos::subjectLogicObserver::afterIdle_whenDo {expr script} {
debug evaluating when $expr -> $script
after idle [list [namespace current]::whenDo $expr $script]
}
# looks through stack frames to see if this is ran from within the
# 'when-do' command. This is how we implicitly determine the
# expression's dependancy on a particular subject (traced variable).
#
# note: this is executed anytime a variable is read which could be expensive.
# It might be worthwhile to find areas of this proc that can be improved
# if performance is a bottleneck.
proc ::esos::subjectLogicObserver::subjectObserver_expressesInterest {subjectName subjectKey op args} {
debug args:$subjectName $subjectKey $args
variable conditionMap
set namespace [namespace current]
set subject [qualifySubject $subjectName $subjectKey]
debug interest expressed in $subject
#traverse the stack for 'whenDo'
for {set level 1} \
{![catch {set frameproc [dict get [info frame -$level] proc]} res]} \
{ incr level } {
debug searching stack $level: $frameproc
if {"$frameproc" == "[set namespace]::whenDo"} {
debug level:$level $frameproc found...
# link to variables in whenDo frame so we can store
# expr and callback in conditionMap
upvar $level expr expr script callback
lappend conditionMap($subject) $expr $callback
debug updated conditionMap\($subject\) $expr $callback
# bail out.. we don't need to finish searching the stack
return
}
}
}
# anytime a subject is modified, call this callback so we can update any
# interested parties.
proc ::esos::subjectLogicObserver::subjectChanged_Handler {subjectName subjectKey op args} {
variable conditionMap
variable subjectValues
set subject [qualifySubject $subjectName $subjectKey]
upvar $subject subjectValue
debug "'[lindex [info level 1] 0]' modified $subject -> '$subjectValue'"
# constraint not met, return variable to previous state.
if {![validateConstraint $subject]} {
debug constraint failed when attempting to set $subject -> $subjectValue, $subject := $subjectValues($subject)
set subjectValue $subjectValues($subject)
return -code ok
}
debug constraint checked
set subjectValues($subject) $subjectValue
# if we have issues below, make sure that when multiple conditions show up we
# are handlnig them correctly.. lindex maybe a janky way to drop the
# subjectName from the response of 'array get' but the advantage of using
# 'array get' is it returns nothing if nothing is found, as opposed to using
# the sugar var '$conditionMap($subjectName)' results in an exception when
# there is no matching key in the hashtable.
foreach {expr callback} [lindex [array get conditionMap $subject] 1] {
set namespace [namespace qualifiers $subject]
# NOTE: If there were some sort of expression eval cache, and we arrived at
# this point, the entry would now be invalid as a supporting component
# has been changed. Reevaluate procedures within expression that have
# changed and evaluate resultant expression. (this is not implemented
# and is just a note for a possible future scalability/performance
# improvement opportunity.)
# debug change invalidates expr: $expr, reevaluating.
debug callback: $callback
if {[expr $expr]} {
# This expr is now true, schedule callback.
after idle [list namespace inscope $namespace $callback]
debug $expr is now true: callback scheduled for execution $callback
}
}
# allow pending events to proceed.
tailcall update
}
proc ::esos::subjectLogicObserver::subjectUnset_Handler {subjectName subjectKey op args} {
variable conditionMap
set subject [qualifySubject $subjectName $subjectKey]
# TODO: WRITE HANDLER FOR UNSET TRACE.... Not sure if this is needed yet.
}
proc ::esos::subjectLogicObserver::subjectArraymod_Handler {subjectName subjectKey op args} {
variable conditionMap
set subject [qualifySubject $subjectName $subjectKey]
# TODO: WRITE HANDLER FOR ARRAY MODIFICATION TRACE.... Not sure if this is needed yet.
}
# Sample Implentation
namespace eval ::thing1 {
namespace export extern_*
namespace ensemble create -map [list set [namespace current]::extern_set get [namespace current]::extern_get]
subject create {
pressure {where $pressure is double}
status {where $status in {stopped starting running stopping}}
alarm {where $alarm is boolean}
}
when {[thing2 get temperature] > 100} do {
puts stderr {!WARNING! thing2 IS GETTING TOO HOT, TURNING DOWN PRESSURE!}
thing1 set pressure 100
}
proc extern_set {varname value} {
variable $varname
set $varname $value
}
proc extern_get {varname} {
variable $varname
return [set $varname]
}
}
namespace eval ::thing2 {
namespace export extern_*
namespace ensemble create -map [list set [namespace current]::extern_set get [namespace current]::extern_get]
subject create {
temperature {where $temperature is double}
watchdog {where $watchdog is wideinteger}
text {where $text is print}
}
proc extern_set {varname value} {
variable $varname
set $varname $value
}
proc extern_get {varname} {
variable $varname
return [set $varname]
}
}
# must call update in order to allow tclsh's event-loop to process idle events.
update
% thing2 set temperature 150
!WARNING! thing2 IS GETTING TOO HOT, TURNING DOWN PRESSURE!
150
I know at face value this seems like this is just a really long way to call a procedure, but I believe if you experiment with creating your code in such a way that you're just defining conditions in which code should run, we can create some very interesting implementations of state machines, servers or interfaces in general. Anyways.. thoughts, ideas, fixes are definately welcome.**Circular References** -- Resolved by delaying whenDo with afterIdle_whenDoxk2600 So I'm trying to evaluate the best way to handle circular references.... thanks to dkf for some assistance on #tcl. He noted that circular references should automatically resolved if you use the 'package provides/requires' constructs. The issue I'm running into is that the codependency between thing1 and thing2 presents itself when we eval the expression defined in the when statement of thing2.I believe when I call package require thing1, it evaluates thing1.tcl which has a package require for thing2 at the top (evaluating thing2.tcl) when 'subjectLogicObserver::when_do' is called as the namespace for thing2 is being executed, thing1 has not had the opportunity to create it's ensemble yet. I'm seeking ideas on how best to manage this scenario in a uniform (and TCL common) way so I can present this construct to the community extending the usability to TCL in a very event driven (and TCL linguistic) way.
thing1.tcl
package provide thing1 1.0
package require subjectLogicObserver
package require thing2
namespace eval ::thing1 {
namespace export extern_*
namespace ensemble create -map [list set [namespace current]::extern_set get [namespace current]::extern_get]
subject create {
pressure {where $pressure is double}
status {where $status in {stopped starting running stopping}}
alarm {where $alarm is boolean}
}
when {[thing2 get temperature] > 100} do {
puts stderr {!WARNING! thing2 IS GETTING TOO HOT, TURNING DOWN PRESSURE!}
thing1 set pressure 100
}
proc extern_set {varname value} {
variable $varname
set $varname $value
}
proc extern_get {varname} {
variable $varname
return [set $varname]
}
}thing2.tcl
package provide thing2 1.0
package require subjectLogicObserver
package require thing1
namespace eval ::thing2 {
namespace export extern_*
namespace ensemble create -map [list set [namespace current]::extern_set get [namespace current]::extern_get]
subject create {
temperature {where $temperature is double}
watchdog {where $watchdog is wideinteger}
text {where $text is print}
}
when {[thing1 get pressure] > 500} do {
puts stderr {!WARNING! thing1 IS OVER PRESSURE, TURNING DOWN TEMPERATURE!}
thing2 set temperature [expr {[thing2 get temperature] - 1}]
}
proc extern_set {varname value} {
variable $varname
set $varname $value
}
proc extern_get {varname} {
variable $varname
return [set $varname]
}
}pkgIndex.tcl (generated via pkg_mkIndex [pwd])
# Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. package ifneeded subjectLogicObserver 0.1 [list source [file join $dir subjectLogicObserver.tcl]] package ifneeded thing 1.0 [list source [file join $dir thing.tcl]] package ifneeded thing1 1.0 [list source [file join $dir thing1.tcl]] package ifneeded thing2 1.0 [list source [file join $dir thing2.tcl]]
showcasing circular dependency problem:
# set TCLLIBPATH=" . /usr/lib /usr/local/lib /usr/local/lib/tcl8.6" # tclsh % package require thing1 invalid command name "thing1"Options I'm evaluating to possibly resolve this issue:
- in 'subjectLogicObserver::when_do' catch the error, and delay execution with 'after idle'
- seems the most straight forward, however it lends itself to complicating a fairly simple implementation thus far.
- build a construct to more directly trace the future calls and variables which are contained within the expr in 'when {expr} do {...}' and build a dependency map to explicitly verify all dependencies are met.
- utilize possible ways TCL has introspection into the package evaluation/dependency process to know whether the necessary dependencies have been met.
