Browse Source
Batched punkcheck-managed outputs per src/AGENTS.md carve-out. Assisted-by: harness=claude; primary-model=claude-fable-5; api-location=anthropic.commaster
19 changed files with 2265 additions and 986 deletions
Binary file not shown.
Binary file not shown.
Binary file not shown.
@ -0,0 +1,925 @@
|
||||
# -*- tcl -*- |
||||
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'dev make' or bin/punkmake to update from <pkg>-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) 2026 |
||||
# |
||||
# @@ Meta Begin |
||||
# Application punk::tclparser 0.1.0 |
||||
# Meta platform tcl |
||||
# Meta license BSD |
||||
# @@ Meta End |
||||
|
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
## Requirements |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
|
||||
package require Tcl 8.6- |
||||
#No other package requirements by design (G-070): this module is the pure-Tcl |
||||
#fallback for the tclparser C library and must load on a plain tclsh. |
||||
#punk::args is used for documentation only via the inert PUNKARGS/register |
||||
#mechanism - it is not required at runtime. |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# punk::tclparser |
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
# Pure-Tcl implementation of (a subset of) the 'parse' command API provided by |
||||
# the tclparser C library (TclPro lineage - punkshell fork/reference at |
||||
# c:/repo/jn/tclparser_punk, pin recorded in goals/G-070-pure-tcl-tclparser.md). |
||||
# |
||||
# Covered subcommands (the set punkshell consumers actually use - G-070): |
||||
# parse command <string> <range> |
||||
# parse getstring <string> <range> |
||||
# parse countnewline <string> ?range? |
||||
# Uncovered (error advising the C library): expr varname list charindex charlength |
||||
# |
||||
# IMPORTANT: this module deliberately does NOT provide the package name |
||||
# 'parser'. Consumers use `package require parser` as the capability probe |
||||
# meaning "the fast C library is present" (textblock::height fast path, |
||||
# punk::lib dispatch). The pure-Tcl engine is always the explicit fallback. |
||||
# |
||||
# All ranges ({start length} pairs) are BYTE offsets over the string's |
||||
# (modified) utf-8 representation, matching what the C library reports |
||||
# against Tcl's internal string bytes. Parsing is performed over a byte view |
||||
# so emitted offsets are byte offsets by construction: every Tcl |
||||
# syntax-significant character is ASCII and utf-8 continuation bytes cannot |
||||
# alias them. |
||||
|
||||
tcl::namespace::eval punk::tclparser { |
||||
variable PUNKARGS |
||||
tcl::namespace::export parse |
||||
|
||||
namespace eval argdoc { |
||||
variable PUNKARGS |
||||
lappend PUNKARGS [list { |
||||
@id -id ::punk::tclparser::parse |
||||
@cmd -name punk::tclparser::parse\ |
||||
-summary\ |
||||
"Pure-Tcl subset of the tclparser C library's 'parse' command."\ |
||||
-help\ |
||||
"Pure-Tcl implementation of the tclparser C library's 'parse' |
||||
command API, covering the subcommands punkshell consumers use: |
||||
command, getstring, countnewline. |
||||
|
||||
Subcommand results and the ranges within them use BYTE offsets |
||||
({start length} pairs) over the string's utf-8 bytes, exactly as |
||||
the C library reports them - use 'parse getstring' (not string |
||||
range) to extract substrings by range. |
||||
|
||||
parse command string range |
||||
Parse one command from string. Returns a 4 element list: |
||||
commentRange commandRange restRange tree. |
||||
The tree is a list of word nodes {type {start len} subnodes} |
||||
with word types simple/word/expand and subnode types |
||||
text/backslash/command/variable. Literal {*} expansions are |
||||
expanded at parse time into per-element simple nodes. |
||||
|
||||
parse getstring string range |
||||
Return the substring of string covered by the byte range. |
||||
|
||||
parse countnewline string ?range? |
||||
Return the number of newline characters in the range |
||||
(default: the whole string). |
||||
|
||||
The uncovered C library subcommands (expr, varname, list, |
||||
charindex, charlength) raise an error advising installation of |
||||
the C library (package require parser). |
||||
|
||||
This module intentionally does not provide the package name |
||||
'parser' - that name is the capability probe for the C library." |
||||
@values -min 2 -max 3 |
||||
subcommand -type string -choices {command getstring countnewline} -choicerestricted 0 -help\ |
||||
"Operation to perform (covered set: command, getstring, countnewline)" |
||||
string -type string -help\ |
||||
"The string to operate on" |
||||
range -type list -optional 1 -help\ |
||||
"Byte range {start length} within string. {} or omitted means the |
||||
whole string. length may be the literal 'end' to mean through to |
||||
the end of the string." |
||||
}] |
||||
} |
||||
proc parse {args} { |
||||
#parity-oriented manual parsing - documentation via PUNKARGS above (see src/modules/AGENTS.md) |
||||
if {[llength $args] < 2} { |
||||
error "wrong # args: should be \"punk::tclparser::parse subcommand string ?range?\"" |
||||
} |
||||
set subcommand [lindex $args 0] |
||||
set str [lindex $args 1] |
||||
if {[llength $args] >= 3} { |
||||
set range [lindex $args 2] |
||||
} else { |
||||
set range {} |
||||
} |
||||
switch -exact -- $subcommand { |
||||
command { |
||||
if {[llength $args] != 3} { |
||||
error "wrong # args: should be \"punk::tclparser::parse command string range\"" |
||||
} |
||||
return [engine::parse_command $str $range] |
||||
} |
||||
getstring { |
||||
if {[llength $args] != 3} { |
||||
error "wrong # args: should be \"punk::tclparser::parse getstring string range\"" |
||||
} |
||||
return [engine::parse_getstring $str $range] |
||||
} |
||||
countnewline { |
||||
return [engine::parse_countnewline $str $range] |
||||
} |
||||
expr - varname - list - charindex - charlength { |
||||
error "punk::tclparser::parse: subcommand '$subcommand' is not implemented in the pure-Tcl engine (covered set: command, getstring, countnewline). Install the tclparser C library (package require parser) for the full API." |
||||
} |
||||
default { |
||||
error "punk::tclparser::parse: bad subcommand \"$subcommand\": must be command, getstring or countnewline" |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
tcl::namespace::eval punk::tclparser::engine { |
||||
#Internal parsing engine. All procs here operate on a 'byte view' string in |
||||
#which each character is one byte of the original string's (modified) utf-8 |
||||
#encoding - so tcl string indices into the byte view ARE byte offsets. |
||||
#Tcl syntax characters are all ASCII; utf-8 continuation bytes (0x80-0xBF) |
||||
#and lead bytes (0xC0+) can never alias them, so scanning the byte view |
||||
#gives byte-correct ranges with no separate bookkeeping. |
||||
|
||||
variable TCL9 [package vsatisfies [package provide Tcl] 9-] |
||||
|
||||
# -- byte view conversion ------------------------------------------------ |
||||
proc to_bytes {s} { |
||||
#NUL must round-trip as modified utf-8 (0xC0 0x80) because that is the |
||||
#internal representation the C parser indexes over. |
||||
if {[string is ascii $s] && [string first \x00 $s] < 0} { |
||||
return $s |
||||
} |
||||
variable TCL9 |
||||
if {$TCL9} { |
||||
set b [encoding convertto -profile tcl8 utf-8 $s] |
||||
} else { |
||||
set b [encoding convertto utf-8 $s] |
||||
} |
||||
return [string map [list \x00 \xC0\x80] $b] |
||||
} |
||||
proc from_bytes {b} { |
||||
if {[string is ascii $b]} { |
||||
return $b |
||||
} |
||||
variable TCL9 |
||||
set b [string map [list \xC0\x80 \x00] $b] |
||||
if {$TCL9} { |
||||
return [encoding convertfrom -profile tcl8 utf-8 $b] |
||||
} |
||||
return [encoding convertfrom utf-8 $b] |
||||
} |
||||
proc resolve_range {range total} { |
||||
#returns {first len} in bytes. {} means whole string. |
||||
if {[llength $range] == 0} { |
||||
return [list 0 $total] |
||||
} |
||||
if {[llength $range] != 2} { |
||||
error "invalid range \"$range\": should be \"\" or a list of two items: start length" |
||||
} |
||||
lassign $range first len |
||||
if {![string is integer -strict $first] || $first < 0} { |
||||
error "invalid range start \"$first\"" |
||||
} |
||||
if {$len eq "end"} { |
||||
set len [expr {$total - $first}] |
||||
} elseif {![string is integer -strict $len]} { |
||||
error "invalid range length \"$len\"" |
||||
} |
||||
if {$first > $total} { |
||||
set first $total |
||||
} |
||||
if {$first + $len > $total} { |
||||
set len [expr {$total - $first}] |
||||
} |
||||
if {$len < 0} { |
||||
set len 0 |
||||
} |
||||
return [list $first $len] |
||||
} |
||||
|
||||
# -- public-facing operations (called by punk::tclparser::parse) -------- |
||||
proc parse_command {str range} { |
||||
set bytes [to_bytes $str] |
||||
set total [string length $bytes] |
||||
lassign [resolve_range $range $total] first len |
||||
set endpos [expr {$first + $len}] |
||||
lassign [parse_command_bytes $bytes $first $endpos 0] cs cl ks kl rest term tree |
||||
if {$cs < 0} { |
||||
set cs 0 |
||||
set cl 0 |
||||
} |
||||
return [list [list $cs $cl] [list $ks $kl] [list $rest [expr {$endpos - $rest}]] $tree] |
||||
} |
||||
proc parse_getstring {str range} { |
||||
set bytes [to_bytes $str] |
||||
set total [string length $bytes] |
||||
lassign [resolve_range $range $total] first len |
||||
return [from_bytes [string range $bytes $first [expr {$first + $len - 1}]]] |
||||
} |
||||
proc parse_countnewline {str range} { |
||||
set bytes [to_bytes $str] |
||||
set total [string length $bytes] |
||||
lassign [resolve_range $range $total] first len |
||||
set seg [string range $bytes $first [expr {$first + $len - 1}]] |
||||
return [expr {[string length $seg] - [string length [string map [list \n {}] $seg]]}] |
||||
} |
||||
|
||||
# -- core scanner -------------------------------------------------------- |
||||
proc skip_white {bytes pos endpos} { |
||||
#inter-word whitespace: space tab vtab ff cr, plus backslash-newline |
||||
#(with its trailing space/tab run) which acts as a word separator. |
||||
#Never consumes bare newline or semicolon (command terminators). |
||||
while {$pos < $endpos} { |
||||
set c [string index $bytes $pos] |
||||
switch -exact -- $c { |
||||
" " - \t - \v - \f - \r { |
||||
incr pos |
||||
} |
||||
"\\" { |
||||
if {$pos + 1 < $endpos && [string index $bytes $pos+1] eq "\n"} { |
||||
incr pos 2 |
||||
while {$pos < $endpos} { |
||||
set c2 [string index $bytes $pos] |
||||
if {$c2 eq " " || $c2 eq "\t"} { |
||||
incr pos |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} else { |
||||
return $pos |
||||
} |
||||
} |
||||
default { |
||||
return $pos |
||||
} |
||||
} |
||||
} |
||||
return $pos |
||||
} |
||||
|
||||
proc bs_advance {bytes pos endpos} { |
||||
#pos is at a backslash: return the position just after the full escape |
||||
#sequence, per Tcl_ParseBackslash rules. \xHH consumes at most 2 hex |
||||
#digits on every supported runtime (TIP 388, in since 8.6 - verified |
||||
#against the c library on 8.6.13, 8.7a6 and 9.0.3; unlimited-run \x is |
||||
#Tcl 8.5, out of scope). |
||||
set p [expr {$pos + 1}] |
||||
if {$p >= $endpos} { |
||||
return $p |
||||
} |
||||
set c [string index $bytes $p] |
||||
switch -exact -- $c { |
||||
"\n" { |
||||
incr p |
||||
while {$p < $endpos} { |
||||
set c2 [string index $bytes $p] |
||||
if {$c2 eq " " || $c2 eq "\t"} { |
||||
incr p |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
return $p |
||||
} |
||||
x { |
||||
incr p |
||||
set hex 0 |
||||
while {$p < $endpos && $hex < 2 && [string match {[0-9a-fA-F]} [string index $bytes $p]]} { |
||||
incr p |
||||
incr hex |
||||
} |
||||
return $p |
||||
} |
||||
u { |
||||
incr p |
||||
set hex 0 |
||||
while {$p < $endpos && $hex < 4 && [string match {[0-9a-fA-F]} [string index $bytes $p]]} { |
||||
incr p |
||||
incr hex |
||||
} |
||||
return $p |
||||
} |
||||
U { |
||||
incr p |
||||
set hex 0 |
||||
while {$p < $endpos && $hex < 8 && [string match {[0-9a-fA-F]} [string index $bytes $p]]} { |
||||
incr p |
||||
incr hex |
||||
} |
||||
return $p |
||||
} |
||||
default { |
||||
if {[string match {[0-7]} $c]} { |
||||
set oct 0 |
||||
while {$p < $endpos && $oct < 3 && [string match {[0-7]} [string index $bytes $p]]} { |
||||
incr p |
||||
incr oct |
||||
} |
||||
return $p |
||||
} |
||||
#single (possibly multibyte) character: consume the full utf-8 |
||||
#sequence so the escape range never splits a character. |
||||
set b [scan $c %c] |
||||
incr p |
||||
if {$b >= 0xC0} { |
||||
while {$p < $endpos} { |
||||
set nb [scan [string index $bytes $p] %c] |
||||
if {$nb >= 0x80 && $nb < 0xC0} { |
||||
incr p |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
} |
||||
return $p |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc parse_command_bytes {bytes pos endpos nested} { |
||||
#Parse a single command starting at pos. |
||||
#Returns: commentStart commentLen cmdStart cmdLen restPos term tree |
||||
#term is one of: eof, nl, semi, bracket (bracket: ']' seen but NOT |
||||
#consumed - the command-substitution scanner consumes it). |
||||
set commentStart -1 |
||||
set commentLen 0 |
||||
while {1} { |
||||
set pos [skip_white $bytes $pos $endpos] |
||||
if {$pos < $endpos && [string index $bytes $pos] eq "\n"} { |
||||
#before the command starts, newlines are ordinary whitespace |
||||
#(they only terminate once a command is in progress) |
||||
incr pos |
||||
continue |
||||
} |
||||
if {$pos < $endpos && [string index $bytes $pos] eq "#"} { |
||||
if {$commentStart < 0} { |
||||
set commentStart $pos |
||||
} |
||||
while {$pos < $endpos} { |
||||
set c [string index $bytes $pos] |
||||
if {$c eq "\\"} { |
||||
set pos [bs_advance $bytes $pos $endpos] |
||||
} elseif {$c eq "\n"} { |
||||
incr pos |
||||
break |
||||
} else { |
||||
incr pos |
||||
} |
||||
} |
||||
set commentLen [expr {$pos - $commentStart}] |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
set cmdStart $pos |
||||
set tree [list] |
||||
set term eof |
||||
while {1} { |
||||
set pos [skip_white $bytes $pos $endpos] |
||||
if {$pos >= $endpos} { |
||||
set term eof |
||||
break |
||||
} |
||||
set c [string index $bytes $pos] |
||||
if {$c eq "\n"} { |
||||
set term nl |
||||
incr pos |
||||
break |
||||
} |
||||
if {$c eq ";"} { |
||||
set term semi |
||||
incr pos |
||||
break |
||||
} |
||||
if {$nested && $c eq "\]"} { |
||||
set term bracket |
||||
break |
||||
} |
||||
lassign [parse_word $bytes $pos $endpos $nested] nodes pos |
||||
lappend tree {*}$nodes |
||||
} |
||||
set cmdLen [expr {$pos - $cmdStart}] |
||||
return [list $commentStart $commentLen $cmdStart $cmdLen $pos $term $tree] |
||||
} |
||||
|
||||
proc parse_word {bytes pos endpos nested} { |
||||
#Parse one word. Returns {nodes nextpos} - nodes is a list of word |
||||
#nodes (usually one; a literal {*} expansion may produce zero or more). |
||||
set wordStart $pos |
||||
set expand 0 |
||||
if {[string range $bytes $pos [expr {$pos + 2}]] eq "\{*\}" && $pos + 3 < $endpos} { |
||||
set c3 [string index $bytes $pos+3] |
||||
set sep 0 |
||||
switch -exact -- $c3 { |
||||
" " - \t - \v - \f - \r - "\n" - ";" { |
||||
set sep 1 |
||||
} |
||||
"\\" { |
||||
#backslash-newline is a word separator, so a {*} followed |
||||
#by a line continuation is a plain braced word |
||||
if {$pos + 4 < $endpos && [string index $bytes $pos+4] eq "\n"} { |
||||
set sep 1 |
||||
} |
||||
} |
||||
"\]" { |
||||
if {$nested} { |
||||
set sep 1 |
||||
} |
||||
} |
||||
} |
||||
if {!$sep} { |
||||
set expand 1 |
||||
incr pos 3 |
||||
} |
||||
} |
||||
set c [string index $bytes $pos] |
||||
set bodykind bare |
||||
if {$c eq "\{"} { |
||||
set bodykind brace |
||||
lassign [parse_braces $bytes $pos $endpos] tokens pos |
||||
} elseif {$c eq "\""} { |
||||
set bodykind quote |
||||
lassign [parse_quoted $bytes $pos $endpos] tokens pos |
||||
} else { |
||||
lassign [parse_tokens $bytes $pos $endpos bare $nested] tokens pos |
||||
if {[llength $tokens] == 0} { |
||||
#can only happen for a lone backslash-newline handled by |
||||
#skip_white, or at a stop char - defensive: emit empty text |
||||
set tokens [list [list text [list $pos 0] {}]] |
||||
} |
||||
} |
||||
if {$bodykind ne "bare" && $pos < $endpos} { |
||||
#closing brace/quote must be followed by whitespace or a terminator |
||||
set c2 [string index $bytes $pos] |
||||
set ok 0 |
||||
switch -exact -- $c2 { |
||||
" " - \t - \v - \f - \r - "\n" - ";" { |
||||
set ok 1 |
||||
} |
||||
"\]" { |
||||
if {$nested} { |
||||
set ok 1 |
||||
} |
||||
} |
||||
"\\" { |
||||
if {$pos + 1 < $endpos && [string index $bytes $pos+1] eq "\n"} { |
||||
set ok 1 |
||||
} |
||||
} |
||||
} |
||||
if {!$ok} { |
||||
if {$bodykind eq "brace"} { |
||||
error "extra characters after close-brace" |
||||
} else { |
||||
error "extra characters after close-quote" |
||||
} |
||||
} |
||||
} |
||||
set wordLen [expr {$pos - $wordStart}] |
||||
if {$expand} { |
||||
if {[llength $tokens] == 1 && [lindex $tokens 0 0] eq "text"} { |
||||
#literal expansion: parse the literal as a list; each element |
||||
#becomes its own simple word node with ranges into the |
||||
#original string. If it is not a valid list, fall back to an |
||||
#expand node (the runtime raises the expansion error). |
||||
lassign [lindex $tokens 0 1] tstart tlen |
||||
if {![catch {list_elements $bytes $tstart [expr {$tstart + $tlen}]} elements]} { |
||||
set nodes [list] |
||||
foreach e $elements { |
||||
lassign $e estart elen etstart etlen |
||||
lappend nodes [list simple [list $estart $elen] [list [list text [list $etstart $etlen] {}]]] |
||||
} |
||||
return [list $nodes $pos] |
||||
} |
||||
} |
||||
return [list [list [list expand [list $wordStart $wordLen] $tokens]] $pos] |
||||
} |
||||
if {[llength $tokens] == 1 && [lindex $tokens 0 0] eq "text"} { |
||||
return [list [list [list simple [list $wordStart $wordLen] $tokens]] $pos] |
||||
} |
||||
return [list [list [list word [list $wordStart $wordLen] $tokens]] $pos] |
||||
} |
||||
|
||||
proc parse_braces {bytes pos endpos} { |
||||
#pos at the open brace. Returns {tokens nextpos} with nextpos just |
||||
#after the close brace. Tokens: text runs and backslash tokens for |
||||
#backslash-newline (the only substitution inside braces). |
||||
set level 1 |
||||
set p [expr {$pos + 1}] |
||||
set textStart $p |
||||
set tokens [list] |
||||
while {1} { |
||||
if {$p >= $endpos} { |
||||
error "missing close-brace" |
||||
} |
||||
set c [string index $bytes $p] |
||||
switch -exact -- $c { |
||||
"\{" { |
||||
incr level |
||||
incr p |
||||
} |
||||
"\}" { |
||||
incr level -1 |
||||
if {$level == 0} { |
||||
if {$p > $textStart || [llength $tokens] == 0} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
incr p |
||||
return [list $tokens $p] |
||||
} |
||||
incr p |
||||
} |
||||
"\\" { |
||||
if {$p + 1 < $endpos && [string index $bytes $p+1] eq "\n"} { |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
set bsend [expr {$p + 2}] |
||||
while {$bsend < $endpos} { |
||||
set c2 [string index $bytes $bsend] |
||||
if {$c2 eq " " || $c2 eq "\t"} { |
||||
incr bsend |
||||
} else { |
||||
break |
||||
} |
||||
} |
||||
lappend tokens [list backslash [list $p [expr {$bsend - $p}]] {}] |
||||
set p $bsend |
||||
set textStart $p |
||||
} else { |
||||
#backslash quotes the next byte for brace counting |
||||
#purposes; both stay part of the text run |
||||
incr p 2 |
||||
if {$p > $endpos} { |
||||
set p $endpos |
||||
} |
||||
} |
||||
} |
||||
default { |
||||
incr p |
||||
} |
||||
} |
||||
} |
||||
} |
||||
|
||||
proc parse_quoted {bytes pos endpos} { |
||||
#pos at the open quote. Returns {tokens nextpos} with nextpos just |
||||
#after the close quote. |
||||
set p [expr {$pos + 1}] |
||||
lassign [parse_tokens $bytes $p $endpos quote 0] tokens p |
||||
if {$p >= $endpos || [string index $bytes $p] ne "\""} { |
||||
error "missing \"" |
||||
} |
||||
if {[llength $tokens] == 0} { |
||||
set tokens [list [list text [list [expr {$pos + 1}] 0] {}]] |
||||
} |
||||
incr p |
||||
return [list $tokens $p] |
||||
} |
||||
|
||||
proc parse_tokens {bytes pos endpos mode nested} { |
||||
#Scan substitution tokens. mode: quote (stop at unescaped double |
||||
#quote), index (stop at close paren - array subscript), bare (stop at |
||||
#whitespace/terminators; backslash-newline acts as a word separator). |
||||
#Returns {tokens stoppos} - stoppos is AT the stopping character. |
||||
variable TCL9 |
||||
set tokens [list] |
||||
set textStart $pos |
||||
set p $pos |
||||
while {$p < $endpos} { |
||||
set c [string index $bytes $p] |
||||
if {$mode eq "quote"} { |
||||
if {$c eq "\""} { |
||||
break |
||||
} |
||||
} elseif {$mode eq "index"} { |
||||
if {$c eq ")"} { |
||||
break |
||||
} |
||||
if {$c eq "(" && $TCL9} { |
||||
#Tcl 9 rejects a bare open paren in an array index at |
||||
#index-token level (inside nested [ ] or $v( ) is fine); |
||||
#Tcl 8.x treats it as ordinary index text. |
||||
error "invalid character in array index" |
||||
} |
||||
} else { |
||||
set stop 0 |
||||
switch -exact -- $c { |
||||
" " - \t - \v - \f - \r - "\n" - ";" { |
||||
set stop 1 |
||||
} |
||||
"\]" { |
||||
if {$nested} { |
||||
set stop 1 |
||||
} |
||||
} |
||||
} |
||||
if {$stop} { |
||||
break |
||||
} |
||||
} |
||||
switch -exact -- $c { |
||||
"\\" { |
||||
if {$mode eq "bare" && $p + 1 < $endpos && [string index $bytes $p+1] eq "\n"} { |
||||
#backslash-newline separates words in bare context |
||||
break |
||||
} |
||||
if {$p + 1 >= $endpos} { |
||||
#trailing backslash with nothing following becomes its |
||||
#own text token (like a bare $) |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
lappend tokens [list text [list $p 1] {}] |
||||
incr p |
||||
set textStart $p |
||||
continue |
||||
} |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
set next [bs_advance $bytes $p $endpos] |
||||
lappend tokens [list backslash [list $p [expr {$next - $p}]] {}] |
||||
set p $next |
||||
set textStart $p |
||||
} |
||||
"$" { |
||||
lassign [parse_varname $bytes $p $endpos] vtok next |
||||
if {$vtok eq ""} { |
||||
#a $ with no variable name following becomes its own |
||||
#text token (it does not merge with adjacent text) |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
lappend tokens [list text [list $p 1] {}] |
||||
incr p |
||||
set textStart $p |
||||
} else { |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
lappend tokens $vtok |
||||
set p $next |
||||
set textStart $p |
||||
} |
||||
} |
||||
"\[" { |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
set q [expr {$p + 1}] |
||||
while {1} { |
||||
lassign [parse_command_bytes $bytes $q $endpos 1] cs cl ks kl q2 term tr |
||||
set q $q2 |
||||
if {$term eq "bracket"} { |
||||
incr q |
||||
break |
||||
} |
||||
if {$term eq "eof"} { |
||||
error "missing close-bracket" |
||||
} |
||||
#nl or semi: further commands inside the brackets |
||||
} |
||||
lappend tokens [list command [list $p [expr {$q - $p}]] {}] |
||||
set p $q |
||||
set textStart $p |
||||
} |
||||
default { |
||||
incr p |
||||
} |
||||
} |
||||
} |
||||
if {$p > $textStart} { |
||||
lappend tokens [list text [list $textStart [expr {$p - $textStart}]] {}] |
||||
} |
||||
return [list $tokens $p] |
||||
} |
||||
|
||||
proc parse_varname {bytes pos endpos} { |
||||
#pos at '$'. Returns {token nextpos}, or {"" pos} when the $ does not |
||||
#introduce a variable (plain text). |
||||
set p [expr {$pos + 1}] |
||||
if {$p >= $endpos} { |
||||
return [list "" $pos] |
||||
} |
||||
set c [string index $bytes $p] |
||||
if {$c eq "\{"} { |
||||
#${name}: Tcl 8.x scans to the FIRST close brace (no escapes); |
||||
#Tcl 9 balances nested braces with backslash-escaped braces not |
||||
#counted (the backslash stays part of the name text). |
||||
variable TCL9 |
||||
if {$TCL9} { |
||||
set level 1 |
||||
set q [expr {$p + 1}] |
||||
while {1} { |
||||
if {$q >= $endpos} { |
||||
error "missing close-brace for variable name" |
||||
} |
||||
set c2 [string index $bytes $q] |
||||
switch -exact -- $c2 { |
||||
"\\" { |
||||
incr q 2 |
||||
} |
||||
"\{" { |
||||
incr level |
||||
incr q |
||||
} |
||||
"\}" { |
||||
incr level -1 |
||||
if {$level == 0} { |
||||
break |
||||
} |
||||
incr q |
||||
} |
||||
default { |
||||
incr q |
||||
} |
||||
} |
||||
} |
||||
set close $q |
||||
} else { |
||||
set close [string first "\}" $bytes $p] |
||||
if {$close < 0 || $close >= $endpos} { |
||||
error "missing close-brace for variable name" |
||||
} |
||||
} |
||||
set nametok [list text [list [expr {$p + 1}] [expr {$close - $p - 1}]] {}] |
||||
set next [expr {$close + 1}] |
||||
return [list [list variable [list $pos [expr {$next - $pos}]] [list $nametok]] $next] |
||||
} |
||||
set nameStart $p |
||||
while {$p < $endpos} { |
||||
set c [string index $bytes $p] |
||||
if {[string match {[a-zA-Z0-9_]} $c]} { |
||||
incr p |
||||
continue |
||||
} |
||||
if {$c eq ":" && $p + 1 < $endpos && [string index $bytes $p+1] eq ":"} { |
||||
incr p 2 |
||||
while {$p < $endpos && [string index $bytes $p] eq ":"} { |
||||
incr p |
||||
} |
||||
continue |
||||
} |
||||
break |
||||
} |
||||
set nameLen [expr {$p - $nameStart}] |
||||
if {$p < $endpos && [string index $bytes $p] eq "("} { |
||||
#array element - name may be empty. Index parsed for |
||||
#substitutions, terminated by the first top-level close paren. |
||||
incr p |
||||
set idxstart $p |
||||
lassign [parse_tokens $bytes $p $endpos index 0] idxtokens p |
||||
if {$p >= $endpos || [string index $bytes $p] ne ")"} { |
||||
error "missing )" |
||||
} |
||||
if {[llength $idxtokens] == 0} { |
||||
#an empty index still carries one empty text token |
||||
set idxtokens [list [list text [list $idxstart 0] {}]] |
||||
} |
||||
incr p |
||||
set nametok [list text [list $nameStart $nameLen] {}] |
||||
set subnodes [list $nametok] |
||||
lappend subnodes {*}$idxtokens |
||||
return [list [list variable [list $pos [expr {$p - $pos}]] $subnodes] $p] |
||||
} |
||||
if {$nameLen == 0} { |
||||
return [list "" $pos] |
||||
} |
||||
set nametok [list text [list $nameStart $nameLen] {}] |
||||
return [list [list variable [list $pos [expr {$p - $pos}]] [list $nametok]] $p] |
||||
} |
||||
|
||||
proc list_elements {bytes start end} { |
||||
#Scan the byte range as a Tcl list (TclFindElement semantics) for |
||||
#parse-time {*} literal expansion. Returns a list of |
||||
#{elemstart elemlen textstart textlen} with text excluding one level |
||||
#of brace/quote enclosure. Errors if the range is not a valid list. |
||||
set p $start |
||||
set out [list] |
||||
while {1} { |
||||
while {$p < $end && [string index $bytes $p] in [list " " \t \n \r \f \v]} { |
||||
incr p |
||||
} |
||||
if {$p >= $end} { |
||||
break |
||||
} |
||||
set c [string index $bytes $p] |
||||
set estart $p |
||||
set kind bare |
||||
if {$c eq "\{"} { |
||||
set kind brace |
||||
set level 1 |
||||
incr p |
||||
set tstart $p |
||||
while {1} { |
||||
if {$p >= $end} { |
||||
error "unmatched open brace in list" |
||||
} |
||||
set c2 [string index $bytes $p] |
||||
if {$c2 eq "\\"} { |
||||
incr p 2 |
||||
continue |
||||
} |
||||
if {$c2 eq "\{"} { |
||||
incr level |
||||
} elseif {$c2 eq "\}"} { |
||||
incr level -1 |
||||
if {$level == 0} { |
||||
break |
||||
} |
||||
} |
||||
incr p |
||||
} |
||||
set tlen [expr {$p - $tstart}] |
||||
incr p |
||||
if {$p < $end && [string index $bytes $p] ni [list " " \t \n \r \f \v]} { |
||||
error "list element in braces followed by \"[string index $bytes $p]\" instead of space" |
||||
} |
||||
} elseif {$c eq "\""} { |
||||
set kind quote |
||||
incr p |
||||
set tstart $p |
||||
while {1} { |
||||
if {$p >= $end} { |
||||
error "unmatched open quote in list" |
||||
} |
||||
set c2 [string index $bytes $p] |
||||
if {$c2 eq "\\"} { |
||||
incr p 2 |
||||
continue |
||||
} |
||||
if {$c2 eq "\""} { |
||||
break |
||||
} |
||||
incr p |
||||
} |
||||
set tlen [expr {$p - $tstart}] |
||||
incr p |
||||
if {$p < $end && [string index $bytes $p] ni [list " " \t \n \r \f \v]} { |
||||
error "list element in quotes followed by \"[string index $bytes $p]\" instead of space" |
||||
} |
||||
} else { |
||||
set tstart $p |
||||
while {$p < $end} { |
||||
set c2 [string index $bytes $p] |
||||
if {$c2 in [list " " \t \n \r \f \v]} { |
||||
break |
||||
} |
||||
if {$c2 eq "\\"} { |
||||
incr p 2 |
||||
continue |
||||
} |
||||
incr p |
||||
} |
||||
if {$p > $end} { |
||||
set p $end |
||||
} |
||||
set tlen [expr {$p - $tstart}] |
||||
} |
||||
#Parse-time literal expansion only applies when every element's |
||||
#value equals its source bytes. A backslash in a bare or quoted |
||||
#element (or backslash-newline in a braced one) needs collapsing, |
||||
#so the whole expansion stays a runtime matter (expand node). |
||||
set seg [string range $bytes $tstart [expr {$tstart + $tlen - 1}]] |
||||
if {$kind eq "brace"} { |
||||
if {[string first "\\\n" $seg] >= 0} { |
||||
error "list element needs backslash collapsing" |
||||
} |
||||
} else { |
||||
if {[string first "\\" $seg] >= 0} { |
||||
error "list element needs backslash collapsing" |
||||
} |
||||
} |
||||
lappend out [list $estart [expr {$p - $estart}] $tstart $tlen] |
||||
} |
||||
return $out |
||||
} |
||||
} |
||||
|
||||
|
||||
# ----------------------------------------------------------------------------- |
||||
# register namespace(s) to have PUNKARGS,PUNKARGS_aliases variables checked |
||||
# ----------------------------------------------------------------------------- |
||||
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::tclparser |
||||
} |
||||
# ----------------------------------------------------------------------------- |
||||
|
||||
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ |
||||
package provide punk::tclparser [tcl::namespace::eval punk::tclparser { |
||||
variable pkg punk::tclparser |
||||
variable version |
||||
set version 0.1.0 |
||||
}] |
||||
## Ready |
||||
return |
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Loading…
Reference in new issue