if { [info commands lassign] == "" } {
proc lassign {L args} {
uplevel 1 [list foreach $args [linsert $L end {}] break]
lrange $L [llength $args] end
}
}
interp alias {} nosubst {} subst -nobackslashes -nocommands -novariables
proc template {name vars body} {
proc $name $vars [genrender -template $body -cmd {append OUT} -end {return $OUT}]
}
proc render {args} { uplevel 1 [eval {genrender} $args] }
proc genrender {args} {
array set par [list -template {} -sub {subst} -cmd {puts -nonewline} -begin {} -end {} ]
array set par $args
set a "$par(-cmd) \[$par(-sub) {"
set b "}]\n\\1\n"
set c [regsub -all -line {$\s*%\s(.*)} $par(-template) $b$a ]
join [list $par(-begin) $a$c\}\] $par(-end)] "\n"
}
set v 3
set mjd "Mark J. Dominus"
set mjdweb "http://perl.plover.com/"
set L [split "ABCD" ""]
template example {v L} {
% global env
You can access variables: $v
or environment variables: $env(HOME)
You can call functions and evaluate code inline.
The list [join $L ", "] has [llength $L] elements.
[string repeat = [llength $L]]
[join $L ""]
[string repeat = [llength $L]]
Loop
% for {set i 0} { $i < [llength $L] } {incr i} {
elem L\[$i\] = [lindex $L $i]
% }
Append to output
% for {set i 0} { $i < [llength $L] } {incr i} {
% append OUT " L\[$i\] = " ' [lindex $L $i] '
% }
% global mjd mjdweb
This example is from $mjd at ${mjdweb}
% set len [llength $L]
The Lord High Chamberlain has gotten $len things for me this year.
% set diff [expr { $len - 5 }]
% set more "more"
% if { $diff == 0 } {
% set more "no"
% } elseif { $diff < 0 } {
% set diff [expr {-$diff}]
% set more "fewer"
% }
That is $diff $more than he gave me last year.
}
puts [example $v $L]
array set structs {
a long
c float
}
template render_struct {n t} {
struct $n {
struct $n *next;
$t data;
};
}
foreach {n t} [array get structs] {
append output [render_struct $n $t]
}
puts $output
Produces the following output
You can access variables: 3
or environment variables: /home/pshook
You can call functions and evaluate code inline.
The list A, B, C, D has 4 elements.
====
ABCD
====
Loop
elem L[0] = A
elem L[1] = B
elem L[2] = C
elem L[3] = D
Append to output L[0] = 'A' L[1] = 'B' L[2] = 'C' L[3] = 'D'
This example is from Mark J. Dominus at http://perl.plover.com/
The Lord High Chamberlain has gotten 4 things for me this year.
That is 1 fewer than he gave me last year.
struct a {
struct a *next;
long data;
};
struct c {
struct c *next;
float data;
};
#-----------------------------------------------------------------------------
# function to create object oriented classes
# http://users.telenet.be/koen.vandamme1/papers/tcl_objects/tcl_objects.html
interp alias {} assign {} upvar #0
proc class {cname args} {
lappend args __class__ $cname
assign $cname c
set c(name) $cname
set c(num) 0
set c(defaults) $args
interp alias {} $cname.new {} class.new $cname
interp alias {} $cname.delete {} class.delete
interp alias {} $cname.set {} class.set
interp alias {} $cname.get {} class.get
interp alias {} $cname.lget {} class.lget
interp alias {} $cname.dump {} class.dump
return $cname
}
proc class.object_command {self method args} {
assign $self obj
# if [info exists obj($method)] { return $obj($method) }
eval [list $obj(__class__).$method $self] $args
}
proc class.new {cname args} {
assign $cname c
set self $cname:[incr c(num)]
# puts "$cname.new $self"
# the object command has the same name as the object
interp alias {} $self {} class.object_command $self
# the object is a global array
assign $self obj
array set obj $c(defaults)
array set obj $args ; # initial values
if { [info procs $cname.__init__] != "" } { $cname.__init__ $self }
return $self
}
proc class.delete {self} {
assign $self obj
# puts [info level 0]
unset obj ; # delete object
rename $self {} ; # delete object command
}
proc class.set {self args} {
assign $self obj
# puts [info level 0]
array set obj $args
}
proc class.get {self name} {
assign $self obj
# puts [info level 0]
if [info exists obj($name)] { return $obj($name) }
error "no such member '$name' in: [info level 0]"
}
proc class.lget {self names} {
assign $self obj
# puts [info level 0]
set values {}
if [catch { foreach name $names { lappend values $obj($name) }}] {
error "no such member '$name' in: [info level 0]"
}
return $values
}
proc class.dump {args} {
# puts [info level 0]
set out ""
foreach self $args {
assign $self obj
append out "$obj(__class__).set $self \\\n"
foreach name [lsort [array names obj]] {
append out "\t [list $name $obj($name)] \\\n"
}
append out "\n"
}
return $out
}
#-----------------------------------------------------------------------------
# link parent object with mulitple children
class link
proc link {rname parent_class child_class} {
interp alias {} $parent_class.$rname.append {} link.append $rname
assign $parent_class pc
lappend pc(defaults) $rname.children {}
link.new -relation $rname -parent_class $parent_class -child_class $child_class
}
proc link.append {rname parent args} {
assign $parent par
foreach child $args {
assign $child obj
if [info exists obj($rname.parent)] {
error "object already linked: [info level 0]"
}
set obj($rname.parent) $parent
lappend par($rname.children) $child
}
}
class apple -color green -size 5 -price 10
proc apple.byte {self} {
assign $self obj
if { $obj(-size) > 0 } {
puts "Taking a byte from apple $self"
incr obj(-size) -1
} else {
puts "Apple $self size is zero"
}
}
class fridge -state "closed"
proc fridge.open {self} {
if { [fridge.get $self -state] == "open" } {
puts "Fridge $self already open"
} else {
fridge.set $self -state "open"
puts "Fridge $self now open"
}
}
proc fridge.close {self} {
if { [$self get -state] == "closed" } {
puts "Fridge $self already closed"
} else {
$self set -state "closed"
puts "Fridge $self now closed"
}
}
set a1 [apple.new -size 1]
proc apple.__init__ {self} {
global $self
parray $self
}
set a2 [apple.new -size 11 -size 2]
set a3 [apple.new -color yellow -price 3]
foreach i {1 2 3} {
apple.byte $a1
apple.byte $a2
apple.byte $a3
}
set f1 [fridge.new]
fridge.open $f1
fridge.close $f1
fridge.close $f1
fridge.open $f1
link holds fridge apple
$f1 holds.append $a2 $a1
foreach a [$f1 get holds.children] { puts [$a dump] }
$f1 holds.append $a3
proc fridge.paint {self color} {
$self set -color $color
puts "Painted fridge $self $color"
}
catch { puts "$f1 is [fridge.get $f1 -color]" } msg
puts $msg
catch { puts "$f1 is [$f1 get -color]" } msg
puts $msg
$f1 paint green
puts "The fridge $f1 is [fridge.get $f1 -color]"
$f1 open
$f1 paint blue
puts "The fridge $f1 is [fridge.get $f1 -color]"
$f1 close
proc show {x} {
set c [$x get __class__]
switch $c {
fridge { puts "$x class $c children are [$x get holds.children]" }
apple { puts "$x class $c parent is [$x get holds.parent], size is [$x get -size]" }
}
}
foreach x [list $f1 $a3] { show $x }
puts [fridge.dump $f1]
puts [apple.dump $a1 $a2 $a3]