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.
Binary file not shown.
Loading…
Reference in new issue