# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use 'pmix make' or src/make.tcl to update from -buildversion.txt # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) 2023 # # @@ Meta Begin # Application punk::tdl 999999.0a1.0 # Meta platform tcl # Meta license # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements ##e.g package require frobz # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::tdl { # https://wiki.tcl-lang.org/page/Config+file+using+slave+interp namespace eval argdoc { variable PUNKARGS } variable sample_script { server -name bsd1 -os FreeBSD server -name p1 -os linux server -name trillion -os windows server -name vmhost1 -os FreeBSD { guest -name bsd1 -vmmanager bastille guest -name p1 -vmmanager bhyve } } namespace eval argdoc { variable PUNKARGS lappend PUNKARGS [list { @id -id ::punk::tdl::prettyparse @cmd -name punk::tdl::prettyparse\ -summary\ "Parse a Tcl-like TDL script into a nested list of dictionaries."\ -help\ "Parse a script in the Tcl Data Language style shown at https://wiki.tcl-lang.org/page/Config+file+using+slave+interp. The script is evaluated in a child interpreter. Unknown commands are captured as data objects: the command name is stored under the reserved 'tag' key, flag/value words become dictionary entries, and an odd final argument is treated as a nested body script and parsed recursively under the reserved 'body' key. When safe is true a safe child interpreter is used. When safe is false a normal child interpreter is used, which allows a broader set of Tcl commands to run while parsing. This parser validates Tcl script syntax and list structure only; schema and semantic validation belong to the caller." @values -min 1 -max 2 script -type string -help\ "TDL-style Tcl script to parse." safe -type boolean -default 1 -optional 1 -help\ "Use a safe child interpreter when true, or a normal child interpreter when false." }] } proc prettyparse {script {safe 1}} { if {$safe} { set i [interp create -safe] } else { set i [interp create] } try { # $i eval {unset {*}[info vars]} # foreach command [$i eval {info commands}] {$i hide $command} # $i invokehidden namespace delete {*}[$i invokehidden namespace children] $i alias unknown apply {{i tag args} { upvar 1 result result set e [concat [list tag $tag] [lrange $args 0 [expr {([llength $args] & ~1) - 1}]]] if {[llength $args] % 2} { set saved $result set result {} $i eval [lindex $args end] lappend e body $result set result $saved } lappend result $e list }} $i set result {} $i eval $script return $result } finally { interp delete $i } } namespace eval argdoc { variable PUNKARGS lappend PUNKARGS [list { @id -id ::punk::tdl::prettyprint @cmd -name punk::tdl::prettyprint\ -summary\ "Render parsed TDL dictionaries back to a readable Tcl-like script."\ -help\ "Render the nested list of dictionaries returned by punk::tdl::prettyparse as an indented Tcl-like data script. The reserved 'tag' key supplies each command name. Remaining dictionary keys are emitted as arguments, and a non-empty reserved 'body' key is rendered recursively inside braces. Comments and original whitespace are not preserved." @values -min 1 -max 2 data -type list -help\ "Nested list of dictionaries in the representation returned by punk::tdl::prettyparse." level -type integer -default 0 -optional 1 -help\ "Initial indentation level, primarily used for recursive rendering." }] } proc prettyprint {data {level 0}} { set ind [string repeat " " $level] incr level set result {} foreach e $data { set line $ind[concat [list [dict get $e tag]] [dict remove $e tag body]] if {[dict exists $e body] && [llength [dict get $e body]]} { append line " {\n[prettyprint [dict get $e body] $level]\n$ind}" } lappend result $line } join $result \n } } namespace eval ::punk::args::register { #use fully qualified so 8.6 doesn't find existing var in global namespace lappend ::punk::args::register::NAMESPACES ::punk::tdl } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::tdl [namespace eval punk::tdl { variable version set version 999999.0a1.0 }] return