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
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;
};
interp alias {} assign {} upvar #0
proc class {classname} {
set template {
global @[email protected]
set @[email protected] 0
proc @classname@_new {args} {
global @[email protected]
set obj @classname@.[incr @[email protected]]
# puts "@classname@_new $obj"
assign $obj members
array set members [list __class__ @classname@]
array set members $args
proc $obj {cmd args} "uplevel 1 @classname@_\$cmd $obj \$args"
return $obj
}
proc @classname@_set {obj args} {
assign $obj members
# puts [info level 0]
if { $members(__class__) != "@classname@" } {
error "invalid object: [info level 0]"
}
array set members $args
}
proc @classname@_get {obj name} {
assign $obj members
# puts [info level 0]
if { $members(__class__) != "@classname@" } {
error "invalid object: [info level 0]"
}
if [catch { set val $members($name) }] {
error "no such member: [info level 0]"
}
return $val
}
}
regsub -all @classname@ $template $classname template
eval $template
}
proc typeof {obj} {
assign $obj members
return $members(__class__)
}
proc write_objects {outvar args} {
upvar 1 $outvar acc
foreach obj $args {
assign $obj members
append acc "$members(__class__)_set $obj \\\n"
foreach name [lsort [array names members]] {
append acc "\t [list $name $members($name)] \\\n"
}
append acc "\n"
}
}
class link
proc link {name parent_class child_class} {
interp alias {} ${child_class}_${name}.parent {} link_parent ${name}
interp alias {} ${parent_class}_${name}.children {} link_children ${name}
interp alias {} ${parent_class}_${name}.append {} link_append ${name}
link_new -name $name -parent_class $parent_class -child_class $child_class
}
proc link_parent {name child} {
assign $child obj
if { ! [info exists obj($name.parent)] } {
error "no such link: [info level 0]"
}
return $obj($name.parent)
}
proc link_children {name parent} {
assign $parent par
if { ! [info exists par($name.children)] } {
error "no such link: [info level 0]"
}
return $par($name.children)
}
proc link_append {name parent args} {
assign $parent par
foreach child $args {
assign $child obj
if [info exists obj($name.parent)] {
error "object already linked: [info level 0]"
}
set obj($name.parent) $parent
lappend par($name.children) $child
}
}
class apple
proc apple_byte {self} {
puts "Taking a byte from apple $self"
apple_set $self -size [expr [apple_get $self -size] - 1]
if { [apple_get $self -size] <= 0 } {
puts "Apple $self now completely eaten!"
}
}
class fridge
proc fridge_open {self} {
if { [fridge_get $self -state] == "open" } {
puts "Fridge $self already open."
} else {
puts "Opening fridge $self..."
fridge_set $self -state "open"
}
}
proc fridge_close {self} {
if { [fridge_get $self -state] == "closed" } {
puts "Fridge $self already closed."
} else {
puts "Closing fridge $self..."
fridge_set $self -state "closed"
}
}
set a1 [apple_new -size 3]
set a2 [apple_new -color yellow -size 3]
foreach i {1 2 3} {
apple_byte $a1
apple_byte $a2
}
set f1 [fridge_new -state open]
fridge_close $f1
fridge_close $f1
fridge_open $f1
fridge_open $f1
fridge_close $f1
proc fridge_paint {self color} {
puts "Painting fridge $self $color ..."
fridge_set $self -color $color
}
catch { puts "$f1 is [fridge_get $f1 -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
link holds fridge apple
$f1 holds.append $a2 $a1
write_objects dump $f1 $a1 $a2
puts $dump
proc show {x} {
set c [$x get __class__]
switch $c {
fridge { puts "$x class $c children [$x holds.children]" }
apple { puts "$x class $c parent [$x holds.parent]" }
}
}
foreach a [$f1 holds.children] {
show $a
}
foreach x [list $f1 $a1 $a2] { show $x }