#! /usr/bin/env tclsh
# Copyright (c) 2021 D. Bohdan.
# License: MIT.
namespace eval tclmark {
variable interp
variable renders 0
variable token
variable version 0.1.0
namespace eval cmd {
namespace path [namespace parent]
}
}
proc tclmark::render {content {variables {}}} {
variable interp
variable renders
variable token
incr renders
set interp tclmark-$renders
# The token should be unguessable by the user.
set token [binary format {iu1 f1 iu1} \
$renders \
[expr rand()] \
[zlib crc32 $content] \
]
try {
interp create -safe $interp
foreach command [interp eval $interp {info commands}] {
$interp hide $command
}
foreach command [info commands cmd::*] {
$interp alias \
[namespace tail $command] \
$command \
}
flatten [msubst $content]
} finally {
catch {
interp delete $interp
}
}
}
proc tclmark::msubst content {
variable interp
variable token
# Pass through already processed content marked with the
# token.
set tokenLen [string length $token]
if {[string range $content 0 $tokenLen-1] eq $token} {
return $content
}
set r [interp invokehidden \
$interp \
subst -nobackslashes -novariables $content \
]
if {$r eq $content} {
return [node text $content]
}
return [node tree $r]
}
proc tclmark::node {tag args} {
variable token
list $token $tag $args
}
proc tclmark::flatten node {
variable token
if {[llength $node] != 3} {
error [list not three elements: $node]
}
lassign $node nodeToken tag data
if {$nodeToken ne $token} {
error [list invalid token in $node]
}
switch -- $tag {
html {
lindex $data 0
}
text {
entities [lindex $data 0]
}
tree {
join [lmap el $data {
flatten $el
}] {}
}
default {
error [list unknown tag: $tag]
}
}
}
proc tclmark::entities text {
string map {
& &
< <
> >
\" "
' '
} $text
}
proc tclmark::cmd::b content {
node tree [node html <b>] [msubst $content] [node html </b>]
}
proc tclmark::cmd::i content {
node tree [node html <i>] [msubst $content] [node html </i>]
}
proc tclmark::generic-list {tag xs} {
if {$tag ni {nl ol}} {
error [list invalid tag: $tag
}
node tree \
[node html <$tag>] \
{*}[msubst-and-wrap li $xs] \
[node html </$tag>] \
}
proc tclmark::cmd::1 args { tailcall generic-list nl $args }
proc tclmark::cmd::* args { tailcall generic-list ol $args }
proc tclmark::msubst-and-wrap {tag items} {
lmap item $items {
node tree [node html <$tag>] [msubst $item] [node html </$tag>]
}
}
proc tclmark::run-tests {} {
set stats [dict create total 0 passed 0 failed 0]
proc test {name script arrow expected} {
upvar stats stats
dict incr stats total
catch $script result
set matched [switch -- $arrow {
-> { expr {$result eq $expected} }
->* { string match $expected $result }
->$ { regexp -- $expected $result }
default {
return -code error \
-errorcode {JIMLIB TEST BAD-ARROW} \
[list unknown arrow: $arrow]
}
}]
if {!$matched} {
set error {}
append error "\n>>>>> $name failed: [list $script]\n"
append error " got: [list $result]\n"
append error " expected: [list $expected]"
if {$arrow ne {->}} {
append error "\n match: $arrow"
}
dict incr stats failed
puts stderr $error
return
}
flatten [msubst $content]
} finally {
catch {
interp delete $interp
}
}
}
proc tclmark::msubst content {
variable interp
variable token
# Pass through already processed content marked with the
# token.
set tokenLen [string length $token]
if {[string range $content 0 $tokenLen-1] eq $token} {
return $content
}
set r [interp invokehidden \
$interp \
subst -nobackslashes -novariables $content \
]
if {$r eq $content} {
return [node text $content]
}
return [node tree $r]
}
proc tclmark::node {tag args} {
variable token
list $token $tag $args
}
proc tclmark::flatten node {
variable token
if {[llength $node] != 3} {
error [list not three elements: $node]
}
lassign $node nodeToken tag data
if {$nodeToken ne $token} {
error [list invalid token in $node]
}
switch -- $tag {
html {
lindex $data 0
}
text {
entities [lindex $data 0]
}
tree {
join [lmap el $data {
flatten $el
}] {}
}
default {
error [list unknown tag: $tag]
}
}
}
proc tclmark::entities text {
string map {
& &
< <
> >
\" "
' '
} $text
}
proc tclmark::cmd::b content {
node tree [node html <b>] [msubst $content] [node html </b>]
}
proc tclmark::cmd::i content {
node tree [node html <i>] [msubst $content] [node html </i>]
}
proc tclmark::cmd::1 args {
node tree \
[node html <nl>] \
{*}[msubst-and-wrap li $args] \
[node html </nl>] \
}
proc tclmark::cmd::* args {
node tree \
[node html <ol>] \
{*}[msubst-and-wrap li $args] \
[node html </ol>] \
}
proc tclmark::msubst-and-wrap {tag items} {
lmap item $items {
node tree [node html <$tag>] [msubst $item] [node html </$tag>]
}
}
proc tclmark::run-tests {} {
set stats [dict create total 0 passed 0 failed 0]
proc test {name script arrow expected} {
upvar stats stats
dict incr stats total
catch $script result
set matched [switch -- $arrow {
-> { expr {$result eq $expected} }
->* { string match $expected $result }
->$ { regexp -- $expected $result }
default {
return -code error \
-errorcode {JIMLIB TEST BAD-ARROW} \
[list unknown arrow: $arrow]
}
}]
if {!$matched} {
set error {}
append error "\n>>>>> $name failed: [list $script]\n"
append error " got: [list $result]\n"
append error " expected: [list $expected]"
if {$arrow ne {->}} {
append error "\n match: $arrow"
}
dict incr stats failed
puts stderr $error
return
}
dict incr stats passed
}
test basic-1 {
tclmark::render Test
} -> Test
test basic-2 {
tclmark::render {[b Test]}
} -> <b>Test</b>
test basic-3 {
tclmark::render {[i {Hello, world!}]}
} -> {<i>Hello, world!</i>}
test basic-4 {
tclmark::render {[b [i Test]]}
} -> <b><i>Test</i></b>
test basic-5 {
tclmark::render {[b {[i Test]}]}
} -> <b><i>Test</i></b>
test basic-6 {
tclmark::render {[}
} -> \[
test html-1 {
tclmark::render {<b><i>Test</i></b>}
} -> {<b><i>Test</i></b>}
test html-2 {
tclmark::render {[b <script>alert('Hello!')</script>]}
} -> {<b><script>alert('Hello!')</script></b>}
test list-1 {
tclmark::render {[* first second third]}
} -> {<ol><li>first</li><li>second</li><li>third</li></ol>}
test list-2 {
tclmark::render {[1 first second third]}
} -> {<nl><li>first</li><li>second</li><li>third</li></nl>}
puts stderr $stats
return [expr {[dict get $stats failed] > 0}]
}
# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
exit [tclmark::run-tests]
}
proc tclmark::cmd::b content {
node tree [node html <b>] [msubst $content] [node html </b>]
}
proc tclmark::cmd::i content {
node tree [node html <i>] [msubst $content] [node html </i>]
}
proc tclmark::run-tests {} {
set stats [dict create total 0 passed 0 failed 0]
proc test {name script arrow expected} {
upvar stats stats
dict incr stats total
catch $script result
set matched [switch -- $arrow {
-> { expr {$result eq $expected} }
->* { string match $expected $result }
->$ { regexp -- $expected $result }
default {
return -code error \
-errorcode {JIMLIB TEST BAD-ARROW} \
[list unknown arrow: $arrow]
}
}]
if {!$matched} {
set error {}
append error "\n>>>>> $name failed: [list $script]\n"
append error " got: [list $result]\n"
append error " expected: [list $expected]"
if {$arrow ne {->}} {
append error "\n match: $arrow"
}
dict incr stats failed
puts stderr $error
return
}
dict incr stats passed
}
test basic-1 {
tclmark::render Test
} -> Test
test basic-2 {
tclmark::render {[b Test]}
} -> <b>Test</b>
test basic-3 {
tclmark::render {[i {Hello, world!}]}
} -> {<i>Hello, world!</i>}
test basic-4 {
tclmark::render {[b [i Test]]}
} -> <b><i>Test</i></b>
test basic-5 {
tclmark::render {[b {[i Test]}]}
} -> <b><i>Test</i></b>
test basic-6 {
tclmark::render {[}
} -> \[
test html-1 {
tclmark::render {<b><i>Test</i></b>}
} -> {<b><i>Test</i></b>}
test html-2 {
tclmark::render {[b <script>alert('Hello!')</script>]}
} -> {<b><script>alert('Hello!')</script></b>}
test list-1 {
tclmark::render {[list first second third]}
} -> {<ol><li>first</li><li>second</li><li>third</li></ol>}
puts stderr $stats
return [expr {[dict get $stats failed] > 0}]
}
# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
exit [tclmark::run-tests]
}
package provide tclmark 0
package provide tclmark 0
dict incr stats passed
}
test basic-1 {
tclmark::render Test
} -> Test
test basic-2 {
tclmark::render {[b Test]}
} -> <b>Test</b>
test basic-3 {
tclmark::render {[i {Hello, world!}]}
} -> {<i>Hello, world!</i>}
test basic-4 {
tclmark::render {[b [i Test]]}
} -> <b><i>Test</i></b>
test basic-5 {
tclmark::render {[b {[i Test]}]}
} -> <b><i>Test</i></b>
test basic-6 {
tclmark::render {[}
} -> \[
test html-1 {
tclmark::render {<b><i>Test</i></b>}
} -> {<b><i>Test</i></b>}
test html-2 {
tclmark::render {[b <script>alert('Hello!')</script>]}
} -> {<b><script>alert('Hello!')</script></b>}
test list-1 {
tclmark::render {[* first second third]}
} -> {<ol><li>first</li><li>second</li><li>third</li></ol>}
test list-2 {
tclmark::render {[1 first second third]}
} -> {<nl><li>first</li><li>second</li><li>third</li></nl>}
puts stderr $stats
return [expr {[dict get $stats failed] > 0}]
}
# If this is the main script...
if {[info exists argv0] && ([file tail [info script]] eq [file tail $argv0])} {
exit [tclmark::run-tests]
}
package provide tclmark 0