#G-054: the 'string is' class set is harvested from the RUNNING interpreter rather
#than hard-coded. It varies by tcl version (8.6 has no dict class; the unreleased
#8.7 series added unicode, which tcl 9 removed) and a static list breaks
#accept/reject parity between these docs and the interpreter they load into.
#A deliberately invalid probe of the pure builtin (safe, side-effect free) yields
#the authoritative list from its error message:
# bad class "zzz": must be alnum, alpha, ..., or xdigit
set string_is_classes [list]
if {[catch {string is __punk_argdoc_probe__ x} _sis_msg]} {
if {[regexp {must be (.+)$} $_sis_msg -> _sis_csv]} {
foreach _sis_c [split $_sis_csv ,] {
set _sis_c [string trim $_sis_c]
if {[string match "or *" $_sis_c]} {
set _sis_c [string range $_sis_c 3 end]
}
if {$_sis_c ne ""} {
lappend string_is_classes $_sis_c
}
}
}
}
if {![llength $string_is_classes]} {
#harvest failed (unexpected error message format) - fall back to the tcl 9.0 set
set string_is_classes {alnum alpha ascii boolean control dict digit double entier false graph integer list lower print punct space true upper wideinteger wordchar xdigit}
}
set string_is_classes [lsort $string_is_classes] ;#display order (as the previous hand-written list)
#hand-written class descriptions (man-page derived, verbatim) - applied below only for
#classes the running interpreter accepts; accepted classes without an entry get a
#generic label. tstr here resolves the ${$A_WARN}/${$A_RST} highlights as before.
set string_is_class_descriptions [punk::args::lib::tstr -return string {
set fchanges [string trim [exec {*}[auto_execok fossil] changes]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine fossil state of source project at $fossilroot ($errM)"
} elseif {$fchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes ([llength [split $fchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
} else {
set flines [list]
foreach line [split $fchanges \n] {
set line [string trim $line]
if {$line eq ""} {continue}
if {$scopeabs ne ""} {
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>'
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue}
set normfile [file normalize [file join $fossilroot $relfile]]
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue}
}
lappend flines $line
}
if {[llength $flines]} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
cd $original_cwd
}
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot 1
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$scope] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot,$scope 1
set gitpathargs [list]
if {$scopeabs ne ""} {
set gitpathargs [list -- $scopeabs]
}
if {[catch {
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain]]
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain {*}$gitpathargs]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)"
} elseif {$gchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
#G-054: the 'string is' class set is harvested from the RUNNING interpreter rather
#than hard-coded. It varies by tcl version (8.6 has no dict class; the unreleased
#8.7 series added unicode, which tcl 9 removed) and a static list breaks
#accept/reject parity between these docs and the interpreter they load into.
#A deliberately invalid probe of the pure builtin (safe, side-effect free) yields
#the authoritative list from its error message:
# bad class "zzz": must be alnum, alpha, ..., or xdigit
set string_is_classes [list]
if {[catch {string is __punk_argdoc_probe__ x} _sis_msg]} {
if {[regexp {must be (.+)$} $_sis_msg -> _sis_csv]} {
foreach _sis_c [split $_sis_csv ,] {
set _sis_c [string trim $_sis_c]
if {[string match "or *" $_sis_c]} {
set _sis_c [string range $_sis_c 3 end]
}
if {$_sis_c ne ""} {
lappend string_is_classes $_sis_c
}
}
}
}
if {![llength $string_is_classes]} {
#harvest failed (unexpected error message format) - fall back to the tcl 9.0 set
set string_is_classes {alnum alpha ascii boolean control dict digit double entier false graph integer list lower print punct space true upper wideinteger wordchar xdigit}
}
set string_is_classes [lsort $string_is_classes] ;#display order (as the previous hand-written list)
#hand-written class descriptions (man-page derived, verbatim) - applied below only for
#classes the running interpreter accepts; accepted classes without an entry get a
#generic label. tstr here resolves the ${$A_WARN}/${$A_RST} highlights as before.
set string_is_class_descriptions [punk::args::lib::tstr -return string {
set fchanges [string trim [exec {*}[auto_execok fossil] changes]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine fossil state of source project at $fossilroot ($errM)"
} elseif {$fchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes ([llength [split $fchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
} else {
set flines [list]
foreach line [split $fchanges \n] {
set line [string trim $line]
if {$line eq ""} {continue}
if {$scopeabs ne ""} {
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>'
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue}
set normfile [file normalize [file join $fossilroot $relfile]]
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue}
}
lappend flines $line
}
if {[llength $flines]} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
cd $original_cwd
}
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot 1
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$scope] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot,$scope 1
set gitpathargs [list]
if {$scopeabs ne ""} {
set gitpathargs [list -- $scopeabs]
}
if {[catch {
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain]]
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain {*}$gitpathargs]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)"
} elseif {$gchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
#G-054: the 'string is' class set is harvested from the RUNNING interpreter rather
#than hard-coded. It varies by tcl version (8.6 has no dict class; the unreleased
#8.7 series added unicode, which tcl 9 removed) and a static list breaks
#accept/reject parity between these docs and the interpreter they load into.
#A deliberately invalid probe of the pure builtin (safe, side-effect free) yields
#the authoritative list from its error message:
# bad class "zzz": must be alnum, alpha, ..., or xdigit
set string_is_classes [list]
if {[catch {string is __punk_argdoc_probe__ x} _sis_msg]} {
if {[regexp {must be (.+)$} $_sis_msg -> _sis_csv]} {
foreach _sis_c [split $_sis_csv ,] {
set _sis_c [string trim $_sis_c]
if {[string match "or *" $_sis_c]} {
set _sis_c [string range $_sis_c 3 end]
}
if {$_sis_c ne ""} {
lappend string_is_classes $_sis_c
}
}
}
}
if {![llength $string_is_classes]} {
#harvest failed (unexpected error message format) - fall back to the tcl 9.0 set
set string_is_classes {alnum alpha ascii boolean control dict digit double entier false graph integer list lower print punct space true upper wideinteger wordchar xdigit}
}
set string_is_classes [lsort $string_is_classes] ;#display order (as the previous hand-written list)
#hand-written class descriptions (man-page derived, verbatim) - applied below only for
#classes the running interpreter accepts; accepted classes without an entry get a
#generic label. tstr here resolves the ${$A_WARN}/${$A_RST} highlights as before.
set string_is_class_descriptions [punk::args::lib::tstr -return string {
set fchanges [string trim [exec {*}[auto_execok fossil] changes]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine fossil state of source project at $fossilroot ($errM)"
} elseif {$fchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes ([llength [split $fchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
} else {
set flines [list]
foreach line [split $fchanges \n] {
set line [string trim $line]
if {$line eq ""} {continue}
if {$scopeabs ne ""} {
#fossil changes lines are '<STATUS> <path-relative-to-checkout-root>'
if {![regexp {^\S+\s+(.*)$} $line _ relfile]} {continue}
set normfile [file normalize [file join $fossilroot $relfile]]
if {$normfile ne $scopeabs && ![string match "${scopeabs}/*" $normfile]} {continue}
}
lappend flines $line
}
if {[llength $flines]} {
lappend warnings "WARNING: ${label}source project at $fossilroot has uncommitted fossil changes${scopedesc} ([llength $flines] file(s)) - artifacts built from a dirty tree have no committed provenance"
}
}
cd $original_cwd
}
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot 1
if {$gitroot ne "" && ![dict exists $checkedroots git,$gitroot,$scope] && [llength [auto_execok git]]} {
dict set checkedroots git,$gitroot,$scope 1
set gitpathargs [list]
if {$scopeabs ne ""} {
set gitpathargs [list -- $scopeabs]
}
if {[catch {
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain]]
set gchanges [string trim [exec {*}[auto_execok git] -C $gitroot status --porcelain {*}$gitpathargs]]
} errM]} {
lappend warnings "WARNING: ${label}could not determine git state of source project at $gitroot ($errM)"
} elseif {$gchanges ne ""} {
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"
lappend warnings "WARNING: ${label}source project at $gitroot has uncommitted git changes${scopedesc} ([llength [split $gchanges \n]] file(s)) - artifacts built from a dirty tree have no committed provenance"