pshook

Simple Template

    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;
        };
    

Simple Class

    #-----------------------------------------------------------------------------
    # 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]