[FM] Using TclOO to create "typed lists"
======
oo::class create typedlist {
constructor {args} {
my variable Liste
my variable Type
my variable counter -1
if {[lindex $args 1] eq "-namespace"} {
set namespace [lindex $args 2] uplevel [list namespace eval ::$namespace {}]
set List [lindex $args 0]
} else {
set namespace []
set Liste $args
}
set i [string last : [namespace tail [self]]]
set Type [string range [namespace tail [self]] 0 $i-1]
oo::objdefine [self] [subst {
method unknown {args} {
my variable counter typedlist create [list [self]]:\[incr counter\] {*}\$args
}
}]
}
method append {index args} {
my variable Liste
set e [lindex $Liste $index]
lset Liste $index [append e {*}$args]
}
method get {} {
my variable Liste
return $Liste
}
method lappend {args} {
my variable Liste
lappend Liste {*}$args
}
method replace {debut fin args} {
my variable Liste
typedlist::nettoyer $Liste $debut $fin
return [set Liste [lreplace $Liste $debut $fin {*}$args]]
}
method search {args} {
my variable Liste
set pattern [lindex $args end]
return [lsearch {*}[lrange $args 0 end-1] $Liste $pattern]
}
method type {} {
my variable Type
return $Type
}
method transmute {type} {
my variable Liste
if {[info object class $type] eq "::typedlist"} {
set new [$type -- {*}$Liste]
after idle [list [self] destroy]
return $new
}
}
method -- {args} {
my variable counter
typedlist create [self]:[incr counter] {*}$args
}
export --
}
======
# Some additionals tools
======
namespace eval typedlist {}
======
# recreate a script from a typedlist
======
proc ::typedlist::scriptifier {Typed} {
set L []
set T []
if {[info object isa object $Typed] && [info object class $Typed] eq "::typedlist"} {
foreach e [$Typed get] {
append L \ [::typedlist::scriptifier $e]
}
append T [$Typed type] \ -- \
} else {
set L \{$Typed\}
set T []
return ${T}${L}
}
return \[$T$L\]
}
======
# test if the object is a typedlist
======
proc ::typedlist::is {T} {
if {[info object isa object $T] \
&& [info object class $T] eq "::typedlist"} {
return 1
} else {
return 0
}
}
======
# equality test between two typedlist
======
proc ::typedlist::eq {L1 L2} {
set res 0
if {[::typedlist::is $L1] && [::typedlist::is $L2]} {
if {[$L1 type] eq [$L2 type]} {
foreach l1 [$L1 get] l2 [$L2 get] {
set res [::typedlist::eq $l1 $l2]
}
}
} elseif {![::typedlist::is $L1] && ![::typedlist::is $L2]} {
if {$L1 eq $L2} {
set res 1
}
}
return $res
}
======
# clean-up tool
======
proc ::typedlist::nettoyer {Typed {debut {0}} {fin {end}}} {
set L [list]
if {[::typedlist::is $Typed]} {
foreach e [lrange [$Typed get] $debut $fin] {
::typedlist::nettoyer $e
if {[catch {$e destroy} err]} {
puts stderr "erreur lors de la destruction de la liste $e,
procédure : ::typedlist::nettoyer $Typed
message : $err"
}
}
}
return
}
package provide typedlist 0.2
======
What does it ? An object containing a type and a list.
Quick démo :
======
typedlist create rectangle
set A [rectangle -- 100 100 200 200]
$A get; # 100 100 200 200
$A type; # rectangle
$A lappend 300 100; # 100 100 200 200 300 100
typedlist create triangle
$A transmute ::triangle
$A type; # triangle
$A get; # 100 100 200 200 300 100
======
Applications :
* [megawidget framework with tclOO (1)]
* [parsing with coroutine]
* [analogy between html markup and typedlist]
----!!!!!!
%|[PYK] 2014-11-06: Made a small change to make sure a value in generated code
was properly encasulated in a list, and another small change to handle relative
namespaces better.
<<categories>> Category Object Orientation] |[ Category Package]|%
!!!!!!