Posted to tcl by smlckz at Sat Nov 29 05:35:56 GMT 2025view pretty
## ==== htmlgen.tcl ====
package require Tcl 8.6
# Taken from https://wiki.tcl-lang.org/page/Config+file+using+slave+interp
proc parse {body} {
set i [interp create -safe]
try {
$i eval {namespace delete ::}
$i alias unknown apply {args {
upvar 1 a a
lappend a $args
return
}}
set a {}
$i eval $body
return $a
} finally {
interp delete $i
}
}
proc html_escape {text} {
return [string map {& & < < > > {"} "} $text]
}
proc tag {args} {
set break_lines 0
set recurse 0
set self_closing 0
set open_only 0
set xml 0
set i 0
set n [llength $args]
while {$i < $n} {
set arg [lindex $args $i]
switch -exact -- $arg {
-breaklines {set break_lines 1}
-recurse {set recurse 1}
-selfclosing {set self_closing 1}
-openonly {set open_only 1}
-xml {set xml 1}
-- {incr i; break}
default break
}
incr i
}
set name [lindex $args $i]
set result "<$name"
incr i
while {$i < $n} {
set key [lindex $args $i]
if {![string equal -length 1 $key -]} break
if {[string equal $key --]} {incr i; break}
if {[string equal [string index $key 1] ?]} {
append result { } [string range $key 2 end]
incr i
} else {
append result { } [string range $key 1 end] {="} [html_escape [lindex $args $i+1]] {"}
incr i 2
}
}
if {$self_closing && $xml} {append result {/}}
append result {>}
if {$self_closing || $open_only} {return $result}
set children [lrange $args $i end]
if $recurse {
set children [lmap child $children {process $child $break_lines}]
}
if $break_lines {
append result "\n " [string map {\n "\n "} [join $children \n]] "\n"
} else {
append result [join $children]
}
append result "</$name>"
}
set h [interp create -safe]
$h alias unknown tag --
$h alias escape html_escape
foreach {alias name} {` code // em ** strong % h1 %% h2} {
$h alias $alias tag $name
}
foreach {flags names} {
{-breaklines -recurse} {ul}
-selfclosing {meta}
-openonly {html}
} {
foreach name $names {
$h alias $name tag {*}$flags -- $name
}
}
foreach {name params f} {
comment body {return "<!--[escape $body]-->"}
doctype args {return "<!doctype [join $args]>"}
} {
$h eval [list proc $name $params $f]
}
proc process {body {multiline 0}} {
set result [lmap tree [parse $body] {$::h eval $tree}]
if $multiline {join $result \n} else {join $result}
}
if {$argc < 1} {
puts "usage: tclsh $argv0 filename"
return
}
set f [open [lindex $argv 0]]
set body [read $f]
close $f
puts [process [$h eval [list subst $body]] 1]
## ==== sample input ====
% [` smlckz]s website
p Hello, Im [` smlckz]. I like studying. I am interested in mathematics, programming and philosophy.
%% Contact
ul -class contact {
li Mastodon: [a -rel me -href {https://c.im/@smlckz} @smlckz@c.im]
li IRC: [` smlckz] on [a -href {https://tilde.chat} tilde.chat] and [a -href {https://libera.chat} libera.chat]
}
comment {
SPDX-FileCopyrightText: 2025 smlckz
SPDX-License-Identifier: CC-BY-SA-4.0
}
## ==== sample output ====
<h1><code>smlckz</code>s website</h1>
<p>Hello, Im <code>smlckz</code>. I like studying. I am interested in mathematics, programming and philosophy.</p>
<h2>Contact</h2>
<ul class="contact">
<li>Mastodon: <a rel="me" href="https://c.im/@smlckz">@smlckz@c.im</a></li>
<li>IRC: <code>smlckz</code> on <a href="https://tilde.chat">tilde.chat</a> and <a href="https://libera.chat">libera.chat</a></li>
</ul>
<!--
SPDX-FileCopyrightText: 2025 smlckz
SPDX-License-Identifier: CC-BY-SA-4.0
-->