diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2018-09-08 12:52:06 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2018-09-08 12:52:06 (GMT) |
| commit | 0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd (patch) | |
| tree | b34e93b062e415da30654cadb67c57ffb11791f5 /generic/tclOOScript.tcl | |
| parent | 4b7caf2e4a373d2616cc7d4f3d05566bd1588b6d (diff) | |
| download | tcl-0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd.zip tcl-0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd.tar.gz tcl-0d73b8a7c0c6e90b6c3ed7fcde7b69916b23bedd.tar.bz2 | |
Implementation of TIP 516
Diffstat (limited to 'generic/tclOOScript.tcl')
| -rw-r--r-- | generic/tclOOScript.tcl | 39 |
1 files changed, 36 insertions, 3 deletions
diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl index d3706ce..30af82a 100644 --- a/generic/tclOOScript.tcl +++ b/generic/tclOOScript.tcl @@ -276,6 +276,20 @@ # ------------------------------------------------------------------ # + # Slot Resolve -- + # + # Helper that lets a slot convert a list of arguments of a + # particular type to their canonical forms. Defaults to doing + # nothing (suitable for simple strings). + # + # ------------------------------------------------------------------ + + method Resolve list { + return $list + } + + # ------------------------------------------------------------------ + # # Slot -set, -append, -clear, --default-operation -- # # Standard public slot operations. If a slot can't figure out @@ -283,12 +297,31 @@ # # ------------------------------------------------------------------ - method -set args {tailcall my Set $args} + method -set args { + set args [uplevel 1 [list [namespace which my] Resolve $args]] + tailcall my Set $args + } method -append args { - set current [uplevel 1 [list [namespace which my] Get]] + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] tailcall my Set [list {*}$current {*}$args] } method -clear {} {tailcall my Set {}} + method -prepend args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$args {*}$current] + } + method -remove args { + set my [namespace which my] + set args [uplevel 1 [list $my Resolve $args]] + set current [uplevel 1 [list $my Get]] + tailcall my Set [lmap val $current { + if {$val in $args} continue else {set val} + }] + } # Default handling forward --default-operation my -append @@ -303,7 +336,7 @@ } # Set up what is exported and what isn't - export -set -append -clear + export -set -append -clear -prepend -remove unexport unknown destroy } |
