diff --git a/src/bootsupport/modules/dictutils-0.2.1.tm b/src/bootsupport/modules/dictutils-0.2.1.tm index cd6b4e58..12ca495b 100644 --- a/src/bootsupport/modules/dictutils-0.2.1.tm +++ b/src/bootsupport/modules/dictutils-0.2.1.tm @@ -1,145 +1,145 @@ -# dictutils.tcl -- - # - # Various dictionary utilities. - # - # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). - # - # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). - # - - #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" - - package require Tcl 8.6- - package provide dictutils 0.2.1 - - namespace eval dictutils { - namespace export equal apply capture witharray nlappend - namespace ensemble create - - # dictutils witharray dictVar arrayVar script -- - # - # Unpacks the elements of the dictionary in dictVar into the array - # variable arrayVar and then evaluates the script. If the script - # completes with an ok, return or continue status, then the result is copied - # back into the dictionary variable, otherwise it is discarded. A - # [break] can be used to explicitly abort the transaction. - # - proc witharray {dictVar arrayVar script} { - upvar 1 $dictVar dict $arrayVar array - array set array $dict - try { uplevel 1 $script - } on break {} { # Discard the result - } on continue result - on ok result { - set dict [array get array] ;# commit changes - return $result - } on return {result opts} { - set dict [array get array] ;# commit changes - dict incr opts -level ;# remove this proc from level - return -options $opts $result - } - # All other cases will discard the changes and propagage - } - - # dictutils equal equalp d1 d2 -- - # - # Compare two dictionaries for equality. Two dictionaries are equal - # if they (a) have the same keys, (b) the corresponding values for - # each key in the two dictionaries are equal when compared using the - # equality predicate, equalp (passed as an argument). The equality - # predicate is invoked with the key and the two values from each - # dictionary as arguments. - # - proc equal {equalp d1 d2} { - if {[dict size $d1] != [dict size $d2]} { return 0 } - dict for {k v} $d1 { - if {![dict exists $d2 $k]} { return 0 } - if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } - } - return 1 - } - - # apply dictVar lambdaExpr ?arg1 arg2 ...? -- - # - # A combination of *dict with* and *apply*, this procedure creates a - # new procedure scope populated with the values in the dictionary - # variable. It then applies the lambdaTerm (anonymous procedure) in - # this new scope. If the procedure completes normally, then any - # changes made to variables in the dictionary are reflected back to - # the dictionary variable, otherwise they are ignored. This provides - # a transaction-style semantics whereby atomic updates to a - # dictionary can be performed. This procedure can also be useful for - # implementing a variety of control constructs, such as mutable - # closures. - # - proc apply {dictVar lambdaExpr args} { - upvar 1 $dictVar dict - set env $dict ;# copy - lassign $lambdaExpr params body ns - if {$ns eq ""} { set ns "::" } - set body [format { - upvar 1 env __env__ - dict with __env__ %s - } [list $body]] - set lambdaExpr [list $params $body $ns] - set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] - if {$rc == 0} { - # Copy back any updates - set dict $env - } - return -options $opts $ret - } - - # capture ?level? ?exclude? ?include? -- - # - # Captures a snapshot of the current (scalar) variable bindings at - # $level on the stack into a dictionary environment. This dictionary - # can later be used with *dictutils apply* to partially restore the - # scope, creating a first approximation of closures. The *level* - # argument should be of the forms accepted by *uplevel* and - # designates which level to capture. It defaults to 1 as in uplevel. - # The *exclude* argument specifies an optional list of literal - # variable names to avoid when performing the capture. No variables - # matching any item in this list will be captured. The *include* - # argument can be used to specify a list of glob patterns of - # variables to capture. Only variables matching one of these - # patterns are captured. The default is a single pattern "*", for - # capturing all visible variables (as determined by *info vars*). - # - proc capture {{level 1} {exclude {}} {include {*}}} { - if {[string is integer $level]} { incr level } - set env [dict create] - foreach pattern $include { - foreach name [uplevel $level [list info vars $pattern]] { - if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } - upvar $level $name value - catch { dict set env $name $value } ;# no arrays - } - } - return $env - } - - # nlappend dictVar keyList ?value ...? - # - # Append zero or more elements to the list value stored in the given - # dictionary at the path of keys specified in $keyList. If $keyList - # specifies a non-existent path of keys, nlappend will behave as if - # the path mapped to an empty list. - # - proc nlappend {dictvar keylist args} { - upvar 1 $dictvar dict - if {[info exists dict] && [dict exists $dict {*}$keylist]} { - set list [dict get $dict {*}$keylist] - } - lappend list {*}$args - dict set dict {*}$keylist $list - } - - # invoke cmd args... -- - # - # Helper procedure to invoke a callback command with arguments at - # the global scope. The helper ensures that proper quotation is - # used. The command is expected to be a list, e.g. {string equal}. - # - proc invoke {cmd args} { uplevel #0 $cmd $args } - - } +# dictutils.tcl -- + # + # Various dictionary utilities. + # + # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). + # + # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). + # + + #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" + + package require Tcl 8.6- + package provide dictutils 0.2.1 + + namespace eval dictutils { + namespace export equal apply capture witharray nlappend + namespace ensemble create + + # dictutils witharray dictVar arrayVar script -- + # + # Unpacks the elements of the dictionary in dictVar into the array + # variable arrayVar and then evaluates the script. If the script + # completes with an ok, return or continue status, then the result is copied + # back into the dictionary variable, otherwise it is discarded. A + # [break] can be used to explicitly abort the transaction. + # + proc witharray {dictVar arrayVar script} { + upvar 1 $dictVar dict $arrayVar array + array set array $dict + try { uplevel 1 $script + } on break {} { # Discard the result + } on continue result - on ok result { + set dict [array get array] ;# commit changes + return $result + } on return {result opts} { + set dict [array get array] ;# commit changes + dict incr opts -level ;# remove this proc from level + return -options $opts $result + } + # All other cases will discard the changes and propagage + } + + # dictutils equal equalp d1 d2 -- + # + # Compare two dictionaries for equality. Two dictionaries are equal + # if they (a) have the same keys, (b) the corresponding values for + # each key in the two dictionaries are equal when compared using the + # equality predicate, equalp (passed as an argument). The equality + # predicate is invoked with the key and the two values from each + # dictionary as arguments. + # + proc equal {equalp d1 d2} { + if {[dict size $d1] != [dict size $d2]} { return 0 } + dict for {k v} $d1 { + if {![dict exists $d2 $k]} { return 0 } + if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } + } + return 1 + } + + # apply dictVar lambdaExpr ?arg1 arg2 ...? -- + # + # A combination of *dict with* and *apply*, this procedure creates a + # new procedure scope populated with the values in the dictionary + # variable. It then applies the lambdaTerm (anonymous procedure) in + # this new scope. If the procedure completes normally, then any + # changes made to variables in the dictionary are reflected back to + # the dictionary variable, otherwise they are ignored. This provides + # a transaction-style semantics whereby atomic updates to a + # dictionary can be performed. This procedure can also be useful for + # implementing a variety of control constructs, such as mutable + # closures. + # + proc apply {dictVar lambdaExpr args} { + upvar 1 $dictVar dict + set env $dict ;# copy + lassign $lambdaExpr params body ns + if {$ns eq ""} { set ns "::" } + set body [format { + upvar 1 env __env__ + dict with __env__ %s + } [list $body]] + set lambdaExpr [list $params $body $ns] + set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] + if {$rc == 0} { + # Copy back any updates + set dict $env + } + return -options $opts $ret + } + + # capture ?level? ?exclude? ?include? -- + # + # Captures a snapshot of the current (scalar) variable bindings at + # $level on the stack into a dictionary environment. This dictionary + # can later be used with *dictutils apply* to partially restore the + # scope, creating a first approximation of closures. The *level* + # argument should be of the forms accepted by *uplevel* and + # designates which level to capture. It defaults to 1 as in uplevel. + # The *exclude* argument specifies an optional list of literal + # variable names to avoid when performing the capture. No variables + # matching any item in this list will be captured. The *include* + # argument can be used to specify a list of glob patterns of + # variables to capture. Only variables matching one of these + # patterns are captured. The default is a single pattern "*", for + # capturing all visible variables (as determined by *info vars*). + # + proc capture {{level 1} {exclude {}} {include {*}}} { + if {[string is integer $level]} { incr level } + set env [dict create] + foreach pattern $include { + foreach name [uplevel $level [list info vars $pattern]] { + if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } + upvar $level $name value + catch { dict set env $name $value } ;# no arrays + } + } + return $env + } + + # nlappend dictVar keyList ?value ...? + # + # Append zero or more elements to the list value stored in the given + # dictionary at the path of keys specified in $keyList. If $keyList + # specifies a non-existent path of keys, nlappend will behave as if + # the path mapped to an empty list. + # + proc nlappend {dictvar keylist args} { + upvar 1 $dictvar dict + if {[info exists dict] && [dict exists $dict {*}$keylist]} { + set list [dict get $dict {*}$keylist] + } + lappend list {*}$args + dict set dict {*}$keylist $list + } + + # invoke cmd args... -- + # + # Helper procedure to invoke a callback command with arguments at + # the global scope. The helper ensures that proper quotation is + # used. The command is expected to be a list, e.g. {string equal}. + # + proc invoke {cmd args} { uplevel #0 $cmd $args } + + } diff --git a/src/bootsupport/include_modules.config b/src/bootsupport/modules/include_modules.config similarity index 87% rename from src/bootsupport/include_modules.config rename to src/bootsupport/modules/include_modules.config index cd46f833..55093f48 100644 --- a/src/bootsupport/include_modules.config +++ b/src/bootsupport/modules/include_modules.config @@ -1,4 +1,7 @@ +#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project +#They must be already built, so generally shouldn't come directly from src/modules. + #each entry - base module set bootsupport_modules [list\ src/vendormodules cksum\ @@ -58,7 +61,3 @@ set bootsupport_modules [list\ modules oolib\ ] -#each entry - base subpath -set bootsupport_module_folders [list\ - modules punk/mix/templates -] diff --git a/src/bootsupport/modules/mime-1.7.0.tm b/src/bootsupport/modules/mime-1.7.0.tm deleted file mode 100644 index fa460769..00000000 --- a/src/bootsupport/modules/mime-1.7.0.tm +++ /dev/null @@ -1,3942 +0,0 @@ -# mime.tcl - MIME body parts -# -# (c) 1999-2000 Marshall T. Rose -# (c) 2000 Brent Welch -# (c) 2000 Sandeep Tamhankar -# (c) 2000 Dan Kuchler -# (c) 2000-2001 Eric Melski -# (c) 2001 Jeff Hobbs -# (c) 2001-2008 Andreas Kupries -# (c) 2002-2003 David Welton -# (c) 2003-2008 Pat Thoyts -# (c) 2005 Benjamin Riefenstahl -# (c) 2013-2021 Poor Yorick -# -# -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. -# -# Influenced by Borenstein's/Rose's safe-tcl (circa 1993) and Darren New's -# unpublished package of 1999. -# - -# new string features and inline scan are used, requiring 8.3. -package require Tcl 8.5 - -package provide mime 1.7.0 -package require tcl::chan::memchan - - -if {[catch {package require Trf 2.0}]} { - - # Fall-back to tcl-based procedures of base64 and quoted-printable - # encoders - ## - # Warning! - ## - # These are a fragile emulations of the more general calling - # sequence that appears to work with this code here. - ## - # The `__ignored__` arguments are expected to be `--` options on - # the caller's side. (See the uses in `copymessageaux`, - # `buildmessageaux`, `parsepart`, and `getbody`). - - package require base64 2.0 - set ::major [lindex [split [package require md5] .] 0] - - # Create these commands in the mime namespace so that they - # won't collide with things at the global namespace level - - namespace eval ::mime { - proc base64 {-mode what __ignored__ chunk} { - return [base64::$what $chunk] - } - proc quoted-printable {-mode what __ignored__ chunk} { - return [mime::qp_$what $chunk] - } - - if {$::major < 2} { - # md5 v1, result is hex string ready for use. - proc md5 {__ignored__ string} { - return [md5::md5 $string] - } - } else { - # md5 v2, need option to get hex string - proc md5 {__ignored__ string} { - return [md5::md5 -hex $string] - } - } - } - - unset ::major -} - -# -# state variables: -# -# canonicalP: input is in its canonical form -# content: type/subtype -# params: dictionary (keys are lower-case) -# encoding: transfer encoding -# version: MIME-version -# header: dictionary (keys are lower-case) -# lowerL: list of header keys, lower-case -# mixedL: list of header keys, mixed-case -# value: either "file", "parts", or "string" -# -# file: input file -# fd: cached file-descriptor, typically for root -# root: token for top-level part, for (distant) subordinates -# offset: number of octets from beginning of file/string -# count: length in octets of (encoded) content -# -# parts: list of bodies (tokens) -# -# string: input string -# -# cid: last child-id assigned -# - - -namespace eval ::mime { - variable mime - array set mime {uid 0 cid 0} - - # RFC 822 lexemes - variable addrtokenL - lappend addrtokenL \; , < > : . ( ) @ \" \[ ] \\ - variable addrlexemeL { - LX_SEMICOLON LX_COMMA - LX_LBRACKET LX_RBRACKET - LX_COLON LX_DOT - LX_LPAREN LX_RPAREN - LX_ATSIGN LX_QUOTE - LX_LSQUARE LX_RSQUARE - LX_QUOTE - } - - # RFC 2045 lexemes - variable typetokenL - lappend typetokenL \; , < > : ? ( ) @ \" \[ \] = / \\ - variable typelexemeL { - LX_SEMICOLON LX_COMMA - LX_LBRACKET LX_RBRACKET - LX_COLON LX_QUESTION - LX_LPAREN LX_RPAREN - LX_ATSIGN LX_QUOTE - LX_LSQUARE LX_RSQUARE - LX_EQUALS LX_SOLIDUS - LX_QUOTE - } - - variable encList { - ascii US-ASCII - big5 Big5 - cp1250 Windows-1250 - cp1251 Windows-1251 - cp1252 Windows-1252 - cp1253 Windows-1253 - cp1254 Windows-1254 - cp1255 Windows-1255 - cp1256 Windows-1256 - cp1257 Windows-1257 - cp1258 Windows-1258 - cp437 IBM437 - cp737 {} - cp775 IBM775 - cp850 IBM850 - cp852 IBM852 - cp855 IBM855 - cp857 IBM857 - cp860 IBM860 - cp861 IBM861 - cp862 IBM862 - cp863 IBM863 - cp864 IBM864 - cp865 IBM865 - cp866 IBM866 - cp869 IBM869 - cp874 {} - cp932 {} - cp936 GBK - cp949 {} - cp950 {} - dingbats {} - ebcdic {} - euc-cn EUC-CN - euc-jp EUC-JP - euc-kr EUC-KR - gb12345 GB12345 - gb1988 GB1988 - gb2312 GB2312 - iso2022 ISO-2022 - iso2022-jp ISO-2022-JP - iso2022-kr ISO-2022-KR - iso8859-1 ISO-8859-1 - iso8859-2 ISO-8859-2 - iso8859-3 ISO-8859-3 - iso8859-4 ISO-8859-4 - iso8859-5 ISO-8859-5 - iso8859-6 ISO-8859-6 - iso8859-7 ISO-8859-7 - iso8859-8 ISO-8859-8 - iso8859-9 ISO-8859-9 - iso8859-10 ISO-8859-10 - iso8859-13 ISO-8859-13 - iso8859-14 ISO-8859-14 - iso8859-15 ISO-8859-15 - iso8859-16 ISO-8859-16 - jis0201 JIS_X0201 - jis0208 JIS_C6226-1983 - jis0212 JIS_X0212-1990 - koi8-r KOI8-R - koi8-u KOI8-U - ksc5601 KS_C_5601-1987 - macCentEuro {} - macCroatian {} - macCyrillic {} - macDingbats {} - macGreek {} - macIceland {} - macJapan {} - macRoman {} - macRomania {} - macThai {} - macTurkish {} - macUkraine {} - shiftjis Shift_JIS - symbol {} - tis-620 TIS-620 - unicode {} - utf-8 UTF-8 - } - - variable encodings - array set encodings $encList - variable reversemap - # Initialized at the bottom of the file - - variable encAliasList { - ascii ANSI_X3.4-1968 - ascii iso-ir-6 - ascii ANSI_X3.4-1986 - ascii ISO_646.irv:1991 - ascii ASCII - ascii ISO646-US - ascii us - ascii IBM367 - ascii cp367 - cp437 cp437 - cp437 437 - cp775 cp775 - cp850 cp850 - cp850 850 - cp852 cp852 - cp852 852 - cp855 cp855 - cp855 855 - cp857 cp857 - cp857 857 - cp860 cp860 - cp860 860 - cp861 cp861 - cp861 861 - cp861 cp-is - cp862 cp862 - cp862 862 - cp863 cp863 - cp863 863 - cp864 cp864 - cp865 cp865 - cp865 865 - cp866 cp866 - cp866 866 - cp869 cp869 - cp869 869 - cp869 cp-gr - cp936 CP936 - cp936 MS936 - cp936 Windows-936 - iso8859-1 ISO_8859-1:1987 - iso8859-1 iso-ir-100 - iso8859-1 ISO_8859-1 - iso8859-1 latin1 - iso8859-1 l1 - iso8859-1 IBM819 - iso8859-1 CP819 - iso8859-2 ISO_8859-2:1987 - iso8859-2 iso-ir-101 - iso8859-2 ISO_8859-2 - iso8859-2 latin2 - iso8859-2 l2 - iso8859-3 ISO_8859-3:1988 - iso8859-3 iso-ir-109 - iso8859-3 ISO_8859-3 - iso8859-3 latin3 - iso8859-3 l3 - iso8859-4 ISO_8859-4:1988 - iso8859-4 iso-ir-110 - iso8859-4 ISO_8859-4 - iso8859-4 latin4 - iso8859-4 l4 - iso8859-5 ISO_8859-5:1988 - iso8859-5 iso-ir-144 - iso8859-5 ISO_8859-5 - iso8859-5 cyrillic - iso8859-6 ISO_8859-6:1987 - iso8859-6 iso-ir-127 - iso8859-6 ISO_8859-6 - iso8859-6 ECMA-114 - iso8859-6 ASMO-708 - iso8859-6 arabic - iso8859-7 ISO_8859-7:1987 - iso8859-7 iso-ir-126 - iso8859-7 ISO_8859-7 - iso8859-7 ELOT_928 - iso8859-7 ECMA-118 - iso8859-7 greek - iso8859-7 greek8 - iso8859-8 ISO_8859-8:1988 - iso8859-8 iso-ir-138 - iso8859-8 ISO_8859-8 - iso8859-8 hebrew - iso8859-9 ISO_8859-9:1989 - iso8859-9 iso-ir-148 - iso8859-9 ISO_8859-9 - iso8859-9 latin5 - iso8859-9 l5 - iso8859-10 iso-ir-157 - iso8859-10 l6 - iso8859-10 ISO_8859-10:1992 - iso8859-10 latin6 - iso8859-14 iso-ir-199 - iso8859-14 ISO_8859-14:1998 - iso8859-14 ISO_8859-14 - iso8859-14 latin8 - iso8859-14 iso-celtic - iso8859-14 l8 - iso8859-15 ISO_8859-15 - iso8859-15 Latin-9 - iso8859-16 iso-ir-226 - iso8859-16 ISO_8859-16:2001 - iso8859-16 ISO_8859-16 - iso8859-16 latin10 - iso8859-16 l10 - jis0201 X0201 - jis0208 iso-ir-87 - jis0208 x0208 - jis0208 JIS_X0208-1983 - jis0212 x0212 - jis0212 iso-ir-159 - ksc5601 iso-ir-149 - ksc5601 KS_C_5601-1989 - ksc5601 KSC5601 - ksc5601 korean - shiftjis MS_Kanji - utf-8 UTF8 - } - - namespace export {*}{ - copymessage finalize getbody getheader getproperty initialize - mapencoding parseaddress parsedatetime reversemapencoding setheader - uniqueID - } -} - -# ::mime::initialize -- -# -# Creates a MIME part, and returnes the MIME token for that part. -# -# Arguments: -# args Args can be any one of the following: -# ?-canonical type/subtype -# ?-param {key value}?... -# ?-encoding value? -# ?-header {key value}?... ? -# (-file name | -string value | -parts {token1 ... tokenN}) -# -# If the -canonical option is present, then the body is in -# canonical (raw) form and is found by consulting either the -file, -# -string, or -parts option. -# -# In addition, both the -param and -header options may occur zero -# or more times to specify "Content-Type" parameters (e.g., -# "charset") and header keyword/values (e.g., -# "Content-Disposition"), respectively. -# -# Also, -encoding, if present, specifies the -# "Content-Transfer-Encoding" when copying the body. -# -# If the -canonical option is not present, then the MIME part -# contained in either the -file or the -string option is parsed, -# dynamically generating subordinates as appropriate. -# -# Results: -# An initialized mime token. - -proc ::mime::initialize args { - global errorCode errorInfo - - variable mime - - set token [namespace current]::[incr mime(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[catch [list mime::initializeaux $token {*}$args] result eopts]} { - catch {mime::finalize $token -subordinates dynamic} - return -options $eopts $result - } - return $token -} - -# ::mime::initializeaux -- -# -# Configures the MIME token created in mime::initialize based on -# the arguments that mime::initialize supports. -# -# Arguments: -# token The MIME token to configure. -# args Args can be any one of the following: -# ?-canonical type/subtype -# ?-param {key value}?... -# ?-encoding value? -# ?-header {key value}?... ? -# (-file name | -string value | -parts {token1 ... tokenN}) -# -# Results: -# Either configures the mime token, or throws an error. - -proc ::mime::initializeaux {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set params [set state(params) {}] - set state(encoding) {} - set state(version) 1.0 - - set state(header) {} - set state(lowerL) {} - set state(mixedL) {} - - set state(cid) 0 - - set userheader 0 - - set argc [llength $args] - for {set argx 0} {$argx < $argc} {incr argx} { - set option [lindex $args $argx] - if {[incr argx] >= $argc} { - error "missing argument to $option" - } - set value [lindex $args $argx] - - switch -- $option { - -canonical { - set state(content) [string tolower $value] - } - - -param { - if {[llength $value] != 2} { - error "-param expects a key and a value, not $value" - } - set lower [string tolower [set mixed [lindex $value 0]]] - if {[info exists params($lower)]} { - error "the $mixed parameter may be specified at most once" - } - - set params($lower) [lindex $value 1] - set state(params) [array get params] - } - - -encoding { - set value [string tolower $value[set value {}]] - - switch -- $value { - 7bit - 8bit - binary - quoted-printable - base64 { - } - - default { - error "unknown value for -encoding $state(encoding)" - } - } - set state(encoding) [string tolower $value] - } - - -header { - if {[llength $value] != 2} { - error "-header expects a key and a value, not $value" - } - set lower [string tolower [set mixed [lindex $value 0]]] - if {$lower eq {content-type}} { - error "use -canonical instead of -header $value" - } - if {$lower eq {content-transfer-encoding}} { - error "use -encoding instead of -header $value" - } - if {$lower in {content-md5 mime-version}} { - error {don't go there...} - } - if {$lower ni $state(lowerL)} { - lappend state(lowerL) $lower - lappend state(mixedL) $mixed - } - - set userheader 1 - - array set header $state(header) - lappend header($lower) [lindex $value 1] - set state(header) [array get header] - } - - -file { - set state(file) $value - } - - -parts { - set state(parts) $value - } - - -string { - set state(string) $value - - set state(lines) [split $value \n] - set state(lines.count) [llength $state(lines)] - set state(lines.current) 0 - } - - -root { - # the following are internal options - - set state(root) $value - } - - -offset { - set state(offset) $value - } - - -count { - set state(count) $value - } - - -lineslist { - set state(lines) $value - set state(lines.count) [llength $state(lines)] - set state(lines.current) 0 - #state(string) is needed, but will be built when required - set state(string) {} - } - - default { - error "unknown option $option" - } - } - } - - #We only want one of -file, -parts or -string: - set valueN 0 - foreach value {file parts string} { - if {[info exists state($value)]} { - set state(value) $value - incr valueN - } - } - if {$valueN != 1 && ![info exists state(lines)]} { - error {specify exactly one of -file, -parts, or -string} - } - - if {[set state(canonicalP) [info exists state(content)]]} { - switch -- $state(value) { - file { - set state(offset) 0 - } - - parts { - switch -glob -- $state(content) { - text/* - - - image/* - - - audio/* - - - video/* { - error "-canonical $state(content) and -parts do not mix" - } - - default { - if {$state(encoding) ne {}} { - error {-encoding and -parts do not mix} - } - } - } - } - default {# Go ahead} - } - - if {[lsearch -exact $state(lowerL) content-id] < 0} { - lappend state(lowerL) content-id - lappend state(mixedL) Content-ID - - array set header $state(header) - lappend header(content-id) [uniqueID] - set state(header) [array get header] - } - - set state(version) 1.0 - return - } - - if {$state(params) ne {}} { - error {-param requires -canonical} - } - if {$state(encoding) ne {}} { - error {-encoding requires -canonical} - } - if {$userheader} { - error {-header requires -canonical} - } - if {[info exists state(parts)]} { - error {-parts requires -canonical} - } - - if {[set fileP [info exists state(file)]]} { - if {[set openP [info exists state(root)]]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - set state(fd) $root(fd) - } else { - set state(root) $token - set state(fd) [open $state(file) RDONLY] - set state(offset) 0 - seek $state(fd) 0 end - set state(count) [tell $state(fd)] - - fconfigure $state(fd) -translation binary - } - } - - set code [catch {mime::parsepart $token} result] - set ecode $errorCode - set einfo $errorInfo - - if {$fileP} { - if {!$openP} { - unset state(root) - catch {close $state(fd)} - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parsepart -- -# -# Parses the MIME headers and attempts to break up the message -# into its various parts, creating a MIME token for each part. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Throws an error if it has problems parsing the MIME token, -# otherwise it just sets up the appropriate variables. - -proc ::mime::parsepart {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[set fileP [info exists state(file)]]} { - seek $state(fd) [set pos $state(offset)] start - set last [expr {$state(offset) + $state(count) - 1}] - } else { - set string $state(string) - } - - set vline {} - while 1 { - set blankP 0 - if {$fileP} { - if {($pos > $last) || ([set x [gets $state(fd) line]] <= 0)} { - set blankP 1 - } else { - incr pos [expr {$x + 1}] - } - } else { - if {$state(lines.current) >= $state(lines.count)} { - set blankP 1 - set line {} - } else { - set line [lindex $state(lines) $state(lines.current)] - incr state(lines.current) - set x [string length $line] - if {$x == 0} {set blankP 1} - } - } - - if {!$blankP && [string match *\r $line]} { - set line [string range $line 0 $x-2]] - if {$x == 1} { - set blankP 1 - } - } - - if {!$blankP && ( - [string first { } $line] == 0 - || - [string first \t $line] == 0 - )} { - append vline \n $line - continue - } - - if {$vline eq {}} { - if {$blankP} { - break - } - - set vline $line - continue - } - - if { - [set x [string first : $vline]] <= 0 - || - [set mixed [string trimright [ - string range $vline 0 [expr {$x - 1}]]]] eq {} - } { - error "improper line in header: $vline" - } - set value [string trim [string range $vline [expr {$x + 1}] end]] - switch -- [set lower [string tolower $mixed]] { - content-type { - if {[info exists state(content)]} { - error "multiple Content-Type fields starting with $vline" - } - - if {![catch {set x [parsetype $token $value]}]} { - set state(content) [lindex $x 0] - set state(params) [lindex $x 1] - } - } - - content-md5 { - } - - content-transfer-encoding { - if { - $state(encoding) ne {} - && - $state(encoding) ne [string tolower $value] - } { - error "multiple Content-Transfer-Encoding fields starting with $vline" - } - - set state(encoding) [string tolower $value] - } - - mime-version { - set state(version) $value - } - - default { - if {[lsearch -exact $state(lowerL) $lower] < 0} { - lappend state(lowerL) $lower - lappend state(mixedL) $mixed - } - - array set header $state(header) - lappend header($lower) $value - set state(header) [array get header] - } - } - - if {$blankP} { - break - } - set vline $line - } - - if {![info exists state(content)]} { - set state(content) text/plain - set state(params) [list charset us-ascii] - } - - if {![string match multipart/* $state(content)]} { - if {$fileP} { - set x [tell $state(fd)] - incr state(count) [expr {$state(offset) - $x}] - set state(offset) $x - } else { - # rebuild string, this is cheap and needed by other functions - set state(string) [join [ - lrange $state(lines) $state(lines.current) end] \n] - } - - if {[string match message/* $state(content)]} { - # FRINK: nocheck - variable [set child $token-[incr state(cid)]] - - set state(value) parts - set state(parts) $child - if {$fileP} { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $state(offset) -count $state(count) - } else { - if {[info exists state(encoding)]} { - set strng [join [ - lrange $state(lines) $state(lines.current) end] \n] - switch -- $state(encoding) { - base64 - - quoted-printable { - set strng [$state(encoding) -mode decode -- $strng] - } - default {} - } - mime::initializeaux $child -string $strng - } else { - mime::initializeaux $child -lineslist [ - lrange $state(lines) $state(lines.current) end] - } - } - } - - return - } - - set state(value) parts - - set boundary {} - foreach {k v} $state(params) { - if {$k eq {boundary}} { - set boundary $v - break - } - } - if {$boundary eq {}} { - error "boundary parameter is missing in $state(content)" - } - if {[string trim $boundary] eq {}} { - error "boundary parameter is empty in $state(content)" - } - - if {$fileP} { - set pos [tell $state(fd)] - # This variable is like 'start', for the reasons laid out - # below, in the other branch of this conditional. - set initialpos $pos - } else { - # This variable is like 'start', a list of lines in the - # part. This record is made even before we find a starting - # boundary and used if we run into the terminating boundary - # before a starting boundary was found. In that case the lines - # before the terminator as recorded by tracelines are seen as - # the part, or at least we attempt to parse them as a - # part. See the forceoctet and nochild flags later. We cannot - # use 'start' as that records lines only after the starting - # boundary was found. - set tracelines [list] - } - - set inP 0 - set moreP 1 - set forceoctet 0 - while {$moreP} { - if {$fileP} { - if {$pos > $last} { - # We have run over the end of the part per the outer - # information without finding a terminating boundary. - # We now fake the boundary and force the parser to - # give any new part coming of this a mime-type of - # application/octet-stream regardless of header - # information. - set line "--$boundary--" - set x [string length $line] - set forceoctet 1 - } else { - if {[set x [gets $state(fd) line]] < 0} { - error "end-of-file encountered while parsing $state(content)" - } - } - incr pos [expr {$x + 1}] - } else { - if {$state(lines.current) >= $state(lines.count)} { - error "end-of-string encountered while parsing $state(content)" - } else { - set line [lindex $state(lines) $state(lines.current)] - incr state(lines.current) - set x [string length $line] - } - set x [string length $line] - } - if {[string last \r $line] == $x - 1} { - set line [string range $line 0 [expr {$x - 2}]] - set crlf 2 - } else { - set crlf 1 - } - - if {[string first --$boundary $line] != 0} { - if {$inP && !$fileP} { - lappend start $line - } - continue - } else { - lappend tracelines $line - } - - if {!$inP} { - # Haven't seen the starting boundary yet. Check if the - # current line contains this starting boundary. - - if {$line eq "--$boundary"} { - # Yes. Switch parser state to now search for the - # terminating boundary of the part and record where - # the part begins (or initialize the recorder for the - # lines in the part). - set inP 1 - if {$fileP} { - set start $pos - } else { - set start [list] - } - continue - } elseif {$line eq "--$boundary--"} { - # We just saw a terminating boundary before we ever - # saw the starting boundary of a part. This forces us - # to stop parsing, we do this by forcing the parser - # into an accepting state. We will try to create a - # child part based on faked start position or recorded - # lines, or, if that fails, let the current part have - # no children. - - # As an example note the test case mime-3.7 and the - # referenced file "badmail1.txt". - - set inP 1 - if {$fileP} { - set start $initialpos - } else { - set start $tracelines - } - set forceoctet 1 - # Fall through. This brings to the creation of the new - # part instead of searching further and possible - # running over the end. - } else { - continue - } - } - - # Looking for the end of the current part. We accept both a - # terminating boundary and the starting boundary of the next - # part as the end of the current part. - - if {[set moreP [string compare $line --$boundary--]] - && $line ne "--$boundary"} { - - # The current part has not ended, so we record the line - # if we are inside a part and doing string parsing. - if {$inP && !$fileP} { - lappend start $line - } - continue - } - - # The current part has ended. We now determine the exact - # boundaries, create a mime part object for it and recursively - # parse it deeper as part of that action. - - # FRINK: nocheck - variable [set child $token-[incr state(cid)]] - - lappend state(parts) $child - - set nochild 0 - if {$fileP} { - if {[set count [expr {$pos - ($start + $x + $crlf + 1)}]] < 0} { - set count 0 - } - if {$forceoctet} { - set ::errorInfo {} - if {[catch { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $start -count $count - }]} { - set nochild 1 - set state(parts) [lrange $state(parts) 0 end-1] - } } else { - mime::initializeaux $child \ - -file $state(file) -root $state(root) \ - -offset $start -count $count - } - seek $state(fd) [set start $pos] start - } else { - if {$forceoctet} { - if {[catch { - mime::initializeaux $child -lineslist $start - }]} { - set nochild 1 - set state(parts) [lrange $state(parts) 0 end-1] - } - } else { - mime::initializeaux $child -lineslist $start - } - set start {} - } - if {$forceoctet && !$nochild} { - variable $child - upvar 0 $child childstate - set childstate(content) application/octet-stream - } - set forceoctet 0 - } -} - -# ::mime::parsetype -- -# -# Parses the string passed in and identifies the content-type and -# params strings. -# -# Arguments: -# token The MIME token to parse. -# string The content-type string that should be parsed. -# -# Results: -# Returns the content and params for the string as a two element -# tcl list. - -proc ::mime::parsetype {token string} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - variable typetokenL - variable typelexemeL - - set state(input) $string - set state(buffer) {} - set state(lastC) LX_END - set state(comment) {} - set state(tokenL) $typetokenL - set state(lexemeL) $typelexemeL - - set code [catch {mime::parsetypeaux $token $string} result] - set ecode $errorCode - set einfo $errorInfo - - unset {*}{ - state(input) - state(buffer) - state(lastC) - state(comment) - state(tokenL) - state(lexemeL) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parsetypeaux -- -# -# A helper function for mime::parsetype. Parses the specified -# string looking for the content type and params. -# -# Arguments: -# token The MIME token to parse. -# string The content-type string that should be parsed. -# -# Results: -# Returns the content and params for the string as a two element -# tcl list. - -proc ::mime::parsetypeaux {token string} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[parselexeme $token] ne {LX_ATOM}} { - error [format {expecting type (found %s)} $state(buffer)] - } - set type [string tolower $state(buffer)] - - switch -- [parselexeme $token] { - LX_SOLIDUS { - } - - LX_END { - if {$type ne {message}} { - error "expecting type/subtype (found $type)" - } - - return [list message/rfc822 {}] - } - - default { - error [format "expecting \"/\" (found %s)" $state(buffer)] - } - } - - if {[parselexeme $token] ne {LX_ATOM}} { - error [format "expecting subtype (found %s)" $state(buffer)] - } - append type [string tolower /$state(buffer)] - - array set params {} - while 1 { - switch -- [parselexeme $token] { - LX_END { - return [list $type [array get params]] - } - - LX_SEMICOLON { - } - - default { - error [format "expecting \";\" (found %s)" $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_END { - return [list $type [array get params]] - } - - LX_ATOM { - } - - default { - error [format "expecting attribute (found %s)" $state(buffer)] - } - } - - set attribute [string tolower $state(buffer)] - - if {[parselexeme $token] ne {LX_EQUALS}} { - error [format {expecting "=" (found %s)} $state(buffer)] - } - - switch -- [parselexeme $token] { - LX_ATOM { - } - - LX_QSTRING { - set state(buffer) [ - string range $state(buffer) 1 [ - expr {[string length $state(buffer)] - 2}]] - } - - default { - error [format {expecting value (found %s)} $state(buffer)] - } - } - set params($attribute) $state(buffer) - } -} - -# ::mime::finalize -- -# -# mime::finalize destroys a MIME part. -# -# If the -subordinates option is present, it specifies which -# subordinates should also be destroyed. The default value is -# "dynamic". -# -# Arguments: -# token The MIME token to parse. -# args Args can be optionally be of the following form: -# ?-subordinates "all" | "dynamic" | "none"? -# -# Results: -# Returns an empty string. - -proc ::mime::finalize {token args} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set options [list -subordinates dynamic] - array set options $args - - switch -- $options(-subordinates) { - all { - #TODO: this code path is untested - if {$state(value) eq {parts}} { - foreach part $state(parts) { - eval [linsert $args 0 mime::finalize $part] - } - } - } - - dynamic { - for {set cid $state(cid)} {$cid > 0} {incr cid -1} { - eval [linsert $args 0 mime::finalize $token-$cid] - } - } - - none { - } - - default { - error "unknown value for -subordinates $options(-subordinates)" - } - } - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - unset $token -} - -# ::mime::getproperty -- -# -# mime::getproperty returns the properties of a MIME part. -# -# The properties are: -# -# property value -# ======== ===== -# content the type/subtype describing the content -# encoding the "Content-Transfer-Encoding" -# params a list of "Content-Type" parameters -# parts a list of tokens for the part's subordinates -# size the approximate size of the content (unencoded) -# -# The "parts" property is present only if the MIME part has -# subordinates. -# -# If mime::getproperty is invoked with the name of a specific -# property, then the corresponding value is returned; instead, if -# -names is specified, a list of all properties is returned; -# otherwise, a dictionary of properties is returned. -# -# Arguments: -# token The MIME token to parse. -# property One of 'content', 'encoding', 'params', 'parts', and -# 'size'. Defaults to returning a dictionary of -# properties. -# -# Results: -# Returns the properties of a MIME part - -proc ::mime::getproperty {token {property {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $property { - {} { - array set properties [list content $state(content) \ - encoding $state(encoding) \ - params $state(params) \ - size [getsize $token]] - if {[info exists state(parts)]} { - set properties(parts) $state(parts) - } - - return [array get properties] - } - - -names { - set names [list content encoding params] - if {[info exists state(parts)]} { - lappend names parts - } - - return $names - } - - content - - - encoding - - - params { - return $state($property) - } - - parts { - if {![info exists state(parts)]} { - error {MIME part is a leaf} - } - - return $state(parts) - } - - size { - return [getsize $token] - } - - default { - error "unknown property $property" - } - } -} - -# ::mime::getsize -- -# -# Determine the size (in bytes) of a MIME part/token -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the size in bytes of the MIME token. - -proc ::mime::getsize {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $state(value)/$state(canonicalP) { - file/0 { - set size $state(count) - } - - file/1 { - return [file size $state(file)] - } - - parts/0 - - - parts/1 { - set size 0 - foreach part $state(parts) { - incr size [getsize $part] - } - - return $size - } - - string/0 { - set size [string length $state(string)] - } - - string/1 { - return [string length $state(string)] - } - default { - error "Unknown combination \"$state(value)/$state(canonicalP)\"" - } - } - - if {$state(encoding) eq {base64}} { - set size [expr {($size * 3 + 2) / 4}] - } - - return $size -} - - -proc ::mime::getContentType token { - variable $token - upvar 0 $token state - set boundary {} - set res $state(content) - foreach {k v} $state(params) { - set boundary $v - append res ";\n $k=\"$v\"" - } - if {([string match multipart/* $state(content)]) \ - && ($boundary eq {})} { - # we're doing everything in one pass... - set key [clock seconds]$token[info hostname][array get state] - set seqno 8 - while {[incr seqno -1] >= 0} { - set key [md5 -- $key] - } - set boundary "----- =_[string trim [base64 -mode encode -- $key]]" - - append res ";\n boundary=\"$boundary\"" - } - return $res -} - -# ::mime::getheader -- -# -# mime::getheader returns the header of a MIME part. -# -# A header consists of zero or more key/value pairs. Each value is a -# list containing one or more strings. -# -# If mime::getheader is invoked with the name of a specific key, then -# a list containing the corresponding value(s) is returned; instead, -# if -names is specified, a list of all keys is returned; otherwise, a -# dictionary is returned. Note that when a -# key is specified (e.g., "Subject"), the list returned usually -# contains exactly one string; however, some keys (e.g., "Received") -# often occur more than once in the header, accordingly the list -# returned usually contains more than one string. -# -# Arguments: -# token The MIME token to parse. -# key Either a key or '-names'. If it is '-names' a list -# of all keys is returned. -# -# Results: -# Returns the header of a MIME part. - -proc ::mime::getheader {token {key {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - switch -- $key { - {} { - set result {} - lappend result MIME-Version $state(version) - foreach lower $state(lowerL) mixed $state(mixedL) { - foreach value $header($lower) { - lappend result $mixed $value - } - } - set tencoding [getTransferEncoding $token] - if {$tencoding ne {}} { - lappend result Content-Transfer-Encoding $tencoding - } - lappend result Content-Type [getContentType $token] - return $result - } - - -names { - return $state(mixedL) - } - - default { - set lower [string tolower $key] - - switch $lower { - content-transfer-encoding { - return [getTransferEncoding $token] - } - content-type { - return [list [getContentType $token]] - } - mime-version { - return [list $state(version)] - } - default { - if {![info exists header($lower)]} { - error "key $key not in header" - } - return $header($lower) - } - } - } - } -} - - -proc ::mime::getTransferEncoding token { - variable $token - upvar 0 $token state - set res {} - if {[set encoding $state(encoding)] eq {}} { - set encoding [encoding $token] - } - if {$encoding ne {}} { - set res $encoding - } - switch -- $encoding { - base64 - - - quoted-printable { - set converter $encoding - } - 7bit - 8bit - binary - {} { - # Bugfix for [#477088], also [#539952] - # Go ahead - } - default { - error "Can't handle content encoding \"$encoding\"" - } - } - return $res -} - -# ::mime::setheader -- -# -# mime::setheader writes, appends to, or deletes the value associated -# with a key in the header. -# -# The value for -mode is one of: -# -# write: the key/value is either created or overwritten (the -# default); -# -# append: a new value is appended for the key (creating it as -# necessary); or, -# -# delete: all values associated with the key are removed (the -# "value" parameter is ignored). -# -# Regardless, mime::setheader returns the previous value associated -# with the key. -# -# Arguments: -# token The MIME token to parse. -# key The name of the key whose value should be set. -# value The value for the header key to be set to. -# args An optional argument of the form: -# ?-mode "write" | "append" | "delete"? -# -# Results: -# Returns previous value associated with the specified key. - -proc ::mime::setheader {token key value args} { - # FRINK: nocheck - variable internal - variable $token - upvar 0 $token state - - array set options [list -mode write] - array set options $args - - set lower [string tolower $key] - array set header $state(header) - if {[set x [lsearch -exact $state(lowerL) $lower]] < 0} { - #TODO: this code path is not tested - if {$options(-mode) eq {delete}} { - error "key $key not in header" - } - - lappend state(lowerL) $lower - lappend state(mixedL) $key - - set result {} - } else { - set result $header($lower) - } - switch -- $options(-mode) { - append - write { - if {!$internal} { - switch -- $lower { - content-md5 - - - content-type - - - content-transfer-encoding - - - mime-version { - set values [getheader $token $lower] - if {$value ni $values} { - error "key $key may not be set" - } - } - default {# Skip key} - } - } - switch -- $options(-mode) { - append { - lappend header($lower) $value - } - write { - set header($lower) [list $value] - } - } - } - delete { - unset header($lower) - set state(lowerL) [lreplace $state(lowerL) $x $x] - set state(mixedL) [lreplace $state(mixedL) $x $x] - } - - default { - error "unknown value for -mode $options(-mode)" - } - } - - set state(header) [array get header] - return $result -} - -# ::mime::getbody -- -# -# mime::getbody returns the body of a leaf MIME part in canonical form. -# -# If the -command option is present, then it is repeatedly invoked -# with a fragment of the body as this: -# -# uplevel #0 $callback [list "data" $fragment] -# -# (The -blocksize option, if present, specifies the maximum size of -# each fragment passed to the callback.) -# When the end of the body is reached, the callback is invoked as: -# -# uplevel #0 $callback "end" -# -# Alternatively, if an error occurs, the callback is invoked as: -# -# uplevel #0 $callback [list "error" reason] -# -# Regardless, the return value of the final invocation of the callback -# is propagated upwards by mime::getbody. -# -# If the -command option is absent, then the return value of -# mime::getbody is a string containing the MIME part's entire body. -# -# Arguments: -# token The MIME token to parse. -# args Optional arguments of the form: -# ?-decode? ?-command callback ?-blocksize octets? ? -# -# Results: -# Returns a string containing the MIME part's entire body, or -# if '-command' is specified, the return value of the command -# is returned. - -proc ::mime::getbody {token args} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set decode 0 - if {[set pos [lsearch -exact $args -decode]] >= 0} { - set decode 1 - set args [lreplace $args $pos $pos] - } - - array set options [list -command [ - list mime::getbodyaux $token] -blocksize 4096] - array set options $args - if {$options(-blocksize) < 1} { - error "-blocksize expects a positive integer, not $options(-blocksize)" - } - - set code 0 - set ecode {} - set einfo {} - - switch -- $state(value)/$state(canonicalP) { - file/0 { - set fd [open $state(file) RDONLY] - - set code [catch { - fconfigure $fd -translation binary - seek $fd [set pos $state(offset)] start - set last [expr {$state(offset) + $state(count) - 1}] - - set fragment {} - while {$pos <= $last} { - if {[set cc [ - expr {($last - $pos) + 1}]] > $options(-blocksize)} { - set cc $options(-blocksize) - } - incr pos [set len [ - string length [set chunk [read $fd $cc]]]] - switch -exact -- $state(encoding) { - base64 - - - quoted-printable { - if {([set x [string last \n $chunk]] > 0) \ - && ($x + 1 != $len)} { - set chunk [string range $chunk 0 $x] - seek $fd [incr pos [expr {($x + 1) - $len}]] start - } - set chunk [ - $state(encoding) -mode decode -- $chunk] - } - 7bit - 8bit - binary - {} { - # Bugfix for [#477088] - # Go ahead, leave chunk alone - } - default { - error "Can't handle content encoding \"$state(encoding)\"" - } - } - append fragment $chunk - - set cc [expr {$options(-blocksize) - 1}] - while {[string length $fragment] > $options(-blocksize)} { - uplevel #0 $options(-command) [ - list data [string range $fragment 0 $cc]] - - set fragment [ - string range $fragment $options(-blocksize) end] - } - } - if {[string length $fragment] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - catch {close $fd} - } - - file/1 { - set fd [open $state(file) RDONLY] - - set code [catch { - fconfigure $fd -translation binary - - while {[string length [ - set fragment [read $fd $options(-blocksize)]]] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - catch {close $fd} - } - - parts/0 - - - parts/1 { - error {MIME part isn't a leaf} - } - - string/0 - - - string/1 { - switch -- $state(encoding)/$state(canonicalP) { - base64/0 - - - quoted-printable/0 { - set fragment [ - $state(encoding) -mode decode -- $state(string)] - } - - default { - # Not a bugfix for [#477088], but clarification - # This handles no-encoding, 7bit, 8bit, and binary. - set fragment $state(string) - } - } - - set code [catch { - set cc [expr {$options(-blocksize) -1}] - while {[string length $fragment] > $options(-blocksize)} { - uplevel #0 $options(-command) [ - list data [string range $fragment 0 $cc]] - - set fragment [ - string range $fragment $options(-blocksize) end] - } - if {[string length $fragment] > 0} { - uplevel #0 $options(-command) [list data $fragment] - } - } result] - set ecode $errorCode - set einfo $errorInfo - } - default { - error "Unknown combination \"$state(value)/$state(canonicalP)\"" - } - } - - set code [catch { - if {$code} { - uplevel #0 $options(-command) [list error $result] - } else { - uplevel #0 $options(-command) [list end] - } - } result] - set ecode $errorCode - set einfo $errorInfo - - if {$code} { - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - - if {$decode} { - array set params [mime::getproperty $token params] - - if {[info exists params(charset)]} { - set charset $params(charset) - } else { - set charset US-ASCII - } - - set enc [reversemapencoding $charset] - if {$enc ne {}} { - set result [::encoding convertfrom $enc $result] - } else { - return -code error "-decode failed: can't reversemap charset $charset" - } - } - - return $result -} - -# ::mime::getbodyaux -- -# -# Builds up the body of the message, fragment by fragment. When -# the entire message has been retrieved, it is returned. -# -# Arguments: -# token The MIME token to parse. -# reason One of 'data', 'end', or 'error'. -# fragment The section of data data fragment to extract a -# string from. -# -# Results: -# Returns nothing, except when called with the 'end' argument -# in which case it returns a string that contains all of the -# data that 'getbodyaux' has been called with. Will throw an -# error if it is called with the reason of 'error'. - -proc ::mime::getbodyaux {token reason {fragment {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch $reason { - data { - append state(getbody) $fragment - return {} - } - - end { - if {[info exists state(getbody)]} { - set result $state(getbody) - unset state(getbody) - } else { - set result {} - } - - return $result - } - - error { - catch {unset state(getbody)} - error $reason - } - - default { - error "Unknown reason \"$reason\"" - } - } -} - -# ::mime::copymessage -- -# -# mime::copymessage copies the MIME part to the specified channel. -# -# mime::copymessage operates synchronously, and uses fileevent to -# allow asynchronous operations to proceed independently. -# -# Arguments: -# token The MIME token to parse. -# channel The channel to copy the message to. -# -# Results: -# Returns nothing unless an error is thrown while the message -# is being written to the channel. - -proc ::mime::copymessage {token channel} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set openP [info exists state(fd)] - - set code [catch {mime::copymessageaux $token $channel} result] - set ecode $errorCode - set einfo $errorInfo - - if {!$openP && [info exists state(fd)]} { - if {![info exists state(root)]} { - catch {close $state(fd)} - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::copymessageaux -- -# -# mime::copymessageaux copies the MIME part to the specified channel. -# -# Arguments: -# token The MIME token to parse. -# channel The channel to copy the message to. -# -# Results: -# Returns nothing unless an error is thrown while the message -# is being written to the channel. - -proc ::mime::copymessageaux {token channel} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - array set header $state(header) - - set boundary {} - - set result {} - foreach {mixed value} [getheader $token] { - puts $channel "$mixed: $value" - } - - foreach {k v} $state(params) { - if {$k eq {boundary}} { - set boundary $v - } - } - - set converter {} - set encoding {} - if {$state(value) ne {parts}} { - if {$state(canonicalP)} { - if {[set encoding $state(encoding)] eq {}} { - set encoding [encoding $token] - } - if {$encoding ne {}} { - puts $channel "Content-Transfer-Encoding: $encoding" - } - switch -- $encoding { - base64 - - - quoted-printable { - set converter $encoding - } - 7bit - 8bit - binary - {} { - # Bugfix for [#477088], also [#539952] - # Go ahead - } - default { - error "Can't handle content encoding \"$encoding\"" - } - } - } - } elseif {([string match multipart/* $state(content)]) \ - && ($boundary eq {})} { - # we're doing everything in one pass... - set key [clock seconds]$token[info hostname][array get state] - set seqno 8 - while {[incr seqno -1] >= 0} { - set key [md5 -- $key] - } - set boundary "----- =_[string trim [base64 -mode encode -- $key]]" - - puts $channel ";\n boundary=\"$boundary\"" - } - - if {[info exists state(error)]} { - unset state(error) - } - - switch -- $state(value) { - file { - set closeP 1 - if {[info exists state(root)]} { - # FRINK: nocheck - variable $state(root) - upvar 0 $state(root) root - - if {[info exists root(fd)]} { - set fd $root(fd) - set closeP 0 - } else { - set fd [set state(fd) [open $state(file) RDONLY]] - } - set size $state(count) - } else { - set fd [set state(fd) [open $state(file) RDONLY]] - # read until eof - set size -1 - } - seek $fd $state(offset) start - if {$closeP} { - fconfigure $fd -translation binary - } - - puts $channel {} - - while {$size != 0 && ![eof $fd]} { - if {$size < 0 || $size > 32766} { - set X [read $fd 32766] - } else { - set X [read $fd $size] - } - if {$size > 0} { - set size [expr {$size - [string length $X]}] - } - if {$converter eq {}} { - puts -nonewline $channel $X - } else { - puts -nonewline $channel [$converter -mode encode -- $X] - } - } - - if {$closeP} { - catch {close $state(fd)} - unset state(fd) - } - } - - parts { - if { - ![info exists state(root)] - && - [info exists state(file)] - } { - set state(fd) [open $state(file) RDONLY] - fconfigure $state(fd) -translation binary - } - - switch -glob -- $state(content) { - message/* { - puts $channel {} - foreach part $state(parts) { - mime::copymessage $part $channel - break - } - } - - default { - # Note RFC 2046: See buildmessageaux for details. - # - # The boundary delimiter MUST occur at the - # beginning of a line, i.e., following a CRLF, and - # the initial CRLF is considered to be attached to - # the boundary delimiter line rather than part of - # the preceding part. - # - # - The above means that the CRLF before $boundary - # is needed per the RFC, and the parts must not - # have a closing CRLF of their own. See Tcllib bug - # 1213527, and patch 1254934 for the problems when - # both file/string branches added CRLF after the - # body parts. - - - foreach part $state(parts) { - puts $channel \n--$boundary - mime::copymessage $part $channel - } - puts $channel \n--$boundary-- - } - } - - if {[info exists state(fd)]} { - catch {close $state(fd)} - unset state(fd) - } - } - - string { - if {[catch {fconfigure $channel -buffersize} blocksize]} { - set blocksize 4096 - } elseif {$blocksize < 512} { - set blocksize 512 - } - set blocksize [expr {($blocksize / 4) * 3}] - - # [893516] - fconfigure $channel -buffersize $blocksize - - puts $channel {} - - #TODO: tests don't cover these paths - if {$converter eq {}} { - puts -nonewline $channel $state(string) - } else { - puts -nonewline $channel [$converter -mode encode -- $state(string)] - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - flush $channel - - if {[info exists state(error)]} { - error $state(error) - } -} - -# ::mime::buildmessage -- -# -# Like copymessage, but produces a string rather than writing the message into a channel. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# The message. - -proc ::mime::buildmessage token { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - - set openP [info exists state(fd)] - - set code [catch {mime::buildmessageaux $token} result] - if {![info exists errorCode]} { - set ecode {} - } else { - set ecode $errorCode - } - set einfo $errorInfo - - if {!$openP && [info exists state(fd)]} { - if {![info exists state(root)]} { - catch {close $state(fd)} - } - unset state(fd) - } - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - - -proc ::mime::buildmessageaux token { - set chan [tcl::chan::memchan] - chan configure $chan -translation crlf - copymessageaux $token $chan - seek $chan 0 - chan configure $chan -translation binary - set res [read $chan] - close $chan - return $res -} - -# ::mime::encoding -- -# -# Determines how a token is encoded. -# -# Arguments: -# token The MIME token to parse. -# -# Results: -# Returns the encoding of the message (the null string, base64, -# or quoted-printable). - -proc ::mime::encoding {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -glob -- $state(content) { - audio/* - - - image/* - - - video/* { - return base64 - } - - message/* - - - multipart/* { - return {} - } - default {# Skip} - } - - set asciiP 1 - set lineP 1 - switch -- $state(value) { - file { - set fd [open $state(file) RDONLY] - fconfigure $fd -translation binary - - while {[gets $fd line] >= 0} { - if {$asciiP} { - set asciiP [encodingasciiP $line] - } - if {$lineP} { - set lineP [encodinglineP $line] - } - if {(!$asciiP) && (!$lineP)} { - break - } - } - - catch {close $fd} - } - - parts { - return {} - } - - string { - foreach line [split $state(string) "\n"] { - if {$asciiP} { - set asciiP [encodingasciiP $line] - } - if {$lineP} { - set lineP [encodinglineP $line] - } - if {(!$asciiP) && (!$lineP)} { - break - } - } - } - default { - error "Unknown value \"$state(value)\"" - } - } - - switch -glob -- $state(content) { - text/* { - if {!$asciiP} { - #TODO: this path is not covered by tests - foreach {k v} $state(params) { - if {$k eq "charset"} { - set v [string tolower $v] - if {($v ne "us-ascii") \ - && (![string match {iso-8859-[1-8]} $v])} { - return base64 - } - - break - } - } - } - - if {!$lineP} { - return quoted-printable - } - } - - - default { - if {(!$asciiP) || (!$lineP)} { - return base64 - } - } - } - - return {} -} - -# ::mime::encodingasciiP -- -# -# Checks if a string is a pure ascii string, or if it has a non-standard -# form. -# -# Arguments: -# line The line to check. -# -# Results: -# Returns 1 if \r only occurs at the end of lines, and if all -# characters in the line are between the ASCII codes of 32 and 126. - -proc ::mime::encodingasciiP {line} { - foreach c [split $line {}] { - switch -- $c { - { } - \t - \r - \n { - } - - default { - binary scan $c c c - if {($c < 32) || ($c > 126)} { - return 0 - } - } - } - } - if { - [set r [string first \r $line]] < 0 - || - $r == {[string length $line] - 1} - } { - return 1 - } - - return 0 -} - -# ::mime::encodinglineP -- -# -# Checks if a string is a line is valid to be processed. -# -# Arguments: -# line The line to check. -# -# Results: -# Returns 1 the line is less than 76 characters long, the line -# contains more characters than just whitespace, the line does -# not start with a '.', and the line does not start with 'From '. - -proc ::mime::encodinglineP {line} { - if {([string length $line] > 76) \ - || ($line ne [string trimright $line]) \ - || ([string first . $line] == 0) \ - || ([string first {From } $line] == 0)} { - return 0 - } - - return 1 -} - -# ::mime::fcopy -- -# -# Appears to be unused. -# -# Arguments: -# -# Results: -# - -proc ::mime::fcopy {token count {error {}}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {$error ne {}} { - set state(error) $error - } - set state(doneP) 1 -} - -# ::mime::scopy -- -# -# Copy a portion of the contents of a mime token to a channel. -# -# Arguments: -# token The token containing the data to copy. -# channel The channel to write the data to. -# offset The location in the string to start copying -# from. -# len The amount of data to write. -# blocksize The block size for the write operation. -# -# Results: -# The specified portion of the string in the mime token is -# copied to the specified channel. - -proc ::mime::scopy {token channel offset len blocksize} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {$len <= 0} { - set state(doneP) 1 - fileevent $channel writable {} - return - } - - if {[set cc $len] > $blocksize} { - set cc $blocksize - } - - if {[catch { - puts -nonewline $channel [ - string range $state(string) $offset [expr {$offset + $cc - 1}]] - fileevent $channel writable [ - list mime::scopy $token $channel [ - incr offset $cc] [incr len -$cc] $blocksize] - } result] - } { - set state(error) $result - set state(doneP) 1 - fileevent $channel writable {} - } - return -} - -# ::mime::qp_encode -- -# -# Tcl version of quote-printable encode -# -# Arguments: -# string The string to quote. -# encoded_word Boolean value to determine whether or not encoded words -# (RFC 2047) should be handled or not. (optional) -# -# Results: -# The properly quoted string is returned. - -proc ::mime::qp_encode {string {encoded_word 0} {no_softbreak 0}} { - # 8.1+ improved string manipulation routines used. - # Replace outlying characters, characters that would normally - # be munged by EBCDIC gateways, and special Tcl characters "[\]{} - # with =xx sequence - - if {$encoded_word} { - # Special processing for encoded words (RFC 2047) - set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF\x09\x5F\x3F]} - lappend mapChars { } _ - } else { - set regexp {[\x00-\x08\x0B-\x1E\x21-\x24\x3D\x40\x5B-\x5E\x60\x7B-\xFF]} - } - regsub -all -- $regexp $string {[format =%02X [scan "\\&" %c]]} string - - # Replace the format commands with their result - - set string [subst -novariables $string] - - # soft/hard newlines and other - # Funky cases for SMTP compatibility - lappend mapChars " \n" =20\n \t\n =09\n \n\.\n =2E\n "\nFrom " "\n=46rom " - - set string [string map $mapChars $string] - - # Break long lines - ugh - - # Implementation of FR #503336 - if {$no_softbreak} { - set result $string - } else { - set result {} - foreach line [split $string \n] { - while {[string length $line] > 72} { - set chunk [string range $line 0 72] - if {[regexp -- (=|=.)$ $chunk dummy end]} { - - # Don't break in the middle of a code - - set len [expr {72 - [string length $end]}] - set chunk [string range $line 0 $len] - incr len - set line [string range $line $len end] - } else { - set line [string range $line 73 end] - } - append result $chunk=\n - } - append result $line\n - } - - # Trim off last \n, since the above code has the side-effect - # of adding an extra \n to the encoded string and return the - # result. - set result [string range $result 0 end-1] - } - - # If the string ends in space or tab, replace with =xx - - set lastChar [string index $result end] - if {$lastChar eq { }} { - set result [string replace $result end end =20] - } elseif {$lastChar eq "\t"} { - set result [string replace $result end end =09] - } - - return $result -} - -# ::mime::qp_decode -- -# -# Tcl version of quote-printable decode -# -# Arguments: -# string The quoted-printable string to decode. -# encoded_word Boolean value to determine whether or not encoded words -# (RFC 2047) should be handled or not. (optional) -# -# Results: -# The decoded string is returned. - -proc ::mime::qp_decode {string {encoded_word 0}} { - # 8.1+ improved string manipulation routines used. - # Special processing for encoded words (RFC 2047) - - if {$encoded_word} { - # _ == \x20, even if SPACE occupies a different code position - set string [string map [list _ \u0020] $string] - } - - # smash the white-space at the ends of lines since that must've been - # generated by an MUA. - - regsub -all -- {[ \t]+\n} $string \n string - set string [string trimright $string " \t"] - - # Protect the backslash for later subst and - # smash soft newlines, has to occur after white-space smash - # and any encoded word modification. - - #TODO: codepath not tested - set string [string map [list \\ {\\} =\n {}] $string] - - # Decode specials - - regsub -all -nocase {=([a-f0-9][a-f0-9])} $string {\\u00\1} string - - # process \u unicode mapped chars - - return [subst -novariables -nocommands $string] -} - -# ::mime::parseaddress -- -# -# This was originally written circa 1982 in C. we're still using it -# because it recognizes virtually every buggy address syntax ever -# generated! -# -# mime::parseaddress takes a string containing one or more 822-style -# address specifications and returns a list of dictionaries, for each -# address specified in the argument. -# -# Each dictionary contains these properties: -# -# property value -# ======== ===== -# address local@domain -# comment 822-style comment -# domain the domain part (rhs) -# error non-empty on a parse error -# group this address begins a group -# friendly user-friendly rendering -# local the local part (lhs) -# memberP this address belongs to a group -# phrase the phrase part -# proper 822-style address specification -# route 822-style route specification (obsolete) -# -# Note that one or more of these properties may be empty. -# -# Arguments: -# string The address string to parse -# -# Results: -# Returns a list of dictionaries, one element for each address -# specified in the argument. - -proc ::mime::parseaddress {string} { - global errorCode errorInfo - - variable mime - - set token [namespace current]::[incr mime(uid)] - # FRINK: nocheck - variable $token - upvar 0 $token state - - set code [catch {mime::parseaddressaux $token $string} result] - set ecode $errorCode - set einfo $errorInfo - - foreach name [array names state] { - unset state($name) - } - # FRINK: nocheck - catch {unset $token} - - return -code $code -errorinfo $einfo -errorcode $ecode $result -} - -# ::mime::parseaddressaux -- -# -# This was originally written circa 1982 in C. we're still using it -# because it recognizes virtually every buggy address syntax ever -# generated! -# -# mime::parseaddressaux does the actually parsing for mime::parseaddress -# -# Each dictionary contains these properties: -# -# property value -# ======== ===== -# address local@domain -# comment 822-style comment -# domain the domain part (rhs) -# error non-empty on a parse error -# group this address begins a group -# friendly user-friendly rendering -# local the local part (lhs) -# memberP this address belongs to a group -# phrase the phrase part -# proper 822-style address specification -# route 822-style route specification (obsolete) -# -# Note that one or more of these properties may be empty. -# -# Arguments: -# token The MIME token to work from. -# string The address string to parse -# -# Results: -# Returns a list of dictionaries, one for each address specified in the -# argument. - -proc ::mime::parseaddressaux {token string} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - variable addrtokenL - variable addrlexemeL - - set state(input) $string - set state(glevel) 0 - set state(buffer) {} - set state(lastC) LX_END - set state(tokenL) $addrtokenL - set state(lexemeL) $addrlexemeL - - set result {} - while {[addr_next $token]} { - if {[set tail $state(domain)] ne {}} { - set tail @$state(domain) - } else { - set tail @[info hostname] - } - if {[set address $state(local)] ne {}} { - #TODO: this path is not covered by tests - append address $tail - } - - if {$state(phrase) ne {}} { - #TODO: this path is not covered by tests - set state(phrase) [string trim $state(phrase) \"] - foreach t $state(tokenL) { - if {[string first $t $state(phrase)] >= 0} { - #TODO: is this quoting robust enough? - set state(phrase) \"$state(phrase)\" - break - } - } - - set proper "$state(phrase) <$address>" - } else { - set proper $address - } - - if {[set friendly $state(phrase)] eq {}} { - #TODO: this path is not covered by tests - if {[set note $state(comment)] ne {}} { - if {[string first ( $note] == 0} { - set note [string trimleft [string range $note 1 end]] - } - if { - [string last ) $note] - == [set len [expr {[string length $note] - 1}]] - } { - set note [string range $note 0 [expr {$len - 1}]] - } - set friendly $note - } - - if { - $friendly eq {} - && - [set mbox $state(local)] ne {} - } { - #TODO: this path is not covered by tests - set mbox [string trim $mbox \"] - - if {[string first / $mbox] != 0} { - set friendly $mbox - } elseif {[set friendly [addr_x400 $mbox PN]] ne {}} { - } elseif { - [set friendly [addr_x400 $mbox S]] ne {} - && - [set g [addr_x400 $mbox G]] ne {} - } { - set friendly "$g $friendly" - } - - if {$friendly eq {}} { - set friendly $mbox - } - } - } - set friendly [string trim $friendly \"] - - lappend result [list address $address \ - comment $state(comment) \ - domain $state(domain) \ - error $state(error) \ - friendly $friendly \ - group $state(group) \ - local $state(local) \ - memberP $state(memberP) \ - phrase $state(phrase) \ - proper $proper \ - route $state(route)] - - } - - unset {*}{ - state(input) - state(glevel) - state(buffer) - state(lastC) - state(tokenL) - state(lexemeL) - } - - return $result -} - -# ::mime::addr_next -- -# -# Locate the next address in a mime token. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_next {token} { - global errorCode errorInfo - # FRINK: nocheck - variable $token - upvar 0 $token state - set nocomplain [package vsatisfies [package provide Tcl] 8.4] - foreach prop {comment domain error group local memberP phrase route} { - if {$nocomplain} { - unset -nocomplain state($prop) - } else { - if {[catch {unset state($prop)}]} {set ::errorInfo {}} - } - } - - switch -- [set code [catch {mime::addr_specification $token} result]] { - 0 { - if {!$result} { - return 0 - } - - switch -- $state(lastC) { - LX_COMMA - - - LX_END { - } - default { - # catch trailing comments... - set lookahead $state(input) - mime::parselexeme $token - set state(input) $lookahead - } - } - } - - 7 { - set state(error) $result - - while {1} { - switch -- $state(lastC) { - LX_COMMA - - - LX_END { - break - } - - default { - mime::parselexeme $token - } - } - } - } - - default { - set ecode $errorCode - set einfo $errorInfo - - return -code $code -errorinfo $einfo -errorcode $ecode $result - } - } - - foreach prop {comment domain error group local memberP phrase route} { - if {![info exists state($prop)]} { - set state($prop) {} - } - } - - return 1 -} - -# ::mime::addr_specification -- -# -# Uses lookahead parsing to determine whether there is another -# valid e-mail address or not. Throws errors if unrecognized -# or invalid e-mail address syntax is used. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_specification {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set lookahead $state(input) - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - set state(phrase) $state(buffer) - } - - LX_SEMICOLON { - if {[incr state(glevel) -1] < 0} { - return -code 7 "extraneous semi-colon" - } - - catch {unset state(comment)} - return [addr_specification $token] - } - - LX_COMMA { - catch {unset state(comment)} - return [addr_specification $token] - } - - LX_END { - return 0 - } - - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_ATSIGN { - set state(input) $lookahead - return [addr_routeaddr $token 0] - } - - default { - return -code 7 [ - format "unexpected character at beginning (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(phrase) " " $state(buffer) - - return [addr_phrase $token] - } - - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_COLON { - return [addr_group $token] - } - - LX_DOT { - set state(local) "$state(phrase)$state(buffer)" - unset state(phrase) - mime::addr_routeaddr $token 0 - mime::addr_end $token - } - - LX_ATSIGN { - set state(memberP) $state(glevel) - set state(local) $state(phrase) - unset state(phrase) - mime::addr_domain $token - mime::addr_end $token - } - - LX_SEMICOLON - - - LX_COMMA - - - LX_END { - set state(memberP) $state(glevel) - if { - $state(lastC) eq "LX_SEMICOLON" - && - ([incr state(glevel) -1] < 0) - } { - #TODO: this path is not covered by tests - return -code 7 "extraneous semi-colon" - } - - set state(local) $state(phrase) - unset state(phrase) - } - - default { - return -code 7 [ - format "expecting mailbox (found %s)" $state(buffer)] - } - } - - return 1 -} - -# ::mime::addr_routeaddr -- -# -# Parses the domain portion of an e-mail address. Finds the '@' -# sign and then calls mime::addr_route to verify the domain. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns 1 if there is another address, and 0 if there is not. - -proc ::mime::addr_routeaddr {token {checkP 1}} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set lookahead $state(input) - if {[parselexeme $token] eq "LX_ATSIGN"} { - #TODO: this path is not covered by tests - mime::addr_route $token - } else { - set state(input) $lookahead - } - - mime::addr_local $token - - switch -- $state(lastC) { - LX_ATSIGN { - mime::addr_domain $token - } - - LX_SEMICOLON - - - LX_RBRACKET - - - LX_COMMA - - - LX_END { - } - - default { - return -code 7 [ - format "expecting at-sign after local-part (found %s)" \ - $state(buffer)] - } - } - - if {($checkP) && ($state(lastC) ne "LX_RBRACKET")} { - return -code 7 [ - format "expecting right-bracket (found %s)" $state(buffer)] - } - - return 1 -} - -# ::mime::addr_route -- -# -# Attempts to parse the portion of the e-mail address after the @. -# Tries to verify that the domain definition has a valid form. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_route {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(route) @ - - while 1 { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_DLITERAL { - append state(route) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting sub-route in route-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_COMMA { - append state(route) $state(buffer) - while 1 { - switch -- [parselexeme $token] { - LX_COMMA { - } - - LX_ATSIGN { - append state(route) $state(buffer) - break - } - - default { - return -code 7 \ - [format "expecting at-sign in route (found %s)" \ - $state(buffer)] - } - } - } - } - - LX_ATSIGN - - - LX_DOT { - append state(route) $state(buffer) - } - - LX_COLON { - append state(route) $state(buffer) - return - } - - default { - return -code 7 [ - format "expecting colon to terminate route (found %s)" \ - $state(buffer)] - } - } - } -} - -# ::mime::addr_domain -- -# -# Attempts to parse the portion of the e-mail address after the @. -# Tries to verify that the domain definition has a valid form. -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_domain {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - while 1 { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_DLITERAL { - append state(domain) $state(buffer) - } - - default { - return -code 7 [ - format "expecting sub-domain in domain-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_DOT { - append state(domain) $state(buffer) - } - - LX_ATSIGN { - append state(local) % $state(domain) - unset state(domain) - } - - default { - return - } - } - } -} - -# ::mime::addr_local -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_local {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(memberP) $state(glevel) - - while 1 { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(local) $state(buffer) - } - - default { - return -code 7 \ - [format "expecting mailbox in local-part (found %s)" \ - $state(buffer)] - } - } - - switch -- [parselexeme $token] { - LX_DOT { - append state(local) $state(buffer) - } - - default { - return - } - } - } -} - -# ::mime::addr_phrase -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - - -proc ::mime::addr_phrase {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - while {1} { - switch -- [parselexeme $token] { - LX_ATOM - - - LX_QSTRING { - append state(phrase) " " $state(buffer) - } - - default { - break - } - } - } - - switch -- $state(lastC) { - LX_LBRACKET { - return [addr_routeaddr $token] - } - - LX_COLON { - return [addr_group $token] - } - - LX_DOT { - append state(phrase) $state(buffer) - return [addr_phrase $token] - } - - default { - return -code 7 [ - format "found phrase instead of mailbox (%s%s)" \ - $state(phrase) $state(buffer)] - } - } -} - -# ::mime::addr_group -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_group {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - if {[incr state(glevel)] > 1} { - return -code 7 [ - format "nested groups not allowed (found %s)" $state(phrase)] - } - - set state(group) $state(phrase) - unset state(phrase) - - set lookahead $state(input) - while 1 { - switch -- [parselexeme $token] { - LX_SEMICOLON - - - LX_END { - set state(glevel) 0 - return 1 - } - - LX_COMMA { - } - - default { - set state(input) $lookahead - return [addr_specification $token] - } - } - } -} - -# ::mime::addr_end -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_end {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - switch -- $state(lastC) { - LX_SEMICOLON { - if {[incr state(glevel) -1] < 0} { - return -code 7 "extraneous semi-colon" - } - } - - LX_COMMA - - - LX_END { - } - - default { - return -code 7 [ - format "junk after local@domain (found %s)" $state(buffer)] - } - } -} - -# ::mime::addr_x400 -- -# -# -# Arguments: -# token The MIME token to work from. -# -# Results: -# Returns nothing if successful, and throws an error if invalid -# syntax is found. - -proc ::mime::addr_x400 {mbox key} { - if {[set x [string first /$key= [string toupper $mbox]]] < 0} { - return {} - } - set mbox [string range $mbox [expr {$x + [string length $key] + 2}] end] - - if {[set x [string first / $mbox]] > 0} { - set mbox [string range $mbox 0 [expr {$x - 1}]] - } - - return [string trim $mbox \"] -} - -# ::mime::parsedatetime -- -# -# Fortunately the clock command in the Tcl 8.x core does all the heavy -# lifting for us (except for timezone calculations). -# -# mime::parsedatetime takes a string containing an 822-style date-time -# specification and returns the specified property. -# -# The list of properties and their ranges are: -# -# property range -# ======== ===== -# clock raw result of "clock scan" -# hour 0 .. 23 -# lmonth January, February, ..., December -# lweekday Sunday, Monday, ... Saturday -# mday 1 .. 31 -# min 0 .. 59 -# mon 1 .. 12 -# month Jan, Feb, ..., Dec -# proper 822-style date-time specification -# rclock elapsed seconds between then and now -# sec 0 .. 59 -# wday 0 .. 6 (Sun .. Mon) -# weekday Sun, Mon, ..., Sat -# yday 1 .. 366 -# year 1900 ... -# zone -720 .. 720 (minutes east of GMT) -# -# Arguments: -# value Either a 822-style date-time specification or '-now' -# if the current date/time should be used. -# property The property (from the list above) to return -# -# Results: -# Returns the string value of the 'property' for the date/time that was -# specified in 'value'. - -namespace eval ::mime { - variable WDAYS_SHORT [list Sun Mon Tue Wed Thu Fri Sat] - variable WDAYS_LONG [list Sunday Monday Tuesday Wednesday Thursday \ - Friday Saturday] - - # Counting months starts at 1, so just insert a dummy element - # at index 0. - variable MONTHS_SHORT [list {} \ - Jan Feb Mar Apr May Jun \ - Jul Aug Sep Oct Nov Dec] - variable MONTHS_LONG [list {} \ - January February March April May June July \ - August Sepember October November December] -} -proc ::mime::parsedatetime {value property} { - if {$value eq "-now"} { - set clock [clock seconds] - } elseif {[regexp {^(.*) ([+-])([0-9][0-9])([0-9][0-9])$} $value \ - -> value zone_sign zone_hour zone_min] - } { - set clock [clock scan $value -gmt 1] - if {[info exists zone_min]} { - set zone_min [scan $zone_min %d] - set zone_hour [scan $zone_hour %d] - set zone [expr {60 * ($zone_min + 60 * $zone_hour)}] - if {$zone_sign eq "+"} { - set zone -$zone - } - incr clock $zone - } - } else { - set clock [clock scan $value] - } - - switch -- $property { - clock { - return $clock - } - - hour { - set value [clock format $clock -format %H] - } - - lmonth { - variable MONTHS_LONG - return [lindex $MONTHS_LONG \ - [scan [clock format $clock -format %m] %d]] - } - - lweekday { - variable WDAYS_LONG - return [lindex $WDAYS_LONG [clock format $clock -format %w]] - } - - mday { - set value [clock format $clock -format %d] - } - - min { - set value [clock format $clock -format %M] - } - - mon { - set value [clock format $clock -format %m] - } - - month { - variable MONTHS_SHORT - return [lindex $MONTHS_SHORT [ - scan [clock format $clock -format %m] %d]] - } - - proper { - set gmt [clock format $clock -format "%Y-%m-%d %H:%M:%S" -gmt true] - if {[set diff [expr {($clock-[clock scan $gmt]) / 60}]] < 0} { - set s - - set diff [expr {-($diff)}] - } else { - set s + - } - set zone [format %s%02d%02d $s [ - expr {$diff / 60}] [expr {$diff % 60}]] - - variable WDAYS_SHORT - set wday [lindex $WDAYS_SHORT [clock format $clock -format %w]] - variable MONTHS_SHORT - set mon [lindex $MONTHS_SHORT [ - scan [clock format $clock -format %m] %d]] - - return [ - clock format $clock -format "$wday, %d $mon %Y %H:%M:%S $zone"] - } - - rclock { - #TODO: these paths are not covered by tests - if {$value eq "-now"} { - return 0 - } else { - return [expr {[clock seconds] - $clock}] - } - } - - sec { - set value [clock format $clock -format %S] - } - - wday { - return [clock format $clock -format %w] - } - - weekday { - variable WDAYS_SHORT - return [lindex $WDAYS_SHORT [clock format $clock -format %w]] - } - - yday { - set value [clock format $clock -format %j] - } - - year { - set value [clock format $clock -format %Y] - } - - zone { - set value [string trim [string map [list \t { }] $value]] - if {[set x [string last { } $value]] < 0} { - return 0 - } - set value [string range $value [expr {$x + 1}] end] - switch -- [set s [string index $value 0]] { - + - - { - if {$s eq "+"} { - #TODO: This path is not covered by tests - set s {} - } - set value [string trim [string range $value 1 end]] - if {( - [string length $value] != 4) - || - [scan $value %2d%2d h m] != 2 - || - $h > 12 - || - $m > 59 - || - ($h == 12 && $m > 0) - } { - error "malformed timezone-specification: $value" - } - set value $s[expr {$h * 60 + $m}] - } - - default { - set value [string toupper $value] - set z1 [list UT GMT EST EDT CST CDT MST MDT PST PDT] - set z2 [list 0 0 -5 -4 -6 -5 -7 -6 -8 -7] - if {[set x [lsearch -exact $z1 $value]] < 0} { - error "unrecognized timezone-mnemonic: $value" - } - set value [expr {[lindex $z2 $x] * 60}] - } - } - } - - date2gmt - - - date2local - - - dst - - - sday - - - szone - - - tzone - - - default { - error "unknown property $property" - } - } - - if {[set value [string trimleft $value 0]] eq {}} { - #TODO: this path is not covered by tests - set value 0 - } - return $value -} - -# ::mime::uniqueID -- -# -# Used to generate a 'globally unique identifier' for the content-id. -# The id is built from the pid, the current time, the hostname, and -# a counter that is incremented each time a message is sent. -# -# Arguments: -# -# Results: -# Returns the a string that contains the globally unique identifier -# that should be used for the Content-ID of an e-mail message. - -proc ::mime::uniqueID {} { - variable mime - - return <[pid].[clock seconds].[incr mime(cid)]@[info hostname]> -} - -# ::mime::parselexeme -- -# -# Used to implement a lookahead parser. -# -# Arguments: -# token The MIME token to operate on. -# -# Results: -# Returns the next token found by the parser. - -proc ::mime::parselexeme {token} { - # FRINK: nocheck - variable $token - upvar 0 $token state - - set state(input) [string trimleft $state(input)] - - set state(buffer) {} - if {$state(input) eq {}} { - set state(buffer) end-of-input - return [set state(lastC) LX_END] - } - - set c [string index $state(input) 0] - set state(input) [string range $state(input) 1 end] - - if {$c eq "("} { - set noteP 0 - set quoteP 0 - - while 1 { - append state(buffer) $c - - #TODO: some of these paths are not covered by tests - switch -- $c/$quoteP { - (/0 { - incr noteP - } - - \\/0 { - set quoteP 1 - } - - )/0 { - if {[incr noteP -1] < 1} { - if {[info exists state(comment)]} { - append state(comment) { } - } - append state(comment) $state(buffer) - - return [parselexeme $token] - } - } - - default { - set quoteP 0 - } - } - - if {[set c [string index $state(input) 0]] eq {}} { - set state(buffer) "end-of-input during comment" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {$c eq "\""} { - set firstP 1 - set quoteP 0 - - while 1 { - append state(buffer) $c - - switch -- $c/$quoteP { - "\\/0" { - set quoteP 1 - } - - "\"/0" { - if {!$firstP} { - return [set state(lastC) LX_QSTRING] - } - set firstP 0 - } - - default { - set quoteP 0 - } - } - - if {[set c [string index $state(input) 0]] eq {}} { - set state(buffer) "end-of-input during quoted-string" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {$c eq {[}} { - set quoteP 0 - - while 1 { - append state(buffer) $c - - switch -- $c/$quoteP { - \\/0 { - set quoteP 1 - } - - ]/0 { - return [set state(lastC) LX_DLITERAL] - } - - default { - set quoteP 0 - } - } - - if {[set c [string index $state(input) 0]] eq {}} { - set state(buffer) "end-of-input during domain-literal" - return [set state(lastC) LX_ERR] - } - set state(input) [string range $state(input) 1 end] - } - } - - if {[set x [lsearch -exact $state(tokenL) $c]] >= 0} { - append state(buffer) $c - - return [set state(lastC) [lindex $state(lexemeL) $x]] - } - - while 1 { - append state(buffer) $c - - switch -- [set c [string index $state(input) 0]] { - {} - " " - "\t" - "\n" { - break - } - - default { - if {[lsearch -exact $state(tokenL) $c] >= 0} { - break - } - } - } - - set state(input) [string range $state(input) 1 end] - } - - return [set state(lastC) LX_ATOM] -} - -# ::mime::mapencoding -- -# -# mime::mapencodings maps tcl encodings onto the proper names for their -# MIME charset type. This is only done for encodings whose charset types -# were known. The remaining encodings return {} for now. -# -# Arguments: -# enc The tcl encoding to map. -# -# Results: -# Returns the MIME charset type for the specified tcl encoding, or {} -# if none is known. - -proc ::mime::mapencoding {enc} { - - variable encodings - - if {[info exists encodings($enc)]} { - return $encodings($enc) - } - return {} -} - -# ::mime::reversemapencoding -- -# -# mime::reversemapencodings maps MIME charset types onto tcl encoding names. -# Those that are unknown return {}. -# -# Arguments: -# mimeType The MIME charset to convert into a tcl encoding type. -# -# Results: -# Returns the tcl encoding name for the specified mime charset, or {} -# if none is known. - -proc ::mime::reversemapencoding {mimeType} { - - variable reversemap - - set lmimeType [string tolower $mimeType] - if {[info exists reversemap($lmimeType)]} { - return $reversemap($lmimeType) - } - return {} -} - -# ::mime::word_encode -- -# -# Word encodes strings as per RFC 2047. -# -# Arguments: -# charset The character set to encode the message to. -# method The encoding method (base64 or quoted-printable). -# string The string to encode. -# ?-charset_encoded 0 or 1 Whether the data is already encoded -# in the specified charset (default 1) -# ?-maxlength maxlength The maximum length of each encoded -# word to return (default 66) -# -# Results: -# Returns a word encoded string. - -proc ::mime::word_encode {charset method string {args}} { - - variable encodings - - if {![info exists encodings($charset)]} { - error "unknown charset '$charset'" - } - - if {$encodings($charset) eq {}} { - error "invalid charset '$charset'" - } - - if {$method ne "base64" && $method ne "quoted-printable"} { - error "unknown method '$method', must be base64 or quoted-printable" - } - - # default to encoded and a length that won't make the Subject header to long - array set options [list -charset_encoded 1 -maxlength 66] - array set options $args - - if {$options(-charset_encoded)} { - set unencoded_string [::encoding convertfrom $charset $string] - } else { - set unencoded_string $string - } - - set string_length [string length $unencoded_string] - - if {!$string_length} { - return {} - } - - set string_bytelength [string bytelength $unencoded_string] - - # the 7 is for =?, ?Q?, ?= delimiters of the encoded word - set maxlength [expr {$options(-maxlength) - [string length $encodings($charset)] - 7}] - switch -exact -- $method { - base64 { - if {$maxlength < 4} { - error "maxlength $options(-maxlength) too short for chosen charset and encoding" - } - set count 0 - set maxlength [expr {($maxlength / 4) * 3}] - while {$count < $string_length} { - set length 0 - set enc_string {} - while {$length < $maxlength && $count < $string_length} { - set char [string range $unencoded_string $count $count] - set enc_char [::encoding convertto $charset $char] - if {$length + [string length $enc_char] > $maxlength} { - set length $maxlength - } else { - append enc_string $enc_char - incr count - incr length [string length $enc_char] - } - } - set encoded_word [string map [ - list \n {}] [base64 -mode encode -- $enc_string]] - append result "=?$encodings($charset)?B?$encoded_word?=\n " - } - # Trim off last "\n ", since the above code has the side-effect - # of adding an extra "\n " to the encoded string. - - set result [string range $result 0 end-2] - } - quoted-printable { - if {$maxlength < 1} { - error "maxlength $options(-maxlength) too short for chosen charset and encoding" - } - set count 0 - while {$count < $string_length} { - set length 0 - set encoded_word {} - while {$length < $maxlength && $count < $string_length} { - set char [string range $unencoded_string $count $count] - set enc_char [::encoding convertto $charset $char] - set qp_enc_char [qp_encode $enc_char 1] - set qp_enc_char_length [string length $qp_enc_char] - if {$qp_enc_char_length > $maxlength} { - error "maxlength $options(-maxlength) too short for chosen charset and encoding" - } - if { - $length + [string length $qp_enc_char] > $maxlength - } { - set length $maxlength - } else { - append encoded_word $qp_enc_char - incr count - incr length [string length $qp_enc_char] - } - } - append result "=?$encodings($charset)?Q?$encoded_word?=\n " - } - # Trim off last "\n ", since the above code has the side-effect - # of adding an extra "\n " to the encoded string. - - set result [string range $result 0 end-2] - } - {} { - # Go ahead - } - default { - error "Can't handle content encoding \"$method\"" - } - } - return $result -} - -# ::mime::word_decode -- -# -# Word decodes strings that have been word encoded as per RFC 2047. -# -# Arguments: -# encoded The word encoded string to decode. -# -# Results: -# Returns the string that has been decoded from the encoded message. - -proc ::mime::word_decode {encoded} { - - variable reversemap - - if {[regexp -- {=\?([^?]+)\?(.)\?([^?]*)\?=} $encoded \ - - charset method string] != 1 - } { - error "malformed word-encoded expression '$encoded'" - } - - set enc [reversemapencoding $charset] - if {$enc eq {}} { - error "unknown charset '$charset'" - } - - switch -exact -- $method { - b - - B { - set method base64 - } - q - - Q { - set method quoted-printable - } - default { - error "unknown method '$method', must be B or Q" - } - } - - switch -exact -- $method { - base64 { - set result [base64 -mode decode -- $string] - } - quoted-printable { - set result [qp_decode $string 1] - } - {} { - # Go ahead - } - default { - error "Can't handle content encoding \"$method\"" - } - } - - return [list $enc $method $result] -} - -# ::mime::field_decode -- -# -# Word decodes strings that have been word encoded as per RFC 2047 -# and converts the string from the original encoding/charset to UTF. -# -# Arguments: -# field The string to decode -# -# Results: -# Returns the decoded string in UTF. - -proc ::mime::field_decode {field} { - # ::mime::field_decode is broken. Here's a new version. - # This code is in the public domain. Don Libes - - # Step through a field for mime-encoded words, building a new - # version with unencoded equivalents. - - # Sorry about the grotesque regexp. Most of it is sensible. One - # notable fudge: the final $ is needed because of an apparent bug - # in the regexp engine where the preceding .* otherwise becomes - # non-greedy - perhaps because of the earlier ".*?", sigh. - - while {[regexp {(.*?)(=\?(?:[^?]+)\?(?:.)\?(?:[^?]*)\?=)(.*)$} $field \ - ignore prefix encoded field] - } { - # don't allow whitespace between encoded words per RFC 2047 - if {{} ne $prefix} { - if {![string is space $prefix]} { - append result $prefix - } - } - - set decoded [word_decode $encoded] - foreach {charset - string} $decoded break - - append result [::encoding convertfrom $charset $string] - } - append result $field - return $result -} - -## One-Shot Initialization - -::apply {{} { - variable encList - variable encAliasList - variable reversemap - - foreach {enc mimeType} $encList { - if {$mimeType eq {}} continue - set reversemap([string tolower $mimeType]) $enc - } - - foreach {enc mimeType} $encAliasList { - set reversemap([string tolower $mimeType]) $enc - } - - # Drop the helper variables - unset encList encAliasList - -} ::mime} - - -variable ::mime::internal 0 diff --git a/src/bootsupport/modules/oolib-0.1.2.tm b/src/bootsupport/modules/oolib-0.1.2.tm index af5da523..858c61cd 100644 --- a/src/bootsupport/modules/oolib-0.1.2.tm +++ b/src/bootsupport/modules/oolib-0.1.2.tm @@ -1,201 +1,201 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1.2 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - #variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - set idx $globOrIdx - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key >= 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex $o_data $key] - #return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? - #method alias {newAlias existingKeyOrAlias} { - # if {[string is integer -strict $newAlias]} { - # error "[self object] collection key alias cannot be integer" - # } - # if {[string length $existingKeyOrAlias]} { - # set o_alias($newAlias) $existingKeyOrAlias - # } else { - # unset o_alias($newAlias) - # } - #} - #method aliases {{key ""}} { - # if {[string length $key]} { - # set result [list] - # foreach {n v} [array get o_alias] { - # if {$v eq $key} { - # lappend result $n $v - # } - # } - # return $result - # } else { - # return [array get o_alias] - # } - #} - ##if the supplied index is an alias, return the underlying key; else return the index supplied. - #method realKey {idx} { - # if {[catch {set o_alias($idx)} key]} { - # return $idx - # } else { - # return $key - # } - #} - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse_the_collection {} { - #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs - #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. - #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1.2 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + #variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? + #method alias {newAlias existingKeyOrAlias} { + # if {[string is integer -strict $newAlias]} { + # error "[self object] collection key alias cannot be integer" + # } + # if {[string length $existingKeyOrAlias]} { + # set o_alias($newAlias) $existingKeyOrAlias + # } else { + # unset o_alias($newAlias) + # } + #} + #method aliases {{key ""}} { + # if {[string length $key]} { + # set result [list] + # foreach {n v} [array get o_alias] { + # if {$v eq $key} { + # lappend result $n $v + # } + # } + # return $result + # } else { + # return [array get o_alias] + # } + #} + ##if the supplied index is an alias, return the underlying key; else return the index supplied. + #method realKey {idx} { + # if {[catch {set o_alias($idx)} key]} { + # return $idx + # } else { + # return $key + # } + #} + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse_the_collection {} { + #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs + #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. + #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/bootsupport/modules/oolib-0.1.tm b/src/bootsupport/modules/oolib-0.1.tm deleted file mode 100644 index 3756fceb..00000000 --- a/src/bootsupport/modules/oolib-0.1.tm +++ /dev/null @@ -1,195 +0,0 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key > 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - method alias {newAlias existingKeyOrAlias} { - if {[string is integer -strict $newAlias]} { - error "[self object] collection key alias cannot be integer" - } - if {[string length $existingKeyOrAlias]} { - set o_alias($newAlias) $existingKeyOrAlias - } else { - unset o_alias($newAlias) - } - } - method aliases {{key ""}} { - if {[string length $key]} { - set result [list] - foreach {n v} [array get o_alias] { - if {$v eq $key} { - lappend result $n $v - } - } - return $result - } else { - return [array get o_alias] - } - } - #if the supplied index is an alias, return the underlying key; else return the index supplied. - method realKey {idx} { - if {[catch {set o_alias($idx)} key]} { - return $idx - } else { - return $key - } - } - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse {} { - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - diff --git a/src/bootsupport/modules/overtype-1.6.1.tm b/src/bootsupport/modules/overtype-1.6.1.tm deleted file mode 100644 index 91ed77ec..00000000 --- a/src/bootsupport/modules/overtype-1.6.1.tm +++ /dev/null @@ -1,3399 +0,0 @@ -# -*- 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) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.1 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.1] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6 -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix string range -# - need to extract and replace ansi codes? - -namespace eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - namespace eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -namespace eval overtype { - variable grapheme_widths [dict create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [dict create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - -#proc overtype::stripansi {text} { -# variable escape_terminals ;#dict -# variable ansi_2byte_codes_dict -# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway -# if {[string first \033 $text] <0 && [string first \009c $text] <0} { -# #\033 same as \x1b -# return $text -# } -# -# set text [convert_g0 $text] -# -# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. -# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) -# set inputlist [split $text ""] -# set outputlist [list] -# -# set 2bytecodes [dict values $ansi_2byte_codes_dict] -# -# set in_escapesequence 0 -# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls -# set i 0 -# foreach u $inputlist { -# set v [lindex $inputlist $i+1] -# set uv ${u}${v} -# if {$in_escapesequence eq "2b"} { -# #2nd byte - done. -# set in_escapesequence 0 -# } elseif {$in_escapesequence != 0} { -# set escseq [dict get $escape_terminals $in_escapesequence] -# if {$u in $escseq} { -# set in_escapesequence 0 -# } elseif {$uv in $escseq} { -# set in_escapseequence 2b ;#flag next byte as last in sequence -# } -# } else { -# #handle both 7-bit and 8-bit CSI and OSC -# if {[regexp {^(?:\033\[|\u009b)} $uv]} { -# set in_escapesequence CSI -# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { -# set in_escapesequence OSC -# } elseif {$uv in $2bytecodes} { -# #self-contained e.g terminal reset - don't pass through. -# set in_escapesequence 2b -# } else { -# lappend outputlist $u -# } -# } -# incr i -# } -# return [join $outputlist ""] -#} - - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::stripansi $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -namespace eval overtype::priv { -} - -#could return larger than colwidth -proc _get_row_append_column {row} { - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_overflow opt_overflow - upvar colwidth colwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$opt_overflow} { - return $endpos - } else { - if {$endpos > $colwidth} { - return $colwidth + 1 - } else { - return $endpos - } - } - } -} -#string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r -#render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. -#The underlay and overlay can be multiline blocks of text of varying line lengths. -#The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. -#This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. -# a cursor start position other than top-left is a possible addition to consider. -#see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline -proc overtype::left {args} { - #*** !doctools - #[call [fun overtype::left] [arg args] ] - #[para] usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - lassign [lrange $args end-1 end] underblock overblock - set defaults [dict create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -wrap 0\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - ] - #-ellipsis args not used if -wrap is true - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental {} - default { - set known_opts [dict keys $defaults] - error "overtype::left unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_overflow [dict get $opts -overflow] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_wrap [dict get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [dict get $opts -width] - set opt_height [dict get $opts -height] - set opt_appendlines [dict get $opts -appendlines] - set opt_transparent [dict get $opts -transparent] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_exposed1 [dict get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set test_mode 1 - set info_mode 0 - set edit_mode 0 - set opt_experimental [dict get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - test_mode { - set test_mode 1 - set info_mode 1 - } - old_mode { - set test_mode 0 - set info_mode 1 - } - data_mode { - set data_mode 1 - } - info_mode { - set info_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - #modes - set insert_mode 0 ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l - set autowrap_mode $opt_wrap - set reverse_mode 0 - - - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #colwidth & colheight were originally named with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - #The naming is now confusing. It should be something like renderwidth renderheight ?? review - - if {$opt_width eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight - } else { - set colwidth $opt_width - set colheight $opt_height - } - if {$underblock eq ""} { - set blank "\x1b\[0m\x1b\[0m" - #set underlines [list "\x1b\[0m\x1b\[0m"] - set underlines [lrepeat $colheight $blank] - } else { - set underlines [lines_as_list -ansiresets 1 $underblock] - } - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output colwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [dict get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[string length $overblock] + 10}] - } - - if {!$test_mode} { - set inputchunks [split $overblock \n] - } else { - set scheme 3 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [string cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [string range [lindex $lflines end] 0 end-1] - } - set inputchunks $lflines[unset lflines] - - } - } - } - - - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height - - - set replay_codes_underlay [dict create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "" - set unapplied "" - set cursor_saved_position [dict create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - if {$data_mode} { - set col [_get_row_append_column $row] - } else { - set col 1 - } - - set instruction_stats [dict create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![string length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [string cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [string cat $replay_codes_overlay $overtext] - if {[dict exists $replay_codes_underlay $row]} { - set undertext [string cat [dict get $replay_codes_underlay $row] $undertext] - } - #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set LASTCALL [list -info 1 -insert_mode $insert_mode -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental -info 1 -insert_mode $insert_mode -cursor_restore_attributes $cursor_saved_attributes -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set instruction [dict get $rinfo instruction] - set insert_mode [dict get $rinfo insert_mode] - set autowrap_mode [dict get $rinfo autowrap_mode] ;# - #set reverse_mode [dict get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set overflow_right_column [dict get $rinfo overflow_right_column] - set unapplied [dict get $rinfo unapplied] - set unapplied_list [dict get $rinfo unapplied_list] - set post_render_col [dict get $rinfo cursor_column] - set post_render_row [dict get $rinfo cursor_row] - set c_saved_pos [dict get $rinfo cursor_saved_position] - set c_saved_attributes [dict get $rinfo cursor_saved_attributes] - set visualwidth [dict get $rinfo visualwidth] - set insert_lines_above [dict get $rinfo insert_lines_above] - set insert_lines_below [dict get $rinfo insert_lines_below] - dict set replay_codes_underlay [expr {$renderedrow+1}] [dict get $rinfo replay_codes_underlay] - #lset replay_codes_overlay [expr $overidx+1] [dict get $rinfo replay_codes_overlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::left loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[dict size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - dict incr instruction_stats $instruction - switch -- $instruction { - {} { - if {$test_mode == 0} { - incr row - if {$data_mode} { - set col [_get_row_append_column $row] - if {$col > $colwidth} { - - } - } else { - set col 1 - } - } else { - #lf included in data - set row $post_render_row - set col $post_render_col - - #set col 1 - #if {$post_render_row != $renderedrow} { - # set col 1 - #} else { - # set col $post_render_col - #} - } - } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[dict exists $cursor_saved_position row]} { - set row [dict get $cursor_saved_position row] - set col [dict get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [dict get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [dict create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::left cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [dict get $opts -overflow] "" $overflow_right] - set foldline [dict get $sub_info result] - set insert_mode [dict get $sub_info insert_mode] ;#probably not needed.. - set autowrap_mode [dict get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? - } - lf_start { - #raw newlines - must be test_mode - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col 1 - # ---------------------- - } - lf_mid { - - if 0 { - #set rhswidth [punk::ansi::printing_length $overflow_right] - #only show debug when we have overflow? - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - - set rhs "" - if {$overflow_right ne ""} { - set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $overflow_right]] - set rhs [textblock::frame -title overflow_right $rhs] - } - puts [textblock::join $lhs " $post_render_col " $rhs] - } - - if {!$test_mode} { - #rendered - append rendered $overflow_right - #set replay_codes_overlay "" - set overflow_right "" - - - set row $renderedrow - - set col 1 - incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col 1 - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col 1 - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after colwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right - - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col 1 - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - if {$test_mode == 0} { - set row $renderedrow - set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too - incr row $insert_lines_below - set col 1 - } else { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col 1 - - - - } - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $colwidth - set r $post_render_row - if {$post_render_col > $colwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $colwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c 1 - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $colwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $colwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {$autowrap_mode} { - incr row - set col 1 ;#whether wrap or not - next data is at column 1 ?? - } else { - #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [string range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {$autowrap_mode} { - if {$colwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col 1 - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$colwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - default { - puts stderr "overtype::left unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_overflow && !$autowrap_mode} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[dict get $opts -ellipsis]} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[string trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - if {[string trim [ansistrip $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::left looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "test_mode:$test_mode\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[dict get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[dict get $LASTCALL -cursor_column]\n" - dict for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - if {$info_mode} { - #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? - #append result \n$instruction_stats\n - } - return $result -} - -namespace eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} -#todo - left-right ellipsis ? -proc overtype::centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set defaults [dict create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 {} - default { - set known_opts [dict keys $defaults] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - # -- --- --- --- --- --- - - - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$colwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[string tolower [dict get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [dict get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![dict get $opts -overflow]} { - #lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] - #set overtext [string range $overtext 0 $colwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use string range on ANSI data - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[string trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [dict get $rinfo result] - } - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] -} - -proc overtype::right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set defaults [dict create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align {} - default { - set known_opts [dict keys $defaults] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_overflow [dict get $opts -overflow] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - set opt_align [dict get $opts -align] - # -- --- --- --- --- --- - - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [dict get $rinfo replay_codes] - set rendered [dict get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - if {[string trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis [string cat $replay_codes $opt_ellipsistext] - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [dict get $rinfo result] - } - set replay_codes [dict get $rinfo replay_codes] - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] -} - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [dict create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [dict merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -namespace eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended for single grapheme - but will work for multiple -#cannot contain ansi or newlines -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[dict exists $grapheme_widths $ch]} { - return [dict get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - dict set grapheme_widths $ch $width - return $width -} - - - -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### -# renderline written from a left-right line orientation perspective as a first-shot at getting something useful. -# ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. -# ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### -# -# -#-returnextra enables returning of overflow and length -#review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? -#review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements -#(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char) -#todo - review transparency issues with single/double width characters -#bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? -proc overtype::renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} - } - lassign [lrange $args end-1 end] under over - if {[string first \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - set defaults [dict create\ - -etabs 0\ - -width \uFFEF\ - -overflow 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -experimental - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes {} - default { - set known_opts [dict keys $defaults] - error "overtype::renderline unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [dict get $opts -width] - set opt_etabs [dict get $opts -etabs] - set opt_overflow [dict get $opts -overflow] - set opt_colstart [dict get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [dict get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [dict get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![string is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [dict get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [dict get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [dict get $opts -reverse_mode] ;#DECSNM - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [dict get $opts -cursor_restore_attributes] - - set test_mode 0 - set cp437_glyphs 0 - foreach e [dict get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set cp437_map [dict create] - if {$cp437_glyphs} { - set cp437_map [set ::punk::ansi::cp437_map] - #for cp437 images we need to map these *after* splitting ansi - #some old files might use newline for its glyph.. but we can't easily support that. - #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - dict unset cp437_map \n - } - - set opt_transparent [dict get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [dict get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [string map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis - set width 1 - } - } - } - } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - if {$code ne ""} { - set c1c2 [string range $code 0 1] - set leadernorm [string range [string map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[string index $c1c2 0] eq "\x1b"} { - set maybemouse [string index $code 2] - } - - if {$maybemouse ne "<" && [string index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [string index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - if {!$test_mode} { - #fill columns to width with spaces, and carry over stacks - we will have to keep track of where the underlying data ends manually - TODO - #Specifying a width is suitable for terminal-like applications and text-blocks - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff " "] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - } else { - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - } - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } else { - set colwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] - #### - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - if {$cp437_glyphs} { - set pt [string map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[dict exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [dict get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_overflow} { - #somewhat counterintuitively - overflow true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - set overflow_idx -1 - } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data - #foreach {pt code} $overmap {} - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $colwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [string map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty string to column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied - #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #change the overflow_idx - set overflow_idx $idx - incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci - #throw back to caller's loop - add instruction to caller as this is not the usual case - #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line - set instruction overflow_splitchar - break - } elseif {$owidth > 2} { - #? tab? - #TODO! - puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" - #tab of some length dependent on tabstops/elastic tabstop settings? - } - } elseif {$idx >= $overflow_idx} { - #jmn? - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break - } - } else { - #review. - #This corresponds to opt_overflow being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #dict set understacks $idx [list] ;#review - use idx-1 codestack? - lset understacks $idx [list] - incr idx - incr cursor_column - } else { - #todo - punk::char::char_width - set g [lindex $outcols $idx] - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay - if {$next_pt_overchar eq ""} { - #special-case trailing transparent - no next_pt_overchar - incr idx - incr cursor_column - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - incr idx - incr cursor_column - } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - if {$overflow_idx !=-1 && !$test_mode} { - #overflow - if {$cursor_column > [llength $outcols]} { - set cursor_column [llength $outcols] - } - } - } - } - } - } ;# end switch - - - } - other { - set code $item - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - set re_row_move {\x1b\[([0-9]*)(A|B)$} - set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - set re_cursor_restore {\x1b\[u$} - set re_cursor_save_dec {\x1b7$} - set re_cursor_restore_dec {\x1b8$} - set re_other_single {\x1b(D|M|E)$} - set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - set matchinfo [list] - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore - set code [string map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $code] - - - set c1 [string index $code 0] - set c1c2c3 [string range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - set leadernorm [string range [string map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [string cat $leadernorm [string range $code 3 end]] - } - 7CSI - 7OSC { - set codenorm [string cat $leadernorm [string range $code 2 end]] - } - 7ESC { - set codenorm [string cat $leadernorm [string range $code 1 end]] - } - 8CSI - 8OSC { - set codenorm [string cat $leadernorm [string range $code 1 end]] - } - default { - #we haven't made a mapping for this - set codenorm $code - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [string index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [string range $codenorm 4 end-1] - #puts stdout "--> CSI [string index $leadernorm 0] bit param:$param" - switch -- [string index $codenorm end] { - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - set num $param - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - C { - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - set num $param - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$test_mode && $cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[dict exists $understacks $idx]} { - # set stackinfo [dict get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [dict get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - G { - #Col move - #move absolute column - #adjust to colstart - as column 1 is within overlay - #??? - set idx [expr {$param + $opt_colstart -1}] - set cursor_column $param - error "renderline absolute col move ESC G unimplemented" - } - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #Row move - down - set num $param - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - H - f { - #$re_both_move - lassign [split $param {;}] row col - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #lassign $matchinfo _match row col - - if {$col eq ""} {set col 1} - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$col > $max} { - set cursor_column $max - } else { - set cursor_column $col - } - set idx [expr {$cursor_column -1}] - - if {$row eq ""} {set row 1} - set cursor_row $row - if {$cursor_row < 1} { - set cursor_row 1 - } - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - X { - puts stderr "X - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - # - todo - make ansi.sys CSI s cursor save only apply for certain cases? - may need to support DECSLRM instead which uses same code - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - - } - u { - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - ~ { - #$re_vt_sequence - #lassign $matchinfo _match key mod - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - h - l { - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - if {[string index $codenorm 4] eq "?"} { - set num [string range $codenorm 5 end-1] ;#param between ? and h|l - #lassign $matchinfo _match num type - switch -- $num { - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? presume not - but sanity check for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline error - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 - } - } - 25 { - if {$type eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - } - - } else { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - #$re_other_single - switch -- [string index $codenorm end] { - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "ESC E unimplemented" - - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - - } - } - - #switch -regexp -matchvar matchinfo -- $code\ - #$re_mode { - #}\ - #default { - # puts stderr "overtype::renderline code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - #} - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_overflow == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW - set in_overflow 1 - } - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [dict get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {$g0 ne $prev_g0} { - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } else { - set gxleader "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - - set sgrleader "" - if {$i < [llength $understacks]} { - #set cstack [dict get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - if {$idx+1 < $cursor_column} { - append outstring [string map [list "\u0000" " "] $ch] - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - if {![ansistring length $overflow_right]} { - set outstring [string trimright $outstring "\u0000"] - } - set outstring [string map [list "\u0000" " "] $outstring] - set overflow_right [string trimright $overflow_right "\u0000"] - set overflow_right [string map [list "\u0000" " "] $overflow_right] - - set replay_codes "" - if {[llength $understacks] > 0} { - if {$overflow_idx == -1} { - #set tail_idx [dict size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [dict create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - opt_overflow $opt_overflow\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - ] - if {$opt_returnextra == 1} { - return $result - } else { - #human/debug - map special chars to visual glyphs - set viewop VIEW - switch -- $opt_returnextra { - 2 { - #codes and character data - set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others - } - 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. - } - } - dict set result result [ansistring $viewop -lf 1 -vt 1 [dict get $result result]] - dict set result overflow_right [ansistring VIEW -lf 1 -vt 1 [dict get $result overflow_right]] - dict set result unapplied [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied]] - dict set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied_list]] - dict set result replay_codes [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes]] - dict set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_underlay]] - dict set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_overlay]] - dict set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [dict get $result cursor_saved_attributes]] - return $result - } - } else { - return $outstring - } - #return [join $out ""] -} -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[string first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansi $textblock] - } - if {[string first \n $textblock] >= 0} { - set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -namespace eval overtype::priv { - variable cache_is_sgr [dict create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[dict exists $cache_is_sgr $code]} { - return [dict get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - dict set cache_is_sgr $code $answer - return $answer - } - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } else { - - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. - if {![string is integer -strict $count] || $count < 1} { - error "render_erasechar count must be integer >= 1" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - if 0 { - if {$c eq "c"} { - puts "i:$i c:$c sgrstack:[ansistring VIEW $sgrstack]" - puts "understacks:[ansistring VIEW $ustacks]" - upvar overstacks overstacks - puts "overstacks:[ansistring VIEW $overstacks]" - puts "info level 0:[info level 0]" - } - } - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -namespace eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [namespace eval overtype { - variable version - set version 1.6.1 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/bootsupport/modules/overtype-1.6.2.tm b/src/bootsupport/modules/overtype-1.6.2.tm deleted file mode 100644 index 0bdd4ca0..00000000 --- a/src/bootsupport/modules/overtype-1.6.2.tm +++ /dev/null @@ -1,3415 +0,0 @@ -# -*- 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) Julian Noble 2003-2023 -# -# @@ Meta Begin -# Application overtype 1.6.2 -# Meta platform tcl -# Meta license BSD -# @@ Meta End - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -# doctools header -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.2] -#[copyright "2024"] -#[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] -#[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] -#[require overtype] -#[keywords module text ansi] -#[description] -#[para] - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[section Overview] -#[para] overview of overtype -#[subsection Concepts] -#[para] - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Requirements -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ - -#*** !doctools -#[subsection dependencies] -#[para] packages used by overtype -#[list_begin itemized] - -package require Tcl 8.6- -package require textutil -package require punk::lib ;#required for lines_as_list -package require punk::ansi ;#required to detect, split, strip and calculate lengths -package require punk::char ;#box drawing - and also unicode character width determination for proper layout of text with double-column-width chars -package require punk::assertion -#*** !doctools -#[item] [package {Tcl 8.6}] -#[item] [package textutil] -#[item] [package punk::ansi] -#[para] - required to detect, split, strip and calculate lengths of text possibly containing ansi codes -#[item] [package punk::char] -#[para] - box drawing - and also unicode character width determination for proper layout of text with double-column-width chars - -# #package require frobz -# #*** !doctools -# #[item] [package {frobz}] - -#*** !doctools -#[list_end] - - - - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -#*** !doctools -#[section API] - - -#Julian Noble - 2003 -#Released under standard 'BSD license' conditions. -# -#todo - ellipsis truncation indicator for center,right - -#v1.4 2023-07 - naive ansi color handling - todo - fix string range -# - need to extract and replace ansi codes? - -namespace eval overtype { - namespace import ::punk::assertion::assert - punk::assertion::active true - - namespace path ::punk::lib - - namespace export * - variable default_ellipsis_horizontal "..." ;#fallback - variable default_ellipsis_vertical "..." - namespace eval priv { - proc _init {} { - upvar ::overtype::default_ellipsis_horizontal e_h - upvar ::overtype::default_ellipsis_vertical e_v - set e_h [format %c 0x2026] ;#Unicode Horizontal Ellipsis - set e_v [format %c 0x22EE] - #The unicode ellipsis looks more natural than triple-dash which is centred vertically whereas ellipsis is at floorline of text - #Also - unicode ellipsis has semantic meaning that other processors can interpret - #unicode does also provide a midline horizontal ellipsis 0x22EF - - #set e [format %c 0x2504] ;#punk::char::charshort boxd_ltdshhz - Box Drawings Light Triple Dash Horizontal - #if {![catch {package require punk::char}]} { - # set e [punk::char::charshort boxd_ltdshhz] - #} - } - } - priv::_init -} -proc overtype::about {} { - return "Simple text formatting. Author JMN. BSD-License" -} - -namespace eval overtype { - variable grapheme_widths [dict create] - - variable escape_terminals - #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals - - #self-contained 2 byte ansi escape sequences - review more? - variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [dict create\ - "reset_terminal" "\u001bc"\ - "save_cursor_posn" "\u001b7"\ - "restore_cursor_posn" "\u001b8"\ - "cursor_up_one" "\u001bM"\ - "NEL - Next Line" "\u001bE"\ - "IND - Down one line" "\u001bD"\ - "HTS - Set Tab Stop" "\u001bH"\ - ] - - #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. - # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ -} - - -#proc overtype::stripansi {text} { -# variable escape_terminals ;#dict -# variable ansi_2byte_codes_dict -# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway -# if {[string first \033 $text] <0 && [string first \009c $text] <0} { -# #\033 same as \x1b -# return $text -# } -# -# set text [convert_g0 $text] -# -# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. -# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) -# set inputlist [split $text ""] -# set outputlist [list] -# -# set 2bytecodes [dict values $ansi_2byte_codes_dict] -# -# set in_escapesequence 0 -# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls -# set i 0 -# foreach u $inputlist { -# set v [lindex $inputlist $i+1] -# set uv ${u}${v} -# if {$in_escapesequence eq "2b"} { -# #2nd byte - done. -# set in_escapesequence 0 -# } elseif {$in_escapesequence != 0} { -# set escseq [dict get $escape_terminals $in_escapesequence] -# if {$u in $escseq} { -# set in_escapesequence 0 -# } elseif {$uv in $escseq} { -# set in_escapseequence 2b ;#flag next byte as last in sequence -# } -# } else { -# #handle both 7-bit and 8-bit CSI and OSC -# if {[regexp {^(?:\033\[|\u009b)} $uv]} { -# set in_escapesequence CSI -# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { -# set in_escapesequence OSC -# } elseif {$uv in $2bytecodes} { -# #self-contained e.g terminal reset - don't pass through. -# set in_escapesequence 2b -# } else { -# lappend outputlist $u -# } -# } -# incr i -# } -# return [join $outputlist ""] -#} - - - - - -proc overtype::string_columns {text} { - if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::stripansi $text] - } - return [punk::char::ansifreestring_width $text] -} - -#todo - consider a way to merge overtype::left/centre/right -#These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock -#overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. -#(i.e not even necessariy having it's top left within the underlay) -namespace eval overtype::priv { -} - -#could return larger than colwidth -proc _get_row_append_column {row} { - upvar outputlines outputlines - set idx [expr {$row -1}] - if {$row <= 1 || $row > [llength $outputlines]} { - return 1 - } else { - upvar opt_overflow opt_overflow - upvar colwidth colwidth - set existinglen [punk::ansi::printing_length [lindex $outputlines $idx]] - set endpos [expr {$existinglen +1}] - if {$opt_overflow} { - return $endpos - } else { - if {$endpos > $colwidth} { - return $colwidth + 1 - } else { - return $endpos - } - } - } -} - -namespace eval overtype { - #*** !doctools - #[subsection {Namespace overtype}] - #[para] Core API functions for overtype - #[list_begin definitions] - - - - #string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r - #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. - #The underlay and overlay can be multiline blocks of text of varying line lengths. - #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. - #This is a single-shot rendering of strings - ie there is no way to chain another call containing a cursor-restore to previously rendered output and have it know about any cursor-saves in the first call. - # a cursor start position other than top-left is a possible addition to consider. - #see editbuf in punk::repl for a more stateful ansi-processor. Both systems use loops over overtype::renderline - proc left {args} { - #*** !doctools - #[call [fun overtype::left] [arg args] ] - #[para] usage: ?-transparent [lb]0|1[rb]? ?-overflow [lb]1|0[rb]? ?-ellipsis [lb]1|0[rb]? ?-ellipsistext ...? undertext overtext - - # @c overtype starting at left (overstrike) - # @c can/should we use something like this?: 'format "%-*s" $len $overtext - variable default_ellipsis_horizontal - - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} - } - lassign [lrange $args end-1 end] underblock overblock - set defaults [dict create\ - -bias ignored\ - -width \uFFEF\ - -height \uFFEF\ - -wrap 0\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -appendlines 1\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -experimental 0\ - -looplimit \uFFEF\ - ] - #-ellipsis args not used if -wrap is true - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -looplimit - -width - -height - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental {} - default { - set known_opts [dict keys $defaults] - error "overtype::left unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_overflow [dict get $opts -overflow] - ##### - # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_wrap [dict get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) - ##### - #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [dict get $opts -width] - set opt_height [dict get $opts -height] - set opt_appendlines [dict get $opts -appendlines] - set opt_transparent [dict get $opts -transparent] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_exposed1 [dict get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo - # -- --- --- --- --- --- - - # ---------------------------- - # -experimental dev flag to set flags etc - # ---------------------------- - set data_mode 0 - set test_mode 1 - set info_mode 0 - set edit_mode 0 - set opt_experimental [dict get $opts -experimental] - foreach o $opt_experimental { - switch -- $o { - test_mode { - set test_mode 1 - set info_mode 1 - } - old_mode { - set test_mode 0 - set info_mode 1 - } - data_mode { - set data_mode 1 - } - info_mode { - set info_mode 1 - } - edit_mode { - set edit_mode 1 - } - } - } - # ---------------------------- - - #modes - set insert_mode 0 ;#can be toggled by insert key or ansi IRM sequence ESC [ 4 h|l - set autowrap_mode $opt_wrap - set reverse_mode 0 - - - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] - - - #set underlines [split $underblock \n] - - #underblock is a 'rendered' block - so width height make sense - #colwidth & colheight were originally named with reference to rendering into a 'column' of output e.g a table column - before cursor row/col was implemented. - #The naming is now confusing. It should be something like renderwidth renderheight ?? review - - if {$opt_width eq "\uFFEF"} { - lassign [blocksize $underblock] _w colwidth _h colheight - } else { - set colwidth $opt_width - set colheight $opt_height - } - if {$underblock eq ""} { - set blank "\x1b\[0m\x1b\[0m" - #set underlines [list "\x1b\[0m\x1b\[0m"] - set underlines [lrepeat $colheight $blank] - } else { - set underlines [lines_as_list -ansiresets 1 $underblock] - } - - #todo - reconsider the 'line' as the natural chunking mechanism for the overlay. - #In practice an overlay ANSI stream can be a single line with ansi moves/restores etc - or even have no moves or newlines, just relying on wrapping at the output colwidth - #In such cases - we process the whole shebazzle for the first output line - only reducing by the applied amount at the head each time, reprocessing the long tail each time. - #(in cases where there are interline moves or cursor jumps anyway) - #This works - but doesn't seem efficient. - #On the other hand.. maybe it depends on the data. For simpler files it's more efficient than splitting first - - #a hack until we work out how to avoid infinite loops... - # - set looplimit [dict get $opts -looplimit] - if {$looplimit eq "\uFFEF"} { - #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? - #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[string length $overblock] + 10}] - } - - if {!$test_mode} { - set inputchunks [split $overblock \n] - } else { - set scheme 3 - switch -- $scheme { - 0 { - #one big chunk - set inputchunks [list $overblock] - } - 1 { - set inputchunks [punk::ansi::ta::split_codes $overblock] - } - 2 { - - #split into lines if possible first - then into plaintext/ansi-sequence chunks ? - set inputchunks [list ""] ;#put an empty plaintext split in for starters - set i 1 - set lines [split $overblock \n] - foreach ln $lines { - if {$i < [llength $lines]} { - append ln \n - } - set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? - set lastpt [lindex $inputchunks end] - lset inputchunks end [string cat $lastpt [lindex $sequence_split 0]] - lappend inputchunks {*}[lrange $sequence_split 1 end] - incr i - } - } - 3 { - #it turns out line based chunks are faster than the above.. probably because some of those end up doing the regex splitting twice - set lflines [list] - set inputchunks [split $overblock \n] - foreach ln $inputchunks { - append ln \n - lappend lflines $ln - } - if {[llength $lflines]} { - lset lflines end [string range [lindex $lflines end] 0 end-1] - } - set inputchunks $lflines[unset lflines] - - } - } - } - - - #overblock height/width isn't useful in the presence of an ansi input overlay with movements. The number of lines may bear little relationship to the output height - #lassign [blocksize $overblock] _w overblock_width _h overblock_height - - - set replay_codes_underlay [dict create 1 ""] - #lappend replay_codes_overlay "" - set replay_codes_overlay "" - set unapplied "" - set cursor_saved_position [dict create] - set cursor_saved_attributes "" - - - set outputlines $underlines - set overidx 0 - - #underlines are not necessarily processed in order - depending on cursor-moves applied from overtext - set row 1 - if {$data_mode} { - set col [_get_row_append_column $row] - } else { - set col 1 - } - - set instruction_stats [dict create] - - set loop 0 - #while {$overidx < [llength $inputchunks]} { } - - while {[llength $inputchunks]} { - #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" - set overtext [lpop inputchunks 0] - if {![string length $overtext]} { - incr loop - continue - } - #puts "----->[ansistring VIEW -lf 1 -vt 1 -nul 1 $overtext]<----" - set undertext [lindex $outputlines [expr {$row -1}]] - set renderedrow $row - - #renderline pads each underaly line to width with spaces and should track where end of data is - - - #set overtext [string cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [string cat $replay_codes_overlay $overtext] - if {[dict exists $replay_codes_underlay $row]} { - set undertext [string cat [dict get $replay_codes_underlay $row] $undertext] - } - #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l - set LASTCALL [list -info 1 -insert_mode $insert_mode -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set rinfo [renderline -experimental $opt_experimental -info 1 -insert_mode $insert_mode -cursor_restore_attributes $cursor_saved_attributes -autowrap_mode $autowrap_mode -transparent $opt_transparent -width $colwidth -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -cursor_column $col -cursor_row $row $undertext $overtext] - set instruction [dict get $rinfo instruction] - set insert_mode [dict get $rinfo insert_mode] - set autowrap_mode [dict get $rinfo autowrap_mode] ;# - #set reverse_mode [dict get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set overflow_right_column [dict get $rinfo overflow_right_column] - set unapplied [dict get $rinfo unapplied] - set unapplied_list [dict get $rinfo unapplied_list] - set post_render_col [dict get $rinfo cursor_column] - set post_render_row [dict get $rinfo cursor_row] - set c_saved_pos [dict get $rinfo cursor_saved_position] - set c_saved_attributes [dict get $rinfo cursor_saved_attributes] - set visualwidth [dict get $rinfo visualwidth] - set insert_lines_above [dict get $rinfo insert_lines_above] - set insert_lines_below [dict get $rinfo insert_lines_below] - dict set replay_codes_underlay [expr {$renderedrow+1}] [dict get $rinfo replay_codes_underlay] - #lset replay_codes_overlay [expr $overidx+1] [dict get $rinfo replay_codes_overlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] - - - - #-- todo - detect looping properly - if {$row > 1 && $overtext ne "" && $unapplied eq $overtext && $post_render_row == $row && $instruction eq ""} { - puts stderr "overtype::left loop?" - puts [ansistring VIEW $rinfo] - break - } - #-- - - if {[dict size $c_saved_pos] >= 1} { - set cursor_saved_position $c_saved_pos - set cursor_saved_attributes $c_saved_attributes - } - - - set overflow_handled 0 - - - - set nextprefix "" - - - #todo - handle potential insertion mode as above for cursor restore? - #keeping separate branches for debugging - review and merge as appropriate when stable - dict incr instruction_stats $instruction - switch -- $instruction { - {} { - if {$test_mode == 0} { - incr row - if {$data_mode} { - set col [_get_row_append_column $row] - if {$col > $colwidth} { - - } - } else { - set col 1 - } - } else { - #lf included in data - set row $post_render_row - set col $post_render_col - - #set col 1 - #if {$post_render_row != $renderedrow} { - # set col 1 - #} else { - # set col $post_render_col - #} - } - } - up { - - #renderline knows it's own line number, and knows not to go above row l - #it knows that a move whilst 1-beyond the width conflicts with the linefeed and reduces the move by one accordingly. - #row returned should be correct. - #column may be the overflow column - as it likes to report that to the caller. - - #Note that an ansi up sequence after last column going up to a previous line and also beyond the last column, will result in the next grapheme going onto the following line. - #this seems correct - as the column remains beyond the right margin so subsequent chars wrap (?) review - #puts stderr "up $post_render_row" - #puts stderr "$rinfo" - - #puts stdout "1 row:$row col $col" - set row $post_render_row - #data_mode (naming?) determines if we move to end of existing data or not. - #data_mode 0 means ignore existing line length and go to exact column - #set by -experimental flag - if {$data_mode == 0} { - set col $post_render_col - } else { - #This doesn't really work if columns are pre-filled with spaces..we can't distinguish them from data - #we need renderline to return the number of the maximum column filled (or min if we ever do r-to-l) - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - - #puts stdout "2 row:$row col $col" - #puts stdout "-----------------------" - #puts stdout $rinfo - #flush stdout - } - down { - if {$data_mode == 0} { - #renderline doesn't know how far down we can go.. - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set row $post_render_row - set col $post_render_col - } else { - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - - } - } - restore_cursor { - #testfile belinda.ans uses this - - #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[dict exists $cursor_saved_position row]} { - set row [dict get $cursor_saved_position row] - set col [dict get $cursor_saved_position column] - #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" - #set nextprefix $cursor_saved_attributes - #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [dict get $rinfo replay_codes_overlay]$cursor_saved_attributes - #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [dict create] - set cursor_saved_attributes "" - } else { - #TODO - #?restore without save? - #should move to home position and reset ansi SGR? - #puts stderr "overtype::left cursor_restore without save data available" - } - #If we were inserting prior to hitting the cursor_restore - there could be overflow_right data - generally the overtype functions aren't for inserting - but ansi can enable it - #if we were already in overflow when cursor_restore was hit - it shouldn't have been processed as an action - just stored. - if {!$overflow_handled && $overflow_right ne ""} { - #wrap before restore? - possible effect on saved cursor position - #this overflow data has previously been rendered so has no cursor movements or further save/restore operations etc - #we can just insert another call to renderline to solve this.. ? - #It would perhaps be more properly handled as a queue of instructions from our initial renderline call - #we don't need to worry about overflow next call (?)- but we should carry forward our gx and ansi stacks - - puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - - set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [dict get $opts -overflow] "" $overflow_right] - set foldline [dict get $sub_info result] - set insert_mode [dict get $sub_info insert_mode] ;#probably not needed.. - set autowrap_mode [dict get $sub_info autowrap_mode] ;#nor this.. - linsert outputlines $renderedrow $foldline - #review - row & col set by restore - but not if there was no save.. - } - set overflow_handled 1 - - } - move { - ######## - if {$post_render_row > [llength $outputlines]} { - #Ansi moves need to create new lines ? - #if {$opt_appendlines} { - # set diff [expr {$post_render_row - [llength $outputlines]}] - # if {$diff > 0} { - # lappend outputlines {*}[lrepeat $diff ""] - # } - # set row $post_render_row - #} else { - set row [llength $outputlines] - #} - } else { - set row $post_render_row - } - ####### - set col $post_render_col - #overflow + unapplied? - } - lf_start { - #raw newlines - must be test_mode - # ---------------------- - #test with fruit.ans - #test - treating as newline below... - #append rendered $overflow_right - #set overflow_right "" - set row $renderedrow - incr row - if {$row > [llength $outputlines]} { - lappend outputlines "" - } - set col 1 - # ---------------------- - } - lf_mid { - - if 0 { - #set rhswidth [punk::ansi::printing_length $overflow_right] - #only show debug when we have overflow? - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - - set rhs "" - if {$overflow_right ne ""} { - set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $overflow_right]] - set rhs [textblock::frame -title overflow_right $rhs] - } - puts [textblock::join $lhs " $post_render_col " $rhs] - } - - if {!$test_mode} { - #rendered - append rendered $overflow_right - #set replay_codes_overlay "" - set overflow_right "" - - - set row $renderedrow - - set col 1 - incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - set edit_mode 0 - if {$edit_mode} { - set inputchunks [linsert $inputchunks 0 $overflow_right$unapplied] - set overflow_right "" - set unapplied "" - set row $post_render_row - #set col $post_render_col - set col 1 - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } else { - append rendered $overflow_right - set overflow_right "" - set row $post_render_row - set col 1 - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - } - } - } - lf_overflow { - #linefeed after colwidth e.g at column 81 for an 80 col width - #we may also have other control sequences that came after col 80 e.g cursor save - - if 0 { - set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -nul 1 -lf 1 -vt 1 $rendered]] - set lhs [textblock::frame -title "rendered $visualwidth cols" -subtitle "row-$renderedrow" $lhs] - set rhs "" - - #assertion - there should be no overflow.. - puts $lhs - } - assert {$overflow_right eq ""} lf_overflow should not get data in overflow_right - - set row $post_render_row - #set row $renderedrow - #incr row - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat 1 ""] - } - set col 1 - - } - newlines_above { - #we get a newlines_above instruction when received at column 1 - #In some cases we want to treat that as request to insert a new blank line above, and move our row 1 down (staying with the data) - #in other cases - we want to treat at column 1 the same as any other - - puts "--->newlines_above" - puts "rinfo: $rinfo" - #renderline doesn't advance the row for us - the caller has the choice to implement or not - set row $post_render_row - set col $post_render_col - if {$insert_lines_above > 0} { - set row $renderedrow - set outputlines [linsert $outputlines $renderedrow-1 {*}[lrepeat $insert_lines_above ""]] - incr row [expr {$insert_lines_above -1}] ;#we should end up on the same line of text (at a different index), with new empties inserted above - #? set row $post_render_row #can renderline tell us? - } - } - newlines_below { - #obsolete? - use for ANSI insert lines sequence - if {$data_mode == 0} { - puts --->nl_below - set row $post_render_row - set col $post_render_col - if {$insert_lines_below == 1} { - if {$test_mode == 0} { - set row $renderedrow - set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too - incr row $insert_lines_below - set col 1 - } else { - #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] - #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] - #set rhs "" - #if {$overflow_right ne ""} { - # set rhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $overflow_right]] - # set rhs [textblock::frame -title overflow_right $rhs] - #} - #puts [textblock::join $lhs $rhs] - - #rendered - append rendered $overflow_right - # - - - set overflow_right "" - set row $renderedrow - #only add newline if we're at the bottom - if {$row > [llength $outputlines]} { - lappend outputlines {*}[lrepeat $insert_lines_below ""] - } - incr row $insert_lines_below - set col 1 - - - - } - } - } else { - set row $post_render_row - if {$post_render_row > [llength $outputlines]} { - if {$opt_appendlines} { - set diff [expr {$post_render_row - [llength $outputlines]}] - if {$diff > 0} { - lappend outputlines {*}[lrepeat $diff ""] - } - lappend outputlines "" - } - } else { - set existingdata [lindex $outputlines [expr {$post_render_row -1}]] - set lastdatacol [punk::ansi::printing_length $existingdata] - if {$lastdatacol < $colwidth} { - set col [expr {$lastdatacol+1}] - } else { - set col $colwidth - } - } - } - } - wrapmoveforward { - #doesn't seem to be used by fruit.ans testfile - #used by dzds.ans - #note that cursor_forward may move deep into the next line - or even span multiple lines !TODO - set c $colwidth - set r $post_render_row - if {$post_render_col > $colwidth} { - set i $c - while {$i <= $post_render_col} { - if {$c == $colwidth+1} { - incr r - if {$opt_appendlines} { - if {$r < [llength $outputlines]} { - lappend outputlines "" - } - } - set c 1 - } else { - incr c - } - incr i - } - set col $c - } else { - #why are we getting this instruction then? - puts stderr "wrapmoveforward - test" - set r [expr {$post_render_row +1}] - set c $post_render_col - } - set row $r - set col $c - } - wrapmovebackward { - set c $colwidth - set r $post_render_row - if {$post_render_col < 1} { - set c 1 - set i $c - while {$i >= $post_render_col} { - if {$c == 0} { - if {$r > 1} { - incr r -1 - set c $colwidth - } else { - #leave r at 1 set c 1 - #testfile besthpav.ans first line top left border alignment - set c 1 - break - } - } else { - incr c -1 - } - incr i -1 - } - set col $c - } else { - puts stderr "Wrapmovebackward - but postrendercol >= 1???" - } - set row $r - set col $c - } - overflow { - #normal single-width grapheme overflow - #puts "----normal overflow --- [ansistring VIEWSTYLE -lf 1 -nul 1 -vt 1 $rendered]" - set row $post_render_row ;#renderline will not advance row when reporting overflow char - if {$autowrap_mode} { - incr row - set col 1 ;#whether wrap or not - next data is at column 1 ?? - } else { - #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. - set col $post_render_col - #set unapplied "" ;#this seems wrong? - #set unapplied [string range $unapplied 1 end] - #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs - #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate - #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' - set idx 0 - set next_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set next_grapheme_index $idx - break - } - incr idx - } - assert {$next_grapheme_index >= 0} - #drop the overflow grapheme - keeping all codes in place. - set unapplied [join [lreplace $unapplied_list $next_grapheme_index $next_grapheme_index] ""] - #we need to run the reduced unapplied on the same line - further graphemes will just overflow again, but codes or control chars could trigger jumps to other lines - - set overflow_handled 1 - #handled by dropping overflow if any - } - } - overflow_splitchar { - set row $post_render_row ;#renderline will not advance row when reporting overflow char - - #2nd half of grapheme would overflow - treggering grapheme is returned in unapplied. There may also be overflow_right from earlier inserts - #todo - consider various options .. re-render a single trailing space or placeholder on same output line, etc - if {$autowrap_mode} { - if {$colwidth < 2} { - #edge case of rendering to a single column output - any 2w char will just cause a loop if we don't substitute with something, or drop the character - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } else { - set col 1 - incr row - } - } else { - set overflow_handled 1 - #handled by dropping entire overflow if any - if {$colwidth < 2} { - set idx 0 - set triggering_grapheme_index -1 - foreach u $unapplied_list { - if {![punk::ansi::ta::detect $u]} { - set triggering_grapheme_index $idx - break - } - incr idx - } - set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] - } - } - - } - vt { - - #can vt add a line like a linefeed can? - set row $post_render_row - set col $post_render_col - } - default { - puts stderr "overtype::left unhandled renderline instruction '$instruction'" - } - - } - - - if {!$opt_overflow && !$autowrap_mode} { - #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[dict get $opts -ellipsis]} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[string trim $lostdata] eq ""} { - set show_ellipsis 0 - } - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - if {[string trim [ansistrip $lostdata]] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - set overflow_handled 1 - } else { - #no wrap - no ellipsis - silently truncate - set overflow_handled 1 - } - } - - - - if {$renderedrow <= [llength $outputlines]} { - lset outputlines [expr {$renderedrow-1}] $rendered - } else { - if {$opt_appendlines} { - lappend outputlines $rendered - } else { - #? - lset outputlines [expr {$renderedrow-1}] $rendered - } - } - - if {!$overflow_handled} { - append nextprefix $overflow_right - } - - append nextprefix $unapplied - - if 0 { - if {$nextprefix ne ""} { - set nextoveridx [expr {$overidx+1}] - if {$nextoveridx >= [llength $inputchunks]} { - lappend inputchunks $nextprefix - } else { - #lset overlines $nextoveridx $nextprefix[lindex $overlines $nextoveridx] - set inputchunks [linsert $inputchunks $nextoveridx $nextprefix] - } - } - } - - if {$nextprefix ne ""} { - set inputchunks [linsert $inputchunks 0 $nextprefix] - } - - - incr overidx - incr loop - if {$loop >= $looplimit} { - puts stderr "overtype::left looplimit reached ($looplimit)" - lappend outputlines "[a+ red bold] - looplimit $looplimit reached[a]" - set Y [a+ yellow bold] - set RST [a] - set sep_header ----DEBUG----- - set debugmsg "" - append debugmsg "${Y}${sep_header}${RST}" \n - append debugmsg "looplimit $looplimit reached\n" - append debugmsg "test_mode:$test_mode\n" - append debugmsg "data_mode:$data_mode\n" - append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[dict get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[dict get $LASTCALL -cursor_column]\n" - dict for {k v} $rinfo { - append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n - } - append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n - - puts stdout $debugmsg - #todo - config regarding error dumps rather than just dumping in working dir - set fd [open [pwd]/error_overtype.txt w] - puts $fd $debugmsg - close $fd - error $debugmsg - break - } - } - - set result [join $outputlines \n] - if {$info_mode} { - #emit to debug window like basictelnet does? make debug configurable as syslog or even a telnet server to allow on 2nd window? - #append result \n$instruction_stats\n - } - return $result - } - - #todo - left-right ellipsis ? - proc centre {args} { - variable default_ellipsis_horizontal - if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-bias [left|right]? ?-overflow [1|0]? undertext overtext} - } - - foreach {underblock overblock} [lrange $args end-1 end] break - - #todo - vertical vs horizontal overflow for blocks - set defaults [dict create\ - -bias left\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - ] - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 {} - default { - set known_opts [dict keys $defaults] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - # -- --- --- --- --- --- - - - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {$colwidth - $overblock_width}] - if {$under_exposed_max > 0} { - #background block is wider - if {$under_exposed_max % 2 == 0} { - #even left/right exposure - set left_exposed [expr {$under_exposed_max / 2}] - } else { - set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[string tolower [dict get $opts -bias]] eq "left"} { - set left_exposed $beforehalf - } else { - #bias to the right - set left_exposed [expr {$beforehalf + 1}] - } - } - } else { - set left_exposed 0 - } - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - set undertext "$undertext[string repeat { } $udiff]" - } - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - #review - right-to-left langs should elide on left! - extra option required - - if {$overflowlength > 0} { - #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [dict get $rinfo unapplied] - #todo - get replay_codes from overflow_right instead of wherever it was truncated? - - #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![dict get $opts -overflow]} { - #lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] - #set overtext [string range $overtext 0 $colwidth-1 ] - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - #don't use string range on ANSI data - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - set lostdata "" - if {$overflow_right ne ""} { - append lostdata $overflow_right - } - if {$unapplied ne ""} { - append lostdata $unapplied - } - if {[string trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set rendered [overtype::right $rendered $opt_ellipsistext] - } - } - } - lappend outputlines $rendered - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent $undertext $overtext] - } else { - #background block is wider than or equal to data for this line - #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [dict get $rinfo result] - } - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] - } - return [join $outputlines \n] - } - - proc right {args} { - #NOT the same as align-right - which should be done to the overblock first if required - variable default_ellipsis_horizontal - # @d !todo - implement overflow, length checks etc - - if {[llength $args] < 2} { - error {usage: ?-overflow [1|0]? ?-transparent 0|? undertext overtext} - } - foreach {underblock overblock} [lrange $args end-1 end] break - - set defaults [dict create\ - -bias ignored\ - -ellipsis 0\ - -ellipsistext $default_ellipsis_horizontal\ - -ellipsiswhitespace 0\ - -overflow 0\ - -transparent 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -align "left"\ - ] - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align {} - default { - set known_opts [dict keys $defaults] - error "overtype::centre unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_overflow [dict get $opts -overflow] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - set opt_align [dict get $opts -align] - # -- --- --- --- --- --- - - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] - - set underlines [split $underblock \n] - #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] - lassign [blocksize $underblock] _w colwidth _h colheight - set overlines [split $overblock \n] - #set overblock_width [tcl::mathfunc::max {*}[lmap v $overlines {punk::ansi::printing_length $v}]] - lassign [blocksize $overblock] _w overblock_width _h overblock_height - set under_exposed_max [expr {max(0,$colwidth - $overblock_width)}] - set left_exposed $under_exposed_max - - - - set outputlines [list] - if {[punk::ansi::ta::detect_sgr [lindex $overlines 0]]} { - set replay_codes "[punk::ansi::a]" - } else { - set replay_codes "" - } - set replay_codes_underlay "" - set replay_codes_overlay "" - foreach undertext $underlines overtext $overlines { - set overtext_datalen [punk::ansi::printing_length $overtext] - set ulen [punk::ansi::printing_length $undertext] - if {$ulen < $colwidth} { - set udiff [expr {$colwidth - $ulen}] - #puts xxx - append undertext [string repeat { } $udiff] - } - if {$overtext_datalen < $overblock_width} { - set odiff [expr {$overblock_width - $overtext_datalen}] - switch -- $opt_align { - left { - set startoffset 0 - } - right { - set startoffset $odiff - } - default { - set half [expr {$odiff / 2}] - #set lhs [string repeat { } $half] - #set righthalf [expr {$odiff - $half}] ;#remainder - may be one more - so we are biased left - #set rhs [string repeat { } $righthalf] - set startoffset $half - } - } - } else { - set startoffset 0 ;#negative? - } - - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] - - set overflowlength [expr {$overtext_datalen - $colwidth}] - if {$overflowlength > 0} { - #raw overtext wider than undertext column - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [dict get $rinfo replay_codes] - set rendered [dict get $rinfo result] - if {!$opt_overflow} { - if {$opt_ellipsis} { - set show_ellipsis 1 - if {!$opt_ellipsiswhitespace} { - #we don't want ellipsis if only whitespace was lost - set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - if {[string trim $lostdata] eq ""} { - set show_ellipsis 0 - } - } - if {$show_ellipsis} { - set ellipsis [string cat $replay_codes $opt_ellipsistext] - #todo - overflow on left if allign = right?? - set rendered [overtype::right $rendered $ellipsis] - } - } - } - lappend outputlines $rendered - } else { - #padded overtext - #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] - #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [dict get $rinfo result] - } - set replay_codes [dict get $rinfo replay_codes] - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] - } - - return [join $outputlines \n] - } - - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # renderline written from a left-right line orientation perspective as a first-shot at getting something useful. - # ultimately right-to-left, top-to-bottom and bottom-to-top are probably needed. - # ## ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### ### - # - # - #-returnextra enables returning of overflow and length - #review - use punk::ansi::ta::detect to short-circuit processing and do simpler string calcs as an optimisation? - #review - DECSWL/DECDWL double width line codes - very difficult/impossible to align and compose with other elements - #(could render it by faking it with sixels and a lot of work - find/make a sixel font and ensure it's exactly 2 cols per char) - #todo - review transparency issues with single/double width characters - #bidi - need a base direction and concept of directional runs for RTL vs LTR - may be best handled at another layer? - proc renderline {args} { - #*** !doctools - #[call [fun overtype::renderline] [arg args] ] - #[para] renderline is the core engine for overtype string processing (frames & textblocks), and the raw mode commandline repl for the Tcl Punk Shell - #[para] It is also a central part of an ansi (micro) virtual terminal-emulator of sorts - #[para] This system does a half decent job at rendering 90's ANSI art to manipulable colour text blocks that can be joined & framed for layout display within a unix or windows terminal - #[para] Renderline helps maintain ANSI text styling reset/replay codes so that the styling of one block doesn't affect another. - #[para] Calling on the punk::ansi library - it can coalesce codes to keep the size down. - #[para] It is a giant mess of doing exactly what common wisdom says not to do... lots at once. - #[para] renderline is part of the Unicode and ANSI aware Overtype system which 'renders' a block of text onto a static underlay - #[para] The underlay is generally expected to be an ordered set of lines or a rectangular text block analogous to a terminal screen - but it can also be ragged in line length, or just blank. - #[para] The overlay couuld be similar - in which case it may often be used to overwrite a column or section of the underlay. - #[para] The overlay could however be a sequence of ANSI-laden text that jumps all over the place. - # - #[para] renderline itself only deals with a single line - or sometimes a single character. It is generally called from a loop that does further terminal-like or textblock processing. - #[para] By suppyling the -info 1 option - it can return various fields indicating the state of the render. - #[para] The main 3 are the result, overflow_right, and unapplied. - #[para] Renderline handles cursor movements from either keystrokes or ANSI sequences but for a full system the aforementioned loop will need to be in place to manage the set of lines under manipulation. - - if {[llength $args] < 2} { - error {usage: ?-info 0|1? ?-startcolumn ? ?-cursor_column ? ?-cursor_row |""? ?-transparent [0|1|]? ?-overflow [1|0]? undertext overtext} - } - lassign [lrange $args end-1 end] under over - if {[string first \n $under] >= 0} { - error "overtype::renderline not allowed to contain newlines in undertext" - } - #if {[string first \n $over] >=0 || [string first \n $under] >= 0} { - # error "overtype::renderline not allowed to contain newlines" - #} - - set defaults [dict create\ - -etabs 0\ - -width \uFFEF\ - -overflow 0\ - -transparent 0\ - -startcolumn 1\ - -cursor_column 1\ - -cursor_row ""\ - -insert_mode 1\ - -autowrap_mode 1\ - -reverse_mode 0\ - -info 0\ - -exposed1 \uFFFD\ - -exposed2 \uFFFD\ - -cursor_restore_attributes ""\ - -experimental {}\ - ] - #-cursor_restore_attributes only - for replay stack - position and actual setting/restoring handled by throwback to caller - - #cursor_row, when numeric will allow detection of certain row moves that are still within our row - allowing us to avoid an early return - #An empty string for cursor_row tells us we have no info about our own row context, and to return with an unapplied string if any row move occurs - - #exposed1 and exposed2 for first and second col of underying 2wide char which is truncated by transparency or overflow - #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error - - set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { - switch -- $k { - -experimental - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes {} - default { - set known_opts [dict keys $defaults] - error "overtype::renderline unknown option '$k'. Known options: $known_opts" - } - } - } - set opts [dict merge $defaults $argsflags] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [dict get $opts -width] - set opt_etabs [dict get $opts -etabs] - set opt_overflow [dict get $opts -overflow] - set opt_colstart [dict get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [dict get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [dict get $opts -cursor_row] - if {[string length $opt_row_context]} { - if {![string is integer -strict $opt_row_context] || $opt_row_context <1 } { - error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [dict get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) - #default is for overtype - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [dict get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [dict get $opts -reverse_mode] ;#DECSNM - # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [dict get $opts -cursor_restore_attributes] - - set test_mode 0 - set cp437_glyphs 0 - foreach e [dict get $opts -experimental] { - switch -- $e { - test_mode { - set test_mode 1 - set cp437_glyphs 1 - } - } - } - set cp437_map [dict create] - if {$cp437_glyphs} { - set cp437_map [set ::punk::ansi::cp437_map] - #for cp437 images we need to map these *after* splitting ansi - #some old files might use newline for its glyph.. but we can't easily support that. - #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - dict unset cp437_map \n - } - - set opt_transparent [dict get $opts -transparent] - if {$opt_transparent eq "0"} { - set do_transparency 0 - } else { - set do_transparency 1 - if {$opt_transparent eq "1"} { - set opt_transparent {[\s]} - } - } - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [dict get $opts -info] - # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - # -- --- --- --- --- --- --- --- --- --- --- --- - - if {$opt_row_context eq ""} { - set cursor_row 1 - } else { - set cursor_row $opt_row_context - } - - - #----- - # - if {[info exists punk::console::tabwidth]} { - #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted - #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - - set overdata $over - if {!$cp437_glyphs} { - #REVIEW! tabify will give different answers for an ANSI colourised string vs plain text - if {!$opt_etabs} { - if {[string first \t $under] >= 0} { - #set under [textutil::tabify::untabify2 $under] - set under [textutil::tabify::untabifyLine $under $tw] - } - if {[string first \t $over] >= 0} { - #set overdata [textutil::tabify::untabify2 $over] - set overdata [textutil::tabify::untabifyLine $over $tw] - } - } - } - #------- - - #ta_detect ansi and do simpler processing? - - #we repeat tests for grapheme width in different loops - rather than create another datastructure to store widths based on column, - #we'll use the grapheme_width_cached function as a lookup table of all graphemes encountered - as there will often be repeats in different positions anyway. - - # -- --- --- --- --- --- --- --- - if {$under ne ""} { - set undermap [punk::ansi::ta::split_codes_single $under] - } else { - set undermap [list] - } - set understacks [list] - set understacks_gx [list] - - set i_u -1 ;#underlay may legitimately be empty - set undercols [list] - set u_codestack [list] - #u_gx_stack probably isn't really a stack - I don't know if g0 g1 can stack or not - for now we support only g0 anyway - set u_gx_stack [list] ;#separate stack for g0 (g1 g2 g3?) graphics on and off (DEC special graphics) - #set pt_underchars "" ;#for string_columns length calculation for overflow 0 truncation - set remainder [list] ;#for returnextra - foreach {pt code} $undermap { - #pt = plain text - #append pt_underchars $pt - if {$cp437_glyphs} { - set pt [string map $cp437_map $pt] - } - foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. - #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. - switch -- $grapheme { - " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - - z - A - B - C - D - E - F - G - H - I - J - K - L - M - N - O - P - Q - R - S - T - U - V - W - X - Y - Z - 0 - 1 - 2 - 3 - 4 - 5 - 6 - 7 - 8 - 9 { - set width 1 - } - default { - if {$grapheme eq "\u0000"} { - #use null as empty cell representation - review - #use of this will probably collide with some application at some point - #consider an option to set the empty cell character - set width 1 - } else { - set width [grapheme_width_cached $grapheme] - #we still want most controls and other zero-length codepoints such as \u200d (zero width joiner) to stay zero-length - #we substitute lone ESC that weren't captured within ANSI context as a debugging aid to see malformed ANSI - #todo - default to off and add a flag (?) to enable this substitution - set sub_stray_escapes 0 - if {$sub_stray_escapes && $width == 0} { - if {$grapheme eq "\x1b"} { - set gvis [ansistring VIEW $grapheme] - set grapheme $gvis - set width 1 - } - } - } - } - } - #set width [grapheme_width_cached $grapheme] - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - - lappend undercols $grapheme - if {$width > 1} { - #presumably there are no triple-column or wider unicode chars.. until the aliens arrive.(?) - #but what about emoji combinations etc - can they be wider than 2? - #todo - if -etabs enabled - then we treat \t as the width determined by our elastic tabstop - incr i_u - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - lappend undercols "" - } - } - - #underlay should already have been rendered and not have non-sgr codes - but let's retain the check for them and not stack them if other codes are here - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - if {$code ne ""} { - set c1c2 [string range $code 0 1] - set leadernorm [string range [string map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - switch -- $leadernorm { - 7CSI - 8CSI { - #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse - #REVIEW - what else could end in m but be mistaken as a normal SGR code here? - set maybemouse "" - if {[string index $c1c2 0] eq "\x1b"} { - set maybemouse [string index $code 2] - } - - if {$maybemouse ne "<" && [string index $code end] eq "m"} { - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set u_codestack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set u_codestack [list $code] - } else { - #basic simplification first.. straight dups - set dup_posns [lsearch -all -exact $u_codestack $code] ;#-exact because of square-bracket glob chars - set u_codestack [lremove $u_codestack {*}$dup_posns] - lappend u_codestack $code - } - } - } - 7GFX { - switch -- [string index $code 2] { - "0" { - set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess - } - B { - set u_gx_stack [list] - } - } - } - default { - - } - - } - - #if {[punk::ansi::codetype::is_sgr_reset $code]} { - # #set u_codestack [list] - #} elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - #} elseif {[punk::ansi::codetype::is_sgr $code]} { - #} else { - # #leave SGR stack as is - # if {[punk::ansi::codetype::is_gx_open $code]} { - # } elseif {[punk::ansi::codetype::is_gx_close $code]} { - # } - #} - } - #consider also if there are other codes that should be stacked..? - } - - if {!$test_mode} { - #fill columns to width with spaces, and carry over stacks - we will have to keep track of where the underlying data ends manually - TODO - #Specifying a width is suitable for terminal-like applications and text-blocks - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff " "] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - } else { - #NULL empty cell indicator - if {$opt_width ne "\uFFEF"} { - if {[llength $understacks]} { - set cs $u_codestack - set gs $u_gx_stack - } else { - set cs [list] - set gs [list] - } - if {[llength $undercols]< $opt_width} { - set diff [expr {$opt_width- [llength $undercols]}] - if {$diff > 0} { - lappend undercols {*}[lrepeat $diff "\u0000"] - lappend understacks {*}[lrepeat $diff $cs] - lappend understacks_gx {*}[lrepeat $diff $gs] - } - } - } - - } - if {$opt_width ne "\uFFEF"} { - set colwidth $opt_width - } else { - set colwidth [llength $undercols] - } - - - if 0 { - # ----------------- - # if we aren't extending understacks & understacks_gx each time we incr idx above the undercols length.. this doesn't really serve a purpose - # Review. - # ----------------- - #replay code for last overlay position in input line - # whether or not we get that far - we need to return it for possible replay on next line - if {[llength $understacks]} { - lappend understacks $u_codestack - lappend understacks_gx $u_gx_stack - } else { - #in case overlay onto emptystring as underlay - lappend understacks [list] - lappend understacks_gx [list] - } - # ----------------- - } - - #trailing codes in effect for underlay - if {[llength $u_codestack]} { - #set replay_codes_underlay [join $u_codestack ""] - set replay_codes_underlay [punk::ansi::codetype::sgr_merge_list {*}$u_codestack] - } else { - set replay_codes_underlay "" - } - - - # -- --- --- --- --- --- --- --- - #### - #if opt_colstart - we need to build a space (or any singlewidth char ?) padding on the left of the right number of columns. - #this will be processed as transparent - and handle doublewidth underlay characters appropriately - set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] - append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] - #### - - #??? - set colcursor $opt_colstart - #TODO - make a little virtual column object - #we need to refer to column1 or columnmin? or columnmax without calculating offsets due to to startcolumn - #need to lock-down what start column means from perspective of ANSI codes moving around - the offset perspective is unclear and a mess. - - - #set re_diacritics {[\u0300-\u036f]+|[\u1ab0-\u1aff]+|[\u1dc0-\u1dff]+|[\u20d0-\u20ff]+|[\ufe20-\ufe2f]+} - #as at 2024-02 punk::char::grapheme_split uses these - not aware of more complex graphemes - - set overstacks [list] - set overstacks_gx [list] - - set o_codestack [list]; #SGR codestack (not other codes such as movement,insert key etc) - set o_gxstack [list] - set pt_overchars "" - set i_o 0 - set overlay_grapheme_control_list [list] ;#tag each with g, sgr or other. 'other' are things like cursor-movement or insert-mode or codes we don't recognise/use - #experiment - set overlay_grapheme_control_stacks [list] - foreach {pt code} $overmap { - if {$cp437_glyphs} { - set pt [string map $cp437_map $pt] - } - append pt_overchars $pt - #will get empty pt between adjacent codes - foreach grapheme [punk::char::grapheme_split $pt] { - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - incr i_o - lappend overlay_grapheme_control_list [list g $grapheme] - lappend overlay_grapheme_control_stacks $o_codestack - } - - #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc - #order of if-else based on assumptions: - # that pure resets are fairly common - more so than leading resets with other info - # that non-sgr codes are not that common, so ok to check for resets before verifying it is actually SGR at all. - if {$code ne ""} { - lappend overlay_grapheme_control_stacks $o_codestack - #there will always be an empty code at end due to foreach on 2 vars with odd-sized list ending with pt (overmap coming from perlish split) - if {[punk::ansi::codetype::is_sgr_reset $code]} { - set o_codestack [list "\x1b\[m"] ;#reset better than empty list - fixes some ansi art issues - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set o_codestack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #basic simplification first - remove straight dupes - set dup_posns [lsearch -all -exact $o_codestack $code] ;#must be -exact because of square-bracket glob chars - set o_codestack [lremove $o_codestack {*}$dup_posns] - lappend o_codestack $code - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[regexp {\x1b7|\x1b\[s} $code]} { - #experiment - #cursor_save - for the replays review. - #jmn - #set temp_cursor_saved [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - lappend overlay_grapheme_control_list [list other $code] - } elseif {[regexp {\x1b8|\x1b\[u} $code]} { - #experiment - #cursor_restore - for the replays - set o_codestack [list $temp_cursor_saved] - lappend overlay_grapheme_control_list [list other $code] - } else { - if {[punk::ansi::codetype::is_gx_open $code]} { - set o_gxstack [list "gx0_on"] - lappend overlay_grapheme_control_list [list gx0 gx0_on] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } elseif {[punk::ansi::codetype::is_gx_close $code]} { - set o_gxstack [list] - lappend overlay_grapheme_control_list [list gx0 gx0_off] ;#don't store code - will complicate debugging if we spit it out and jump character sets - } else { - lappend overlay_grapheme_control_list [list other $code] - } - } - } - - } - #replay code for last overlay position in input line - should take account of possible trailing sgr code after last grapheme - set max_overlay_grapheme_index [expr {$i_o -1}] - lappend overstacks $o_codestack - lappend overstacks_gx $o_gxstack - - #set replay_codes_overlay [join $o_codestack ""] - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - - #if {[dict exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [dict get $overstacks $max_overlay_grapheme_index] ""] - #} else { - # set replay_codes_overlay "" - #} - # -- --- --- --- --- --- --- --- - - - #potential problem - combinining diacritics directly following control chars like \r \b - - # -- --- --- - #we need to initialise overflow_idx before any potential row-movements - as they need to perform a loop break and force in_excess to 1 - if {$opt_overflow} { - #somewhat counterintuitively - overflow true means we can have lines as long as we want, but either way there can be excess data that needs to be thrown back to the calling loop. - set overflow_idx -1 - } else { - #overflow zero - we can't grow beyond our column width - so we get ellipsis or truncation - if {$opt_width ne "\uFFEF"} { - set overflow_idx [expr {$opt_width}] - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - } - # -- --- --- - - set outcols $undercols ;#leave undercols as is, outcols can potentially be appended to. - - set unapplied "" ;#if we break for move row (but not for /v ?) - set unapplied_list [list] - - set insert_lines_above 0 ;#return key - set insert_lines_below 0 - set instruction "" - - # -- --- --- - #cursor_save_dec, cursor_restore_dec etc - set cursor_restore_required 0 - set cursor_saved_attributes "" - set cursor_saved_position "" - # -- --- --- - - #set idx 0 ;# line index (cursor - 1) - #set idx [expr {$opt_colstart + $opt_colcursor} -1] - - #idx is the per column output index - set idx [expr {$opt_colcursor -1}] ;#don't use opt_colstart here - we have padded and won't start emitting until idx reaches opt_colstart-1 - #cursor_column is usually one above idx - but we have opt_colstart which is like a margin - todo: remove cursor_column from the following loop and calculate it's offset when breaking or at end. - #(for now we are incrementing/decrementing both in sync - which is a bit silly) - set cursor_column $opt_colcursor - - #idx_over is the per grapheme overlay index - set idx_over -1 - - - #movements only occur within the overlay range. - #an underlay is however not necessary.. e.g - #renderline -overflow 1 "" data - #foreach {pt code} $overmap {} - set insert_mode $opt_insert_mode ;#default 1 - set autowrap_mode $opt_autowrap_mode ;#default 1 - - - #puts "-->$overlay_grapheme_control_list<--" - #puts "-->overflow_idx: $overflow_idx" - for {set gci 0} {$gci < [llength $overlay_grapheme_control_list]} {incr gci} { - set gc [lindex $overlay_grapheme_control_list $gci] - lassign $gc type item - - #emit plaintext chars first using existing SGR codes from under/over stack as appropriate - #then check if the following code is a cursor movement within the line and adjust index if so - #foreach ch $overlay_graphemes {} - switch -- $type { - g { - set ch $item - incr idx_over; #idx_over (until unapplied reached anyway) is per *grapheme* in the overlay - not per col. - if {($idx < ($opt_colstart -1))} { - incr idx [grapheme_width_cached $ch] - continue - } - #set within_undercols [expr {$idx <= [llength $undercols]-1}] ;#within our active data width - set within_undercols [expr {$idx <= $colwidth-1}] - - #https://www.enigma.com/resources/blog/the-secret-world-of-newline-characters - #\x85 NEL in the c1 control set is treated by some terminal emulators (e.g Hyper) as a newline, - #on some it's invisble but doesn't change the line, on some it's a visible glyph of width 1. - #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable - #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - - set chtest [string map [list \n \x85 \b \r \v \x7f ] $ch] - #puts --->chtest:$chtest - #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached - switch -- $chtest { - "" { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - if {$idx == 0} { - #puts "---a at col 1" - #linefeed at column 1 - #leave the overflow_idx ;#? review - set instruction lf_start ;#specific instruction for newline at column 1 - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } elseif {$overflow_idx != -1 && $idx == $overflow_idx} { - #linefeed after final column - #puts "---c at overflow_idx=$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_overflow ;#only special treatment is to give it it's own instruction in case caller needs to handle differently - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } else { - #linefeed occurred in middle or at end of text - #puts "---mid-or-end-text-linefeed idx:$idx overflow_idx:$overflow_idx" - incr cursor_row - set overflow_idx $idx ;#override overflow_idx even if it was set to -1 due to opt_overflow = 1|2 - set instruction lf_mid - priv::render_unapplied $overlay_grapheme_control_list $gci - break - } - - } - "" { - #will we want/need to use raw for keypresses in terminal? (terminal with LNM in standard reset mode means enter= this is the usual config for terminals) - #So far we are assuming the caller has translated to and handle above.. REVIEW. - - #consider also the old space-carriagereturn softwrap convention used in some terminals. - #In the context of rendering to a block of text - this works similarly in that the space gets eaten so programs emitting space-cr at the terminal width col will pretty much get what they expect. - set idx [expr {$opt_colstart -1}] - set cursor_column $opt_colstart ;#? - } - "" { - #literal backspace char - not necessarily from keyboard - #review - backspace effect on double-width chars - we are taking a column-editing perspective in overtype - #(important for -transparent option - hence replacement chars for half-exposed etc) - #review - overstrike support as per nroff/less (generally considered an old technology replaced by unicode mechanisms and/or ansi SGR) - if {$idx > ($opt_colstart -1)} { - incr idx -1 - incr cursor_column -1 - } else { - set flag 0 - if $flag { - #review - conflicting requirements? Need a different sequence for destructive interactive backspace? - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction backspace_at_start - break - } - } - } - "" { - #literal del character - some terminals send just this for what is generally expected to be a destructive backspace - #We instead treat this as a pure delete at current cursor position - it is up to the repl or terminal to remap backspace key to a sequence that has the desired effect. - priv::render_delchar $idx - } - "" { - #end processing this overline. rest of line is remainder. cursor for column as is. - #REVIEW - this theoretically depends on terminal's vertical tabulation setting (name?) - #e.g it could be configured to jump down 6 rows. - #On the other hand I've seen indications that some modern terminal emulators treat it pretty much as a linefeed. - #todo? - incr cursor_row - set overflow_idx $idx - #idx_over has already been incremented as this is both a movement-control and in some sense a grapheme - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction vt - break - } - default { - if {$overflow_idx != -1} { - #review - how to check arbitrary length item such as tab is going to overflow .. before we get to overflow_idx? - #call grapheme_width_cached on each ch, or look for tab specifically as it's currently the only known reason to have a grapheme width > 2? - #we need to decide what a tab spanning the overflow_idx means and how it affects wrap etc etc - if {$idx == $overflow_idx-1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 2} { - #review split 2w overflow? - #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line - #better to consider the overlay char as unable to be applied to the line - #render empty string to column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied - #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #change the overflow_idx - set overflow_idx $idx - incr idx - incr idx_over -1 ;#set overlay grapheme index back one so that sgr stack from previous overlay grapheme used - priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#note $gci-1 instead of just gci - #throw back to caller's loop - add instruction to caller as this is not the usual case - #caller may for example choose to render a single replacement char to this line and omit the grapheme, or wrap it to the next line - set instruction overflow_splitchar - break - } elseif {$owidth > 2} { - #? tab? - #TODO! - puts stderr "overtype::renderline long overtext grapheme '[ansistring VIEW -lf 1 -vt 1 $ch]' not handled" - #tab of some length dependent on tabstops/elastic tabstop settings? - } - } elseif {$idx >= $overflow_idx} { - #jmn? - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci-1]] - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #don't incr idx beyond the overflow_idx - #idx_over already incremented - decrement so current overlay grapheme stacks go to unapplied - incr idx_over -1 - #priv::render_unapplied $overlay_grapheme_control_list [expr {$gci-1}] ;#back one index here too - priv::render_this_unapplied $overlay_grapheme_control_list $gci ;# - set instruction overflow - break - } - } else { - #review. - #This corresponds to opt_overflow being true (at least until overflow_idx is in some cases forced to a value when throwing back to calling loop) - } - - if {($do_transparency && [regexp $opt_transparent $ch])} { - #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) - if {$idx > [llength $outcols]-1} { - lappend outcols " " - #dict set understacks $idx [list] ;#review - use idx-1 codestack? - lset understacks $idx [list] - incr idx - incr cursor_column - } else { - #todo - punk::char::char_width - set g [lindex $outcols $idx] - set uwidth [grapheme_width_cached $g] - if {[lindex $outcols $idx] eq ""} { - #2nd col of 2-wide char in underlay - incr idx - incr cursor_column - } elseif {$uwidth == 0} { - #e.g control char ? combining diacritic ? - incr idx - incr cursor_column - } elseif {$uwidth == 1} { - set owidth [grapheme_width_cached $ch] - incr idx - incr cursor_column - if {$owidth > 1} { - incr idx - incr cursor_column - } - } elseif {$uwidth > 1} { - if {[grapheme_width_cached $ch] == 1} { - if {!$insert_mode} { - #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay - if {$next_pt_overchar eq ""} { - #special-case trailing transparent - no next_pt_overchar - incr idx - incr cursor_column - } else { - if {[regexp $opt_transparent $next_pt_overchar]} { - incr idx - incr cursor_column - } else { - #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode - priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } - } else { - #? todo - decide what transparency even means for insert mode - incr idx - incr cursor_column - } - } else { - #2wide transparency over 2wide in underlay - review - incr idx - incr cursor_column - } - } - } - } else { - - set idxchar [lindex $outcols $idx] - #non-transparent char in overlay or empty cell - if {$idxchar eq "\u0000"} { - #empty/erased cell indicator - set uwidth 1 - } else { - set uwidth [grapheme_width_cached $idxchar] - } - if {$within_undercols} { - if {$idxchar eq ""} { - #2nd col of 2wide char in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 - #JMN - this has to expose if our startposn chopped an underlay - but not if we already overwrote the first half of the widechar underlay grapheme - #e.g renderline \uFF21\uFF21--- a\uFF23\uFF23 - #vs - # renderline -startcolumn 2 \uFF21---- \uFF23 - if {[lindex $outcols $idx-1] != ""} { - #verified it's an empty following a filled - so it's a legit underlay remnant (REVIEW - when would it not be??) - #reset previous to an exposed 1st-half - but leave understacks code as is - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 - } - incr idx - } else { - set prevcolinfo [lindex $outcols $idx-1] - #for insert mode - first replace the empty 2ndhalf char with exposed2 before shifting it right - #REVIEW - this leaves a replacement character permanently in our columns.. but it is consistent regarding length (?) - #The alternative is to disallow insertion at a column cursor that is at 2nd half of 2wide char - #perhaps by inserting after the char - this may be worthwhile - but may cause other surprises - #It is perhaps best avoided at another level and try to make renderline do exactly as it's told - #the advantage of this 2w splitting method is that the inserted character ends up in exactly the column we expect. - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 0 ;#replace not insert - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] 1 ;#insert - same index - if {$prevcolinfo ne ""} { - #we've split the 2wide - it may already have been rendered as an exposed1 - but not for example if our startcolumn was current idx - priv::render_addchar [expr {$idx-1}] $opt_exposed1 [lindex $understacks $idx-1] [lindex $understacks_gx $idx-1] 0 ;#replace not insert - } ;# else?? - incr idx - } - if {$cursor_column < [llength $outcols] || $overflow_idx == -1} { - incr cursor_column - } - } elseif {$uwidth == 0} { - #what if this is some other c0/c1 control we haven't handled specifically? - - #by emitting a preceding empty-string column - we associate whatever this char is with the preceeding non-zero-length character and any existing zero-lengths that follow it - #e.g combining diacritic - increment before over char REVIEW - #arguably the previous overchar should have done this - ie lookahead for combiners? - #if we can get a proper grapheme_split function - this should be easier to tidy up. - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column 2 - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } elseif {$uwidth == 1} { - #includes null empty cells - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #if next column in underlay empty - we've overwritten first half of underlying 2wide grapheme - #replace with rhs exposure in case there are no more overlay graphemes coming - use underlay's stack - if {([llength $outcols] >= $idx +2) && [lindex $outcols $idx+1] eq ""} { - priv::render_addchar [expr {$idx+1}] $opt_exposed2 [lindex $understacks $idx+1] [lindex $understacks_gx $idx+1] $insert_mode - } - incr idx - } - if {($cursor_column < [llength $outcols]) || $overflow_idx == -1 || $test_mode} { - incr cursor_column - } - } elseif {$uwidth > 1} { - set owidth [grapheme_width_cached $ch] - if {$owidth == 1} { - #1wide over 2wide in underlay - if {!$insert_mode} { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - priv::render_addchar $idx $opt_exposed2 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - #don't incr idx - we are just putting a broken-indication in the underlay - which may get overwritten by next overlay char - } else { - #insert mode just pushes all to right - no exposition char here - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - } - } else { - #2wide over 2wide - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx 2 - incr cursor_column 2 - } - - if {$cursor_column > [llength $outcols] && $overflow_idx != -1} { - set cursor_column [llength $outcols] - } - } - } else { - priv::render_addchar $idx $ch [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode - incr idx - incr cursor_column - if {$overflow_idx !=-1 && !$test_mode} { - #overflow - if {$cursor_column > [llength $outcols]} { - set cursor_column [llength $outcols] - } - } - } - } - } - } ;# end switch - - - } - other { - set code $item - #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - - set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - set re_row_move {\x1b\[([0-9]*)(A|B)$} - set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - set re_cursor_restore {\x1b\[u$} - set re_cursor_save_dec {\x1b7$} - set re_cursor_restore_dec {\x1b8$} - set re_other_single {\x1b(D|M|E)$} - set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins - set matchinfo [list] - - #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI - #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping - #review - cost/benefit of function calls within these switch-arms instead of inline code? - - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore - set code [string map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $code] - - - set c1 [string index $code 0] - set c1c2c3 [string range $code 0 2] - #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - set leadernorm [string range [string map [list\ - \x1b\[< 1006\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\] 7OSC\ - \x9d 8OSC\ - \x1b 7ESC\ - ] $c1c2c3] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars - - #we leave the tail of the code unmapped for now - switch -- $leadernorm { - 1006 { - #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html - #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [string cat $leadernorm [string range $code 3 end]] - } - 7CSI - 7OSC { - set codenorm [string cat $leadernorm [string range $code 2 end]] - } - 7ESC { - set codenorm [string cat $leadernorm [string range $code 1 end]] - } - 8CSI - 8OSC { - set codenorm [string cat $leadernorm [string range $code 1 end]] - } - default { - #we haven't made a mapping for this - set codenorm $code - } - } - - #we've mapped 7 and 8bit escapes to values we can handle as literals in switch statements to take advantange of jump tables. - switch -- $leadernorm { - 1006 { - #TODO - # - switch -- [string index $codenorm end] { - M { - puts stderr "mousedown $codenorm" - } - m { - puts stderr "mouseup $codenorm" - } - } - - } - {7CSI} - {8CSI} { - set param [string range $codenorm 4 end-1] - #puts stdout "--> CSI [string index $leadernorm 0] bit param:$param" - switch -- [string index $codenorm end] { - D { - #Col move - #puts stdout "<-back" - #cursor back - #left-arrow/move-back when ltr mode - set num $param - if {$num eq ""} {set num 1} - - set version 2 - if {$version eq "2"} { - #todo - startcolumn offset! - if {$cursor_column - $num >= 1} { - incr idx -$num - incr cursor_column -$num - } else { - if {!$autowrap_mode} { - set cursor_column 1 - set idx 0 - } else { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - incr cursor_column -$num - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmovebackward - break - } - } - } else { - incr idx -$num - incr cursor_column -$num - if {$idx < $opt_colstart-1} { - #wrap to previous line and position cursor at end of data - set idx [expr {$opt_colstart-1}] - set cursor_column $opt_colstart - } - } - } - C { - #Col move - #puts stdout "->forward" - #todo - consider right-to-left cursor mode (e.g Hebrew).. some day. - #cursor forward - #right-arrow/move forward - set num $param - if {$num eq ""} {set num 1} - - #todo - retrict to moving 1 position past datalen? restrict to column width? - #should ideally wrap to next line when interactive and not on last row - #(some ansi art seems to expect this behaviour) - #This presumably depends on the terminal's wrap mode - #e.g DECAWM autowrap mode - # CSI ? 7 h - set: autowrap (also tput smam) - # CSI ? 7 l - reset: no autowrap (also tput rmam) - set version 2 - if {$version eq "2"} { - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$test_mode && $cursor_column == $max+1} { - #move_forward while in overflow - incr cursor_column -1 - } - - if {($cursor_column + $num) <= $max} { - incr idx $num - incr cursor_column $num - } else { - if {$autowrap_mode} { - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #jmn - if {$idx == $overflow_idx} { - incr num - } - - #horizontal movement beyond line extent needs to wrap - throw back to caller - #we may have both overflow_rightand unapplied data - #(can have overflow_right if we were in insert_mode and processed chars prior to this movement) - #leave row as is - caller will need to determine how many rows the column-movement has consumed - incr cursor_column $num ;#give our caller the necessary info as columns from start of row - #incr idx_over - #should be gci following last one applied - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction wrapmoveforward - break - } else { - set cursor_column $max - set idx [expr {$cursor_column -1}] - } - } - } else { - if {!$opt_overflow || ($cursor_column + $num) <= [llength $outcols+1]} { - incr idx $num - incr cursor_column $num - } else { - if {!$insert_mode} { - #block editing style with arrow keys - #overtype mode - set idxstart $idx - set idxend [llength $outcols] - set moveend [expr {$idxend - $idxstart}] - if {$moveend < 0} {set moveend 0} ;#sanity? - #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" - incr idx $moveend - incr cursor_column $moveend - #if {[dict exists $understacks $idx]} { - # set stackinfo [dict get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - #} else { - # set stackinfo [list] - #} - if {$idx < [llength $understacks]} { - set stackinfo [lindex $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext - } else { - set stackinfo [list] - } - if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [dict get $understacks_gx $idx] - set gxstackinfo [lindex $understacks_gx $idx] - } else { - set gxstackinfo [list] - } - #pad outcols - set movemore [expr {$num - $moveend}] - #assert movemore always at least 1 or we wouldn't be in this branch - for {set m 1} {$m <= $movemore} {incr m} { - incr idx - incr cursor_column - priv::render_addchar $idx " " $stackinfo $gxstackinfo $insert_mode - } - } else { - #normal - insert - incr idx $num - incr cursor_column $num - if {$idx > [llength $outcols]} { - set idx [llength $outcols];#allow one beyond - for adding character at end of line - set cursor_column [expr {[llength $outcols]+1}] - } - } - } - } - } - G { - #Col move - #move absolute column - #adjust to colstart - as column 1 is within overlay - #??? - set idx [expr {$param + $opt_colstart -1}] - set cursor_column $param - error "renderline absolute col move ESC G unimplemented" - } - A { - #Row move - up - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set num $param - if {$num eq ""} {set num 1} - incr cursor_row -$num - - if {$cursor_row < 1} { - set cursor_row 1 - } - - #ensure rest of *overlay* is emitted to remainder - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up - #retain cursor_column - break - } - B { - #Row move - down - set num $param - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move down - if {$num eq ""} {set num 1} - incr cursor_row $num - - - incr idx_over ;#idx_over hasn't encountered a grapheme and hasn't advanced yet - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - H - f { - #$re_both_move - lassign [split $param {;}] row col - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #lassign $matchinfo _match row col - - if {$col eq ""} {set col 1} - set max [llength $outcols] - if {$overflow_idx == -1} { - incr max - } - if {$col > $max} { - set cursor_column $max - } else { - set cursor_column $col - } - set idx [expr {$cursor_column -1}] - - if {$row eq ""} {set row 1} - set cursor_row $row - if {$cursor_row < 1} { - set cursor_row 1 - } - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move - break - - } - X { - puts stderr "X - $param" - #ECH - erase character - if {$param eq "" || $param eq "0"} {set param 1}; #param=count of chars to erase - priv::render_erasechar $idx $param - #cursor position doesn't change. - } - r { - #$re_decstbm - #https://www.vt100.net/docs/vt510-rm/DECSTBM.html - #This control function sets the top and bottom margins for the current page. You cannot perform scrolling outside the margins - lassign [split $param {;}] margin_top margin_bottom - - #todo - return these for the caller to process.. - puts stderr "overtype::renderline DECSTBM set top and bottom margin not implemented" - #Also moves the cursor to col 1 line 1 of the page - set cursor_column 1 - set cursor_row 1 - - incr idx_over - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction move ;#own instruction? decstbm? - break - } - s { - # - todo - make ansi.sys CSI s cursor save only apply for certain cases? - may need to support DECSLRM instead which uses same code - - #$re_cursor_save - #cursor save could come after last column - if {$overflow_idx != -1 && $idx == $overflow_idx} { - #bartman2.ans test file - fixes misalignment at bottom of dialog bubble - #incr cursor_row - #set cursor_column 1 - #bwings1.ans test file - breaks if we actually incr cursor (has repeated saves) - set cursor_saved_position [list row [expr {$cursor_row+1}] column 1] - } else { - set cursor_saved_position [list row $cursor_row column $cursor_column] - } - #there may be overlay stackable codes emitted that aren't in the understacks because they come between the last emmited character and the cursor_save control. - #we need the SGR and gx overlay codes prior to the cursor_save - - #a real terminal would not be able to know the state of the underlay.. so we should probably ignore it. - #set sgr_stack [lindex $understacks $idx] - #set gx_stack [lindex $understacks_gx $idx] ;#not actually a stack - just a boolean state (for now?) - - set sgr_stack [list] - set gx_stack [list] - - #we shouldn't need to scan for intermediate cursor save/restores - as restores would throw-back to the calling loop - so our overlay 'line' is since those. - #The overlay_grapheme_control_list had leading resets from previous lines - so we go back to the beginning not just the first grapheme. - - foreach gc [lrange $overlay_grapheme_control_list 0 $gci-1] { - lassign $gc type code - #types g other sgr gx0 - switch -- $type { - gx0 { - #code is actually a stand-in for the graphics on/off code - not the raw code - #It is either gx0_on or gx0_off - set gx_stack [list $code] - } - sgr { - #code is the raw code - if {[punk::ansi::codetype::is_sgr_reset $code]} { - #jmn - set sgr_stack [list "\x1b\[m"] - } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { - set sgr_stack [list $code] - lappend overlay_grapheme_control_list [list sgr $code] - } elseif {[priv::is_sgr $code]} { - #often we don't get resets - and codes just pile up. - #as a first step to simplifying - at least remove earlier straight up dupes - set dup_posns [lsearch -all -exact $sgr_stack $code] ;#needs -exact - codes have square-brackets (glob chars) - set sgr_stack [lremove $sgr_stack {*}$dup_posns] - lappend sgr_stack $code - } - } - } - } - set cursor_saved_attributes "" - switch -- [lindex $gx_stack 0] { - gx0_on { - append cursor_saved_attributes "\x1b(0" - } - gx0_off { - append cursor_saved_attributes "\x1b(B" - } - } - #append cursor_saved_attributes [join $sgr_stack ""] - append cursor_saved_attributes [punk::ansi::codetype::sgr_merge_list {*}$sgr_stack] - - #as there is apparently only one cursor storage element we don't need to throw back to the calling loop for a save. - - #don't incr index - or the save will cause cursor to move to the right - #carry on - - } - u { - #$re_cursor_restore - #we are going to jump somewhere.. for now we will assume another line, and process accordingly. - #The caller has the cursor_saved_position/cursor_saved_attributes if any (?review - if we always pass it back it, we could save some calls for moves in same line) - #don't set overflow at this point. The existing underlay to the right must be preserved. - #we only want to jump and render the unapplied at the new location. - - #lset overstacks $idx_over [list] - #set replay_codes_overlay "" - - #if {$cursor_saved_attributes ne ""} { - # set replay_codes_overlay $cursor_saved_attributes ;#empty - or last save if it happend in this input chunk - #} else { - #jj - #set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - set replay_codes_overlay "" - #} - - #like priv::render_unapplied - but without the overlay's ansi reset or gx stacks from before the restore code - incr idx_over - - set unapplied "" - set unapplied_list [list] - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - #incr idx_over - } - set unapplied [join $unapplied_list ""] - #if the save occured within this line - that's ok - it's in the return value list and caller can prepend for the next loop. - set instruction restore_cursor - break - } - ~ { - #$re_vt_sequence - #lassign $matchinfo _match key mod - lassign [split $param {;}] key mod - - #Note that f1 to f4 show as ESCOP|Q|R|S (VT220?) but f5+ show as ESC\[15~ - # - #e.g esc \[2~ insert esc \[2;2~ shift-insert - #mod - subtract 1, and then use bitmask - #shift = 1, (left)Alt = 2, control=4, meta=8 (meta seems to do nothing on many terminals on windows? Intercepted by windows?) - #puts stderr "vt key:$key mod:$mod code:[ansistring VIEW $code]" - if {$key eq "1"} { - #home - } elseif {$key eq "2"} { - #Insert - if {$mod eq ""} { - #no modifier key - set insert_mode [expr {!$insert_mode}] - #rather than set the cursor - we return the insert mode state so the caller can decide - } - } elseif {$key eq "3"} { - #Delete - presumably this shifts other chars in the line, with empty cells coming in from the end - switch -- $mod { - "" { - priv::render_delchar $idx - } - "5" { - #ctrl-del - delete to end of word (pwsh) - possibly word on next line if current line empty(?) - } - } - } elseif {$key eq "4"} { - #End - } elseif {$key eq "5"} { - #pgup - } elseif {$key eq "6"} { - #pgDn - } elseif {$key eq "7"} { - #Home - #?? - set idx [expr {$opt_colstart -1}] - set cursor_column 1 - } elseif {$key eq "8"} { - #End - } elseif {$key eq "11"} { - #F1 - or ESCOP or e.g shift F1 ESC\[1;2P - } elseif {$key eq "12"} { - #F2 - or ESCOQ - } elseif {$key eq "13"} { - #F3 - or ESCOR - } elseif {$key eq "14"} { - #F4 - or ESCOS - } elseif {$key eq "15"} { - #F5 or shift F5 ESC\[15;2~ - } elseif {$key eq "17"} { - #F6 - } elseif {$key eq "18"} { - #F7 - } elseif {$key eq "19"} { - #F8 - } elseif {$key eq "20"} { - #F9 - } elseif {$key eq "21"} { - #F10 - } elseif {$key eq "23"} { - #F11 - } elseif {$key eq "24"} { - #F12 - } - - } - h - l { - #we are matching only last char to get to this arm - but are there other sequences ending in h|l we need to handle? - - #$re_mode if first after CSI is "?" - #some docs mention ESC=h|l - not seen on windows terminals.. review - #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - if {[string index $codenorm 4] eq "?"} { - set num [string range $codenorm 5 end-1] ;#param between ? and h|l - #lassign $matchinfo _match num type - switch -- $num { - 5 { - #DECSNM - reverse video - #How we simulate this to render within a block of text is an open question. - #track all SGR stacks and constantly flip based on the current SGR reverse state? - #It is the job of the calling loop to do this - so at this stage we'll just set the states - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set reverse_mode 1 - } else { - #reset (disable) - set reverse_mode 0 - } - - } - 7 { - #DECAWM autowrap - if {$type eq "h"} { - #set (enable) - set autowrap_mode 1 - if {$opt_width ne "\uFFEF"} { - set overflow_idx $opt_width - } else { - #review - this is also the cursor position when adding a char at end of line? - set overflow_idx [expr {[llength $undercols]}] ;#index at which we would be *in* overflow a row move may still override it - } - #review - can idx ever be beyond overflow_idx limit when we change e.g with a width setting and cursor movements? presume not - but sanity check for now. - if {$idx >= $overflow_idx} { - puts stderr "renderline error - idx '$idx' >= overflow_idx '$overflow_idx' - unexpected" - } - } else { - #reset (disable) - set autowrap_mode 0 - set overflow_idx -1 - } - } - 25 { - if {$type eq "h"} { - #visible cursor - - } else { - #invisible cursor - - } - } - } - - } else { - puts stderr "overtype::renderline CSI...h|l code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - default { - puts stderr "overtype::renderline CSI code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - } - 7ESC { - #$re_other_single - switch -- [string index $codenorm end] { - D { - #\x84 - #index (IND) - #vt102-docs: "Moves cursor down one line in same column. If cursor is at bottom margin, screen performs a scroll-up" - puts stderr "ESC D not fully implemented" - incr cursor_row - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction down - #retain cursor_column - break - } - M { - #\x8D - #Reverse Index (RI) - #vt102-docs: "Moves cursor up one line in same column. If cursor is at top margin, screen performs a scroll-down" - puts stderr "ESC M not fully implemented" - - set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}[lindex $overlay_grapheme_control_stacks $gci]] - #move up - incr cursor_row -1 - if {$cursor_row < 1} { - set cursor_row 1 - } - #ensure rest of *overlay* is emitted to remainder - priv::render_unapplied $overlay_grapheme_control_list $gci - set instruction up ;#need instruction for scroll-down? - #retain cursor_column - break - } - E { - #\x85 - #review - is behaviour different to lf? - #todo - possibly(?) same logic as handling above. i.e return instruction depends on where column_cursor is at the time we get NEL - #leave implementation until logic for is set in stone... still under review - #It's arguable NEL is a pure cursor movement as opposed to the semantic meaning of crlf or lf in a file. - # - #Next Line (NEL) "Move the cursor to the left margin on the next line. If the cursor is at the bottom margin, scroll the page up" - puts stderr "ESC E unimplemented" - - } - default { - puts stderr "overtype::renderline ESC code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - } - } - - } - } - - #switch -regexp -matchvar matchinfo -- $code\ - #$re_mode { - #}\ - #default { - # puts stderr "overtype::renderline code [ansistring VIEW -lf 1 -vt 1 -nul 1 $code] not implemented" - #} - - } - default { - #don't need to handle sgr or gx0 types - #we have our sgr gx0 codes already in stacks for each overlay grapheme - } - } - } - - #-------- - if {$opt_overflow == 0} { - #need to truncate to the width of the original undertext - #review - string_width vs printing_length here. undertext requirement to be already rendered therefore punk::char::string_width ok? - #set num_under_columns [punk::char::string_width $pt_underchars] ;#plaintext underchars - } - if {$overflow_idx == -1} { - #overflow was initially unlimited and hasn't been overridden - } else { - - } - #-------- - - - #coalesce and replay codestacks for outcols grapheme list - set outstring "" ;#output prior to overflow - set overflow_right "" ;#remainder after overflow point reached - set i 0 - set cstack [list] - set prevstack [list] - set prev_g0 [list] - #note overflow_idx may already have been set lower if we had a row move above due to \v or ANSI moves - set in_overflow 0 ;#used to stop char-width scanning once in overflow - if {$overflow_idx == 0} { - #how does caller avoid an infinite loop if they have autowrap on and keep throwing graphemes to the next line? REVIEW - set in_overflow 1 - } - foreach ch $outcols { - #puts "---- [ansistring VIEW $ch]" - - set gxleader "" - if {$i < [llength $understacks_gx]} { - #set g0 [dict get $understacks_gx $i] - set g0 [lindex $understacks_gx $i] - if {$g0 ne $prev_g0} { - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } else { - set gxleader "\x1b(B" - } - } - set prev_g0 $g0 - } else { - set prev_g0 [list] - } - - set sgrleader "" - if {$i < [llength $understacks]} { - #set cstack [dict get $understacks $i] - set cstack [lindex $understacks $i] - if {$cstack ne $prevstack} { - if {[llength $prevstack] && ![llength $cstack]} { - #This reset is important e.g testfile fruit.ans - we get overhang on rhs without it. But why is cstack empty? - append sgrleader \033\[m - } else { - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - } - } - set prevstack $cstack - } else { - set prevstack [list] - } - - - - if {$in_overflow} { - if {$i == $overflow_idx} { - set 0 [lindex $understacks_gx $i] - set gxleader "" - if {$g0 eq [list "gx0_on"]} { - set gxleader "\x1b(0" - } elseif {$g0 eq [list "gx0_off"]} { - set gxleader "\x1b(B" - } - append overflow_right $gxleader - set cstack [lindex $understacks $i] - set sgrleader "" - #whether cstack is same or differs from previous char's stack - we must have an output at the start of the overflow_right - #if {[llength $prevstack] && ![llength $cstack]} { - # append sgrleader \033\[m - #} - append sgrleader [punk::ansi::codetype::sgr_merge_list {*}$cstack] - append overflow_right $sgrleader - append overflow_right $ch - } else { - append overflow_right $gxleader - append overflow_right $sgrleader - append overflow_right $ch - } - } else { - if {$overflow_idx != -1 && $i+1 == $overflow_idx} { - #one before overflow - #will be in overflow in next iteration - set in_overflow 1 - if {[grapheme_width_cached $ch]> 1} { - #we overflowed with second-half of a double-width char - replace first-half with user-supplied exposition char (should be 1 wide) - set ch $opt_exposed1 - } - } - append outstring $gxleader - append outstring $sgrleader - if {$idx+1 < $cursor_column} { - append outstring [string map [list "\u0000" " "] $ch] - } else { - append outstring $ch - } - } - incr i - } - #flower.ans good test for null handling - reverse line building - if {![ansistring length $overflow_right]} { - set outstring [string trimright $outstring "\u0000"] - } - set outstring [string map [list "\u0000" " "] $outstring] - set overflow_right [string trimright $overflow_right "\u0000"] - set overflow_right [string map [list "\u0000" " "] $overflow_right] - - set replay_codes "" - if {[llength $understacks] > 0} { - if {$overflow_idx == -1} { - #set tail_idx [dict size $understacks] - set tail_idx [llength $understacks] - } else { - set tail_idx [llength $undercols] - } - if {$tail_idx-1 < [llength $understacks]} { - #set replay_codes [join [lindex $understacks $tail_idx-1] ""] ;#tail replay codes - set replay_codes [punk::ansi::codetype::sgr_merge_list {*}[lindex $understacks $tail_idx-1]] ;#tail replay codes - } - if {$tail_idx-1 < [llength $understacks_gx]} { - set gx0 [lindex $understacks_gx $tail_idx-1] - if {$gx0 eq [list "gx0_on"]} { - #if it was on, turn gx0 off at the point we stop processing overlay - append outstring "\x1b(B" - } - } - } - if {[string length $overflow_right]} { - #puts stderr "remainder:$overflow_right" - } - #pdict $understacks - - if {[punk::ansi::ta::detect_sgr $outstring]} { - append outstring [punk::ansi::a] ;#without this - we would get for example, trailing backgrounds after rightmost column - - #close off any open gx? - #probably should - and overflow_right reopen? - } - - if {$opt_returnextra} { - #replay_codes is the codestack at the boundary - used for ellipsis colouring to match elided text - review - #replay_codes_underlay is the set of codes in effect at the very end of the original underlay - - #review - #replay_codes_overlay is the set of codes in effect at the very end of the original overlay (even if not all overlay was applied) - #todo - replay_codes for gx0 mode - - #overflow_idx may change during ansi & character processing - if {$overflow_idx == -1} { - set overflow_right_column "" - } else { - set overflow_right_column [expr {$overflow_idx+1}] - } - set result [dict create\ - result $outstring\ - visualwidth [punk::ansi::printing_length $outstring]\ - instruction $instruction\ - stringlen [string length $outstring]\ - overflow_right_column $overflow_right_column\ - overflow_right $overflow_right\ - unapplied $unapplied\ - unapplied_list $unapplied_list\ - insert_mode $insert_mode\ - autowrap_mode $autowrap_mode\ - insert_lines_above $insert_lines_above\ - insert_lines_below $insert_lines_below\ - cursor_saved_position $cursor_saved_position\ - cursor_saved_attributes $cursor_saved_attributes\ - cursor_column $cursor_column\ - cursor_row $cursor_row\ - opt_overflow $opt_overflow\ - replay_codes $replay_codes\ - replay_codes_underlay $replay_codes_underlay\ - replay_codes_overlay $replay_codes_overlay\ - ] - if {$opt_returnextra == 1} { - return $result - } else { - #human/debug - map special chars to visual glyphs - set viewop VIEW - switch -- $opt_returnextra { - 2 { - #codes and character data - set viewop VIEWCODES ;#ansi colorisation of codes - green for SGR, blue/blue reverse for cursor_save/cursor_restore, cyan for movements, orange for others - } - 3 { - set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. - } - } - dict set result result [ansistring $viewop -lf 1 -vt 1 [dict get $result result]] - dict set result overflow_right [ansistring VIEW -lf 1 -vt 1 [dict get $result overflow_right]] - dict set result unapplied [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied]] - dict set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied_list]] - dict set result replay_codes [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes]] - dict set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_underlay]] - dict set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_overlay]] - dict set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [dict get $result cursor_saved_attributes]] - return $result - } - } else { - return $outstring - } - #return [join $out ""] - } - - #*** !doctools - #[list_end] [comment {--- end definitions namespace overtype ---}] -} - -namespace eval overtype::piper { - proc overcentre {args} { - if {[llength $args] < 2} { - error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::centre {*}$argsflags $under $over - } - proc overleft {args} { - if {[llength $args] < 2} { - error {usage: ?-startcolumn ? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} - } - lassign [lrange $args end-1 end] over under - set argsflags [lrange $args 0 end-2] - tailcall overtype::left {*}$argsflags $under $over - } -} - - -# -- --- --- --- --- --- --- --- --- --- --- -proc overtype::transparentline {args} { - foreach {under over} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - set defaults [dict create\ - -transparent 1\ - -exposed 1 " "\ - -exposed 2 " "\ - ] - set newargs [dict merge $defaults $argsflags] - tailcall overtype::renderline {*}$newargs $under $over -} -#renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. -# We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. -#We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. -# -namespace eval overtype::piper { - proc renderline {args} { - if {[llength $args] < 2} { - error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} - } - foreach {over under} [lrange $args end-1 end] break - set argsflags [lrange $args 0 end-2] - tailcall overtype::renderline {*}$argsflags $under $over - } -} -interp alias "" piper_renderline "" overtype::piper::renderline - -#intended for single grapheme - but will work for multiple -#cannot contain ansi or newlines -#(a cache of ansifreestring_width calls - as these are quite regex heavy) -proc overtype::grapheme_width_cached {ch} { - variable grapheme_widths - if {[dict exists $grapheme_widths $ch]} { - return [dict get $grapheme_widths $ch] - } - set width [punk::char::ansifreestring_width $ch] - dict set grapheme_widths $ch $width - return $width -} - - - -proc overtype::test_renderline {} { - set t \uFF5E ;#2-wide tilde - set u \uFF3F ;#2-wide underscore - set missing \uFFFD - return [list $t $u A${t}B] -} - -#maintenance warning -#same as textblock::size - but we don't want that circular dependency -#block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both -proc overtype::blocksize {textblock} { - if {$textblock eq ""} { - return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings - } - if {[string first \t $textblock] >= 0} { - if {[info exists punk::console::tabwidth]} { - set tw $::punk::console::tabwidth - } else { - set tw 8 - } - set textblock [textutil::tabify::untabify2 $textblock $tw] - } - #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests - if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansi $textblock] - } - if {[string first \n $textblock] >= 0} { - set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list - set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] - } else { - set num_le 0 - set width [punk::char::ansifreestring_width $textblock] - } - #our concept of block-height is likely to be different to other line-counting mechanisms - set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - - return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height -} - -namespace eval overtype::priv { - variable cache_is_sgr [dict create] - - #we are likely to be asking the same question of the same ansi codes repeatedly - #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS - #todo - test if still worthwhile after a large cache is built up. (limit cache size?) - proc is_sgr {code} { - variable cache_is_sgr - if {[dict exists $cache_is_sgr $code]} { - return [dict get $cache_is_sgr $code] - } - set answer [punk::ansi::codetype::is_sgr $code] - dict set cache_is_sgr $code $answer - return $answer - } - proc render_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list ;#maintaining as a list allows caller to utilize it without having to re-split - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - #append unapplied [join [lindex $overstacks $idx_over] ""] - #append unapplied [punk::ansi::codetype::sgr_merge_list {*}[lindex $overstacks $idx_over]] - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci+1 end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - - #clearer - renders the specific gci forward as unapplied - prefixed with it's merged sgr stack - proc render_this_unapplied {overlay_grapheme_control_list gci} { - upvar idx_over idx_over - upvar unapplied unapplied - upvar unapplied_list unapplied_list - upvar overstacks overstacks - upvar overstacks_gx overstacks_gx - upvar overlay_grapheme_control_stacks og_stacks - - #set unapplied [join [lrange $overlay_grapheme_control_list $gci+1 end]] - set unapplied "" - set unapplied_list [list] - - set sgr_merged [punk::ansi::codetype::sgr_merge_list {*}[lindex $og_stacks $gci]] - if {$sgr_merged ne ""} { - lappend unapplied_list $sgr_merged - } - switch -- [lindex $overstacks_gx $idx_over] { - "gx0_on" { - lappend unapplied_list "\x1b(0" - } - "gx0_off" { - lappend unapplied_list "\x1b(B" - } - } - - foreach gc [lrange $overlay_grapheme_control_list $gci end] { - lassign $gc type item - #types g other sgr gx0 - if {$type eq "gx0"} { - if {$item eq "gx0_on"} { - lappend unapplied_list "\x1b(0" - } elseif {$item eq "gx0_off"} { - lappend unapplied_list "\x1b(B" - } - } else { - lappend unapplied_list $item - } - } - set unapplied [join $unapplied_list ""] - } - proc render_delchar {i} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - set nxt [llength $o] - if {$i < $nxt} { - set o [lreplace $o $i $i] - set ustacks [lreplace $ustacks $i $i] - set gxstacks [lreplace $gxstacks $i $i] - } else { - - } - } - proc render_erasechar {i count} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - #ECH clears character attributes from erased character positions - #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. - if {![string is integer -strict $count] || $count < 1} { - error "render_erasechar count must be integer >= 1" - } - set start $i - set end [expr {$i + $count -1}] - #we restrict ECH to current line - as some terminals do - review - is that the only way it's implemented? - if {$i > [llength $o]-1} { - return - } - if {$end > [llength $o]-1} { - set end [expr {[llength $o]-1}] - } - set num [expr {$end - $start + 1}] - set o [lreplace $o $start $end {*}[lrepeat $num \u0000]] ;#or space? - set ustacks [lreplace $ustacks $start $end {*}[lrepeat $num [list]]] - set gxstacks [lreplace $gxstacks $start $end {*}[lrepeat $num [list]]] - return - } - proc render_setchar {i c } { - upvar outcols o - lset o $i $c - } - #is actually addgrapheme? - proc render_addchar {i c sgrstack gx0stack {insert_mode 0}} { - upvar outcols o - upvar understacks ustacks - upvar understacks_gx gxstacks - - if 0 { - if {$c eq "c"} { - puts "i:$i c:$c sgrstack:[ansistring VIEW $sgrstack]" - puts "understacks:[ansistring VIEW $ustacks]" - upvar overstacks overstacks - puts "overstacks:[ansistring VIEW $overstacks]" - puts "info level 0:[info level 0]" - } - } - - set nxt [llength $o] - if {!$insert_mode} { - if {$i < $nxt} { - #These lists must always be in sync - lset o $i $c - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - lset ustacks $i $sgrstack - lset gxstacks $i $gx0stack - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } else { - #insert of single-width vs double-width when underlying is double-width? - if {$i < $nxt} { - set o [linsert $o $i $c] - } else { - lappend o $c - } - if {$i < [llength $ustacks]} { - set ustacks [linsert $ustacks $i $sgrstack] - set gxstacks [linsert $gxstacks $i $gx0stack] - } else { - lappend ustacks $sgrstack - lappend gxstacks $gx0stack - } - } - } - -} - - - -# -- --- --- --- --- --- --- --- --- --- --- -namespace eval overtype { - interp alias {} ::overtype::center {} ::overtype::centre -} - -# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -## Ready -package provide overtype [namespace eval overtype { - variable version - set version 1.6.2 -}] -return - -#*** !doctools -#[manpage_end] diff --git a/src/bootsupport/modules/overtype-1.6.4.tm b/src/bootsupport/modules/overtype-1.6.5.tm similarity index 98% rename from src/bootsupport/modules/overtype-1.6.4.tm rename to src/bootsupport/modules/overtype-1.6.5.tm index 42876322..143794fb 100644 --- a/src/bootsupport/modules/overtype-1.6.4.tm +++ b/src/bootsupport/modules/overtype-1.6.5.tm @@ -7,7 +7,7 @@ # (C) Julian Noble 2003-2023 # # @@ Meta Begin -# Application overtype 1.6.4 +# Application overtype 1.6.5 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.4] +#[manpage_begin overtype_module_overtype 0 1.6.5] #[copyright "2024"] #[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] #[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] @@ -146,66 +146,12 @@ tcl::namespace::eval overtype { } -#proc overtype::stripansi {text} { -# variable escape_terminals ;#dict -# variable ansi_2byte_codes_dict -# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway -# if {[string first \033 $text] <0 && [string first \009c $text] <0} { -# #\033 same as \x1b -# return $text -# } -# -# set text [convert_g0 $text] -# -# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. -# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) -# set inputlist [split $text ""] -# set outputlist [list] -# -# set 2bytecodes [dict values $ansi_2byte_codes_dict] -# -# set in_escapesequence 0 -# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls -# set i 0 -# foreach u $inputlist { -# set v [lindex $inputlist $i+1] -# set uv ${u}${v} -# if {$in_escapesequence eq "2b"} { -# #2nd byte - done. -# set in_escapesequence 0 -# } elseif {$in_escapesequence != 0} { -# set escseq [tcl::dict::get $escape_terminals $in_escapesequence] -# if {$u in $escseq} { -# set in_escapesequence 0 -# } elseif {$uv in $escseq} { -# set in_escapseequence 2b ;#flag next byte as last in sequence -# } -# } else { -# #handle both 7-bit and 8-bit CSI and OSC -# if {[regexp {^(?:\033\[|\u009b)} $uv]} { -# set in_escapesequence CSI -# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { -# set in_escapesequence OSC -# } elseif {$uv in $2bytecodes} { -# #self-contained e.g terminal reset - don't pass through. -# set in_escapesequence 2b -# } else { -# lappend outputlist $u -# } -# } -# incr i -# } -# return [join $outputlist ""] -#} - - - proc overtype::string_columns {text} { if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::stripansi $text] + #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" + set text [punk::ansi::ansistrip $text] } return [punk::char::ansifreestring_width $text] } @@ -265,7 +211,7 @@ tcl::namespace::eval overtype { variable default_ellipsis_horizontal if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } lassign [lrange $args end-1 end] underblock overblock set opts [tcl::dict::create\ @@ -1059,7 +1005,7 @@ tcl::namespace::eval overtype { set show_ellipsis 0 } #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] - if {[tcl::string::trim [punk::ansi::stripansi $lostdata]] eq ""} { + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { set show_ellipsis 0 } } @@ -1837,8 +1783,9 @@ tcl::namespace::eval overtype { set pt [tcl::string::map $cp437_map $pt] } foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance switch -- $grapheme { " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - @@ -3460,9 +3407,9 @@ proc overtype::blocksize {textblock} { } set textblock [textutil::tabify::untabify2 $textblock $tw] } - #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests + #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansi $textblock] + set textblock [punk::ansi::ansistrip $textblock] } if {[tcl::string::last \n $textblock] >= 0} { set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list @@ -3677,7 +3624,7 @@ tcl::namespace::eval overtype { ## Ready package provide overtype [tcl::namespace::eval overtype { variable version - set version 1.6.4 + set version 1.6.5 }] return diff --git a/src/bootsupport/modules/punk/ansi-0.1.1.tm b/src/bootsupport/modules/punk/ansi-0.1.1.tm index fd14bcae..85cb9f27 100644 --- a/src/bootsupport/modules/punk/ansi-0.1.1.tm +++ b/src/bootsupport/modules/punk/ansi-0.1.1.tm @@ -265,13 +265,13 @@ tcl::namespace::eval punk::ansi::class { } set opts_width [tcl::dict::get $opts -width] if {$opts_width eq ""} { - return [punk::ansi::stripansiraw [$o_ansistringobj get]] + return [punk::ansi::ansistripraw [$o_ansistringobj get]] } elseif {$opts_width eq "auto"} { lassign [punk::console::get_size] _cols columns _rows rows set displaycols [expr {$columns -4}] ;#review - return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]] + return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]] } elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} { - return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]] + return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]] } else { error "viewchars unrecognised value for -width. Try auto or a positive integer" } @@ -420,7 +420,7 @@ tcl::namespace::eval punk::ansi { get_*\ move*\ reset*\ - strip*\ + ansistrip*\ test_decaln\ titleset\ @@ -750,7 +750,7 @@ tcl::namespace::eval punk::ansi { #mqj #m = boxd_lur - #don't call detect_g0 in here. Leave for caller. e.g stripansi uses detect_g0 to decide whether to call this. + #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] @@ -813,14 +813,17 @@ tcl::namespace::eval punk::ansi { proc g0 {text} { return \x1b(0$text\x1b(B } + proc ansistrip_gx {text} { + #e.g "\033(0" - select VT100 graphics for character set G0 + #e.g "\033(B" - reset + #e.g "\033)0" - select VT100 graphics for character set G1 + #e.g "\033)X" - where X is any char other than 0 to reset ?? + + #return [convert_g0 $text] + return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] + } proc stripansi_gx {text} { - #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset - #e.g "\033)0" - select VT100 graphics for character set G1 - #e.g "\033)X" - where X is any char other than 0 to reset ?? - - #return [convert_g0 $text] - return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] + return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] } @@ -1085,7 +1088,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #This is an in depth analysis of the xterm colour set which gives names(*) to all of the 256 colours and describes possible indexing by Hue,Luminance,Saturation #https://www.wowsignal.io/articles/xterm256 - #*The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard. + # *The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard. #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: @@ -1872,7 +1875,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t configure -frametype {} $t configure_column 0 -headers [list "[tcl::string::totitle $g] colours"] - $t configure_column 0 -header_colspans [list all] + $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend grouptables [$t print] $t destroy @@ -1919,7 +1922,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t configure -frametype block $t configure_column 0 -headers [list "X11"] - $t configure_column 0 -header_colspans [list all] + $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend comparetables [$t print] $t destroy @@ -1940,7 +1943,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } $t configure -frametype block $t configure_column 0 -headers [list "Web"] - $t configure_column 0 -header_colspans [list all] + $t configure_column 0 -header_colspans [list any] $t configure -ansibase_header [a+ {*}$fc web-black Web-white] lappend comparetables [$t print] $t destroy @@ -2013,39 +2016,39 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu package require overtype ;# circular dependency - many components require overtype. Here we only need it for nice layout in the a? query proc - so we'll do a soft-dependency by only loading when needed and also wrapping in a try package require textblock - append out [textblock::join $indent [tcl::string::map $strmap $settings_applied]] \n - append out [textblock::join $indent [tcl::string::trim $SGR_colour_map \n]] \n - append out [textblock::join $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n + append out [textblock::join -- $indent [tcl::string::map $strmap $settings_applied]] \n + append out [textblock::join -- $indent [tcl::string::trim $SGR_colour_map \n]] \n + append out [textblock::join -- $indent "Example: \[a+ bold red White underline\]text\[a] -> [a+ bold red White underline]text[a]"] \n \n set bgname "Web-white" set map1 [colourmap1 -bg $bgname -forcecolour $opt_forcecolour] set map1 [overtype::centre -transparent 1 $map1 "[a {*}$fc black $bgname]Standard colours[a]"] set map2 [colourmap2 -bg $bgname -forcecolour $opt_forcecolour] set map2 [overtype::centre -transparent 1 $map2 "[a {*}$fc black $bgname]High-intensity colours[a]"] - append out [textblock::join $indent [textblock::join -- $map1 $map2]] \n + append out [textblock::join -- $indent [textblock::join -- $map1 $map2]] \n append out "[a+ {*}$fc web-white]216 colours of 256 terminal colours (To see names, use: a? term ?pastel? ?rainbow?)[a]" \n - append out [textblock::join $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n + append out [textblock::join -- $indent [colourblock_216 -forcecolour $opt_forcecolour]] \n append out "[a+ {*}$fc web-white]24 Greyscale colours[a]" \n - append out [textblock::join $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n + append out [textblock::join -- $indent [colourblock_24 -forcecolour $opt_forcecolour]] \n append out \n - append out [textblock::join $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Term-92 term-49\]text\[a] -> [a+ {*}$fc Term-92 term-49]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Term-lightsteelblue term-gold1\]text\[a] -> [a+ {*}$fc Term-lightsteelblue term-gold1]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ term-lightsteelblue Term-gold1\]text\[a] -> [a+ {*}$fc term-lightsteelblue Term-gold1]text[a]"] \n append out \n append out "[a+ {*}$fc web-white]16 Million colours[a]" \n #tcl::dict::set WEB_colour_map mediumvioletred 199-21-133 ;# #C71585 - append out [textblock::join $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n - append out [textblock::join $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n - append out [textblock::join $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n + append out [textblock::join -- $indent "Example: \[a+ rgb-199-21-133\]text\[a] -> [a+ {*}$fc rgb-199-21-133]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Rgb#C71585\]text\[a] -> [a+ {*}$fc Rgb#C71585]text[a]"] \n + append out [textblock::join -- $indent "Examine a sequence: a? bold rgb-46-139-87 Rgb#C71585 "] \n append out \n append out "[a+ {*}$fc web-white]Web colours[a]" \n - append out [textblock::join $indent "To see all names use: a? web"] \n - append out [textblock::join $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n - append out [textblock::join $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n + append out [textblock::join -- $indent "To see all names use: a? web"] \n + append out [textblock::join -- $indent "To see specific colour groups use: a? web groupname1 groupname2..."] \n + append out [textblock::join -- $indent "Valid group names (can be listed in any order): basic pink red orange yellow brown purple blue cyan green white grey"] \n append out \n - append out [textblock::join $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n + append out [textblock::join -- $indent "Example: \[a+ Web-springgreen web-crimson\]text\[a] -> [a+ {*}$fc Web-springgreen web-coral]text[a]"] \n append out \n append out "[a+ {*}$fc web-white]X11 colours[a] - mostly match Web colours" \n - append out [textblock::join $indent "To see differences: a? x11"] \n + append out [textblock::join -- $indent "To see differences: a? x11"] \n if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { append out \n @@ -2261,15 +2264,29 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu set sgr_cache [tcl::dict::create] #sgr_cache clear called by punk::console::ansi when set to off - proc sgr_cache {{action ""}} { + proc sgr_cache {args} { + set argd [punk::args::get_dict { + *proc -name punk::ansi::sgr_cache -help "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + *values -min 0 -max 0 + } $args] + set action [dict get $argd opts -action] + set pretty [dict get $argd opts -pretty] + variable sgr_cache - if {$action ni {"" clear}} { - error "sgr_cache action '$action' not understood. Valid actions: clear" - } if {$action eq "clear"} { set sgr_cache [tcl::dict::create] return "sgr_cache cleared" } + if {$pretty} { + #return [pdict -channel none sgr_cache */%str,%ansiview] + return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] + } + if {[catch { set termwidth [tcl::dict::get [punk::console::get_size] columns] } errM]} { @@ -2311,7 +2328,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #function name part of cache-key because a and a+ return slightly different results (a has leading reset) variable sgr_cache - set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key + set cache_key "a+ $args" ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key if {[tcl::dict::exists $sgr_cache $cache_key]} { return [tcl::dict::get $sgr_cache $cache_key] } @@ -2670,7 +2687,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #It's important to put the functionname in the cache-key because a and a+ return slightly different results variable sgr_cache - set cache_key a_$args + set cache_key "a $args" if {[tcl::dict::exists $sgr_cache $cache_key]} { return [tcl::dict::get $sgr_cache $cache_key] } @@ -2681,7 +2698,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable TERM_colour_map set colour_disabled 0 - #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear + #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache -action clear if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { set colour_disabled 1 } @@ -3381,10 +3398,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char #This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width? - set line [punk::ansi::stripansi $line] + set line [punk::ansi::ansistrip $line] #we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves) - set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi + set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after ansistrip - some like BEL are part of ansi #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter #(* more correctly - moves cursor back) #Note some terminals process backspace before \v - which seems quite wrong @@ -3500,6 +3517,40 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } + #ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks + proc ansistrip {text} { + #*** !doctools + #[call [fun ansistrip] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + if {[punk::ansi::ta::detect_g0 $text]} { + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + } + set parts [punk::ansi::ta::split_codes $text] + set out "" + foreach {pt code} $parts { + append out $pt + } + return $out + } + #interp alias {} stripansi {} ::punk::ansi::ansistrip + proc ansistripraw {text} { + #*** !doctools + #[call [fun ansistripraw] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. + #[para]ie instead of a horizontal line you may see: qqqqqq + + set parts [punk::ansi::ta::split_codes $text] + set out "" + foreach {pt code} $parts { + append out $pt + } + return $out + } + #interp alias {} stripansiraw {} ::punk::ansi::ansistripraw + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi ---}] } @@ -4281,16 +4332,16 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun strip] [arg text]] #[para]Return text stripped of Ansi codes - #[para]This is a tailcall to punk::ansi::stripansi - tailcall stripansi $text + #[para]This is a tailcall to punk::ansi::ansistrip + tailcall ansistrip $text } proc length {text} { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - #we can use stripansiraw to avoid g0 conversion - as the length should remain the same - tcl::string::length [stripansiraw $text] + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same + tcl::string::length [ansistripraw $text] } #todo - handle newlines #not in perl ta @@ -5439,11 +5490,8 @@ tcl::namespace::eval punk::ansi::class { } } tcl::namespace::eval punk::ansi { - proc stripansi {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #*** !doctools - #[call [fun stripansi] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary @@ -5459,12 +5507,7 @@ tcl::namespace::eval punk::ansi { punk::ansi::ta::Do_split_at_codes_join $text {} }] - proc stripansiraw {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #*** !doctools - #[call [fun stripansi] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq + proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { #join [::punk::ansi::ta::split_at_codes $text] "" punk::ansi::ta::Do_split_at_codes_join $text {} @@ -5890,7 +5933,7 @@ tcl::namespace::eval punk::ansi::ansistring { #[para]Returns the count of visible graphemes and non-ansi control characters #[para]Incomplete! grapheme clustering support not yet implemented - only diacritics are currently clustered to count as one grapheme. #[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence. - #[para]This is not quite equivalent to calling string length on the result of stripansi $string due to diacritics and/or grapheme combinations + #[para]This is not quite equivalent to calling string length on the result of ansistrip $string due to diacritics and/or grapheme combinations #[para]Note that this returns the number of characters in the payload (after applying combiners) #It is not always the same as the width of the string as rendered on a terminal due to 2wide Unicode characters and the usual invisible control characters such as \r and \n #[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware. @@ -5902,17 +5945,17 @@ tcl::namespace::eval punk::ansi::ansistring { set string [regsub -all $re_diacritics $string ""] #we want length to return number of glyphs.. not screen width. Has to be consistent with index function - tcl::string::length [stripansi $string] + tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { #we want count to return number of glyphs.. not screen width. Has to be consistent with index function - return [llength [punk::char::grapheme_split [stripansi $string]]] + return [llength [punk::char::grapheme_split [ansistrip $string]]] } proc length {string} { - tcl::string::length [stripansi $string] + tcl::string::length [ansistrip $string] } proc _splits_trimleft {sclist} { @@ -6022,9 +6065,9 @@ tcl::namespace::eval punk::ansi::ansistring { #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. - #[para]If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards. - #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index. - #[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that. + #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. + #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. + #[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using ansistrip and normal string operations on that. #[para]The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code #[para]The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered. #[para]The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be. diff --git a/src/bootsupport/modules/punk/args-0.1.0.tm b/src/bootsupport/modules/punk/args-0.1.0.tm index e148a2aa..5e270ac8 100644 --- a/src/bootsupport/modules/punk/args-0.1.0.tm +++ b/src/bootsupport/modules/punk/args-0.1.0.tm @@ -267,6 +267,9 @@ tcl::namespace::eval punk::args { #[list_begin definitions] + #todo? -synonym ? (applies to opts only not values) + #e.g -background -synonym -bg -default White + proc Get_argspecs {optionspecs args} { variable argspec_cache variable argspecs @@ -332,7 +335,8 @@ tcl::namespace::eval punk::args { set in_record 0 foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] - if {![tcl::info::complete $recordsofar]} { + #ansi colours can stop info complete from working (contain square brackets) + if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} { #append linebuild [string trimleft $rawline] \n if {$in_record} { if {[tcl::string::length $lastindent]} { @@ -436,6 +440,9 @@ tcl::namespace::eval punk::args { } none - any - ansistring { + } + list { + } default { #todo - disallow unknown types unless prefixed with custom- @@ -494,6 +501,9 @@ tcl::namespace::eval punk::args { } dict - dictionary { set v dict + } + list { + } default { #todo - disallow unknown types unless prefixed with custom- @@ -568,7 +578,9 @@ tcl::namespace::eval punk::args { "" - none { if {$is_opt} { tcl::dict::set spec_merged -type none - tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + if {[tcl::dict::exists $specval -optional] && [tcl::dict::get $specval -optional]} { + tcl::dict::set spec_merged -default 0 ;#-default 0 can still be overridden if -default appears after -type - we'll allow it. + } lappend opt_solos $argname } else { #-solo only valid for flags @@ -687,6 +699,8 @@ tcl::namespace::eval punk::args { } proc arg_error {msg spec_dict {badarg ""}} { + # use basic colours here to support terminals without extended colours + #todo - add checks column (e.g -minlen -maxlen) set errmsg $msg if {![catch {package require textblock}]} { if {[catch { @@ -694,18 +708,21 @@ tcl::namespace::eval punk::args { set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""] set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""] - set t [textblock::class::table new [a+ web-yellow]Usage[a]] + #set t [textblock::class::table new [a+ web-yellow]Usage[a]] + set t [textblock::class::table new [a+ brightyellow]Usage[a]] set blank_header_col [list ""] if {$procname ne ""} { lappend blank_header_col "" - set procname_display [a+ web-white]$procname[a] + #set procname_display [a+ web-white]$procname[a] + set procname_display [a+ brightwhite]$procname[a] } else { set procname_display "" } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ web-white]$prochelp[a] + #set prochelp_display [a+ web-white]$prochelp[a] + set prochelp_display [a+ brightwhite]$prochelp[a] } else { set prochelp_display "" } @@ -728,9 +745,12 @@ tcl::namespace::eval punk::args { $t configure_header 2 -values {Arg Type Default Multiple Help} } - set c_default [a+ web-white Web-limegreen] - set c_badarg [a+ web-crimson] - set greencheck [a+ web-limegreen]\u2713[a] + #set c_default [a+ web-white Web-limegreen] + set c_default [a+ brightwhite Brightgreen] + #set c_badarg [a+ web-crimson] + set c_badarg [a+ brightred] + #set greencheck [a+ web-limegreen]\u2713[a] + set greencheck [a+ brightgreen]\u2713[a] foreach arg [dict get $spec_dict opt_names] { set arginfo [dict get $spec_dict arg_info $arg] @@ -779,7 +799,8 @@ tcl::namespace::eval punk::args { } - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + #$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 append errmsg [$t print] $t destroy @@ -798,7 +819,12 @@ tcl::namespace::eval punk::args { #Also,we're polite enough in the errorInfo, nothing wrong with a Clint Eastwood style errorCode ;) return -code error -errorcode {TCL WRONGARGS PUNK} $errmsg } - + + #todo - a version of get_dict that supports punk::lib::tstr templating + #rename get_dict + #provide ability to look up and reuse definitions from ids etc + # + #generally we expect values to contain leading dashes only if -- specified. Otherwise no reliable way determine difference between bad flags and values #If no eopts (--) specified we stop looking for opts at the first nondash encountered in a position we'd expect a dash - so without eopt, values could contain dashes - but not in first position after flags. #only supports -flag val pairs, not solo options @@ -849,7 +875,7 @@ tcl::namespace::eval punk::args { #this would be important in the case where the function to be wrapped has never been called - but the wrapper needs info about the downstream options #we would like to avoid the ugliness of trying to parse a proc body to scrape the specification. #we may still need to do a basic scan of the proc body to determine if it at least contains the string punk::args::get_dict - but that is slightly less odious. - error "unsupported" + error "unsupported number of arguments for punk::args::get_dict" set inopt 0 set k "" set i 0 @@ -887,8 +913,12 @@ tcl::namespace::eval punk::args { #for -multple true, we need to ensure we can differentiate between a default value and a first of many that happens to match the default. #-default value must not be appended to if argname not yet in flagsreceived + + #todo: -minmultiple -maxmultiple ? + set opts $opt_defaults if {[set eopts [lsearch -exact $rawargs "--"]] >= 0} { + lappend flagsreceived -- set values [lrange $rawargs $eopts+1 end] set arglist [lrange $rawargs 0 $eopts-1] set maxidx [expr {[llength $arglist]-1}] @@ -908,7 +938,7 @@ tcl::namespace::eval punk::args { #review - what if user sets first value that happens to match a default? if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt [list $flagval] } else { tcl::dict::lappend opts $fullopt $flagval } @@ -997,7 +1027,7 @@ tcl::namespace::eval punk::args { #review - what if user sets first value that happens to match a default? if {$fullopt ni $flagsreceived && [tcl::dict::exists $opt_defaults $fullopt] && ([tcl::dict::get $opt_defaults $fullopt] eq [tcl::dict::get $opts $fullopt])} { #first occurrence of this flag, whilst stored value matches default - tcl::dict::set opts $fullopt $flagval + tcl::dict::set opts $fullopt [list $flagval] } else { tcl::dict::lappend opts $fullopt $flagval } @@ -1079,7 +1109,7 @@ tcl::namespace::eval punk::args { if {[tcl::dict::get $arg_info $valname -multiple]} { if {[tcl::dict::exists $val_defaults $valname] && ([tcl::dict::get $val_defaults $valname] eq [tcl::dict::get $values_dict $valname])} { #current stored val equals defined default - don't include default in the list we build up - tcl::dict::set values_dict $valname $val + tcl::dict::set values_dict $valname [list $val] ;#important to treat first element as a list } else { tcl::dict::lappend values_dict $valname $val } @@ -1146,6 +1176,7 @@ tcl::namespace::eval punk::args { } + #todo - truncate/summarize values in error messages #todo - allow defaults outside of choices/ranges @@ -1189,7 +1220,7 @@ tcl::namespace::eval punk::args { package require punk::ansi set vlist_check [list] foreach e $vlist { - lappend vlist_check [punk::ansi::stripansi $e] + lappend vlist_check [punk::ansi::ansistrip $e] } } else { #validate_without_ansi 0 @@ -1205,6 +1236,9 @@ tcl::namespace::eval punk::args { } if {$is_default eq [llength $vlist]} { set is_default 1 + } else { + #important to set 0 here too e.g if only one element of many matches default + set is_default 0 } } #puts "argname:$argname v:$v is_default:$is_default" @@ -1214,6 +1248,32 @@ tcl::namespace::eval punk::args { if {$is_default == 0} { switch -- $type { any {} + list { + foreach e_check $vlist_check { + if {![tcl::string::is list -strict $e_check]} { + arg_error "Option $argname for [Get_caller] requires type 'list'. Received: '$e_check'" $argspecs $argname + } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minlen { + # -1 for disable is as good as zero + if {[llength $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -minlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname + } + } + -maxlen { + if {$checkval ne "-1"} { + if {[llength $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires list with -maxlen $checkval. Received len:[llength $e_check] value:'$e_check'" $argspecs $argname + } + } + } + } + } + } + } + } string { if {[tcl::dict::size $thisarg_checks]} { foreach e_check $vlist_check { @@ -1295,6 +1355,25 @@ tcl::namespace::eval punk::args { if {[llength $e_check] %2 != 0} { arg_error "Option $argname for [Get_caller] requires type 'dict' - must be key value pairs. Received: '$e_check'" $argspecs $argname } + if {[tcl::dict::size $thisarg_checks]} { + tcl::dict::for {checkopt checkval} $thisarg_checks { + switch -- $checkopt { + -minlen { + # -1 for disable is as good as zero + if {[tcl::dict::size $e_check] < $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -minlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname + } + } + -maxlen { + if {$checkval ne "-1"} { + if {[tcl::dict::size $e_check] > $checkval} { + arg_error "Option $argname for [Get_caller] requires dict with -maxlen $checkval. Received dict size:[dict size $e_check] value:'$e_check'" $argspecs $argname + } + } + } + } + } + } } } alnum - @@ -1369,7 +1448,7 @@ tcl::namespace::eval punk::args { } } if {$is_strip_ansi} { - set stripped_list [lmap e $vlist {punk::ansi::stripansi $e}] ;#no faster or slower, but more concise than foreach + set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach if {[tcl::dict::get $thisarg -multiple]} { if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { tcl::dict::set opts $argname $stripped_list diff --git a/src/bootsupport/modules/punk/char-0.1.0.tm b/src/bootsupport/modules/punk/char-0.1.0.tm index e8752c06..ed4b22e4 100644 --- a/src/bootsupport/modules/punk/char-0.1.0.tm +++ b/src/bootsupport/modules/punk/char-0.1.0.tm @@ -1950,7 +1950,7 @@ tcl::namespace::eval punk::char { #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { - # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" #} @@ -2057,7 +2057,7 @@ tcl::namespace::eval punk::char { #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { - # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" #} @@ -2161,7 +2161,7 @@ tcl::namespace::eval punk::char { #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { - # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" #} diff --git a/src/bootsupport/modules/punk/console-0.1.1.tm b/src/bootsupport/modules/punk/console-0.1.1.tm index 832232bd..3c64c7e3 100644 --- a/src/bootsupport/modules/punk/console-0.1.1.tm +++ b/src/bootsupport/modules/punk/console-0.1.1.tm @@ -51,7 +51,7 @@ namespace eval punk::console { variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. #-1 still evaluates to true - as the modern assumption for ansi availability is true #only false if ansi_available has been set 0 by test_can_ansi - #support stripansi for legacy windows terminals + #support ansistrip for legacy windows terminals # -- variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset @@ -780,7 +780,7 @@ namespace eval punk::console { #stdout variable ansi_wanted if {$ansi_wanted <= 0} { - puts -nonewline [punk::ansi::stripansiraw [::punk::ansi::a?]] + puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]] } else { tailcall ansi::a? {*}$args } @@ -806,7 +806,7 @@ namespace eval punk::console { proc code_a? {args} { variable ansi_wanted if {$ansi_wanted <= 0} { - return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] + return [punk::ansi::ansistripraw [::punk::ansi::a? {*}$args]] } else { tailcall ::punk::ansi::a? {*}$args } @@ -833,7 +833,7 @@ namespace eval punk::console { false - no { set ansi_wanted 0 - punk::ansi::sgr_cache clear + punk::ansi::sgr_cache -action clear } default { set ansi_wanted 2 @@ -859,7 +859,7 @@ namespace eval punk::console { if {$on} { if {$colour_disabled} { #change of state - punk::ansi::sgr_cache clear + punk::ansi::sgr_cache -action clear catch {punk::repl::reset_prompt} set colour_disabled 0 } @@ -867,7 +867,7 @@ namespace eval punk::console { #we don't disable a/a+ entirely - they must still emit underlines/bold/reverse if {!$colour_disabled} { #change of state - punk::ansi::sgr_cache clear + punk::ansi::sgr_cache -action clear catch {punk::repl::reset_prompt} set colour_disabled 1 } @@ -1811,7 +1811,6 @@ interp alias {} colour {} punk::console::colour interp alias {} ansi {} punk::console::ansi interp alias {} color {} punk::console::colour interp alias {} a+ {} punk::console::code_a+ -interp alias {} a= {} punk::console::code_a interp alias {} a {} punk::console::code_a interp alias {} a? {} punk::console::code_a? diff --git a/src/bootsupport/modules/punk/fileline-0.1.0.tm b/src/bootsupport/modules/punk/fileline-0.1.0.tm index 837b9821..7e1ee14c 100644 --- a/src/bootsupport/modules/punk/fileline-0.1.0.tm +++ b/src/bootsupport/modules/punk/fileline-0.1.0.tm @@ -318,7 +318,7 @@ namespace eval punk::fileline::class { package require overtype # will require punk::char and punk::ansi - if {"::punk::fileline::ansi::stripansi" ne [info commands ::punk::fileline::ansi::stripansi]} { + if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} { namespace eval ::punk::fileline::ansi { namespace import ::punk::ansi::* } @@ -334,7 +334,7 @@ namespace eval punk::fileline::class { } else { set ::punk::fileline::ansi::enabled 0 } - if {"::punk::fileline::stripansi" ne [info commands ::punk::fileline::stripansi]} { + if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { if {$::punk::fileline::ansi::enabled} { tailcall ::punk::fileline::ansi::a {*}$args @@ -349,9 +349,9 @@ namespace eval punk::fileline::class { return "" } } - proc ::punk::fileline::stripansi {str} { + proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::stripansi $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -560,7 +560,7 @@ namespace eval punk::fileline::class { set title_line "Line" #todo - use punk::char for unicode support of wide chars etc? set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]] - set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [stripansi $v]}]] + set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]] set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}] set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]] foreach row $result_list { @@ -1259,18 +1259,17 @@ namespace eval punk::fileline { #[para]The encoding used is as specified in the -encoding option - or from the Byte Order Mark (bom) at the beginning of the data #[para]For Tcl 8.6 - encodings such as utf-16le may not be available - so the bytes are swapped appropriately depending on the platform byteOrder and encoding 'unicode' is used. #[para]encoding defaults to utf-8 if no -encoding specified and no BOM was found - #[para]Specify -encoding binary to perform no encoding conversion #[para]Whether -encoding was specified or not - by default the BOM characters are not retained in the line-data #[para]If -includebom 1 is specified - the bom will be retained in the stored chunk and the data for line 1, but will undergo the same encoding transformation as the rest of the data #[para]The get_bomid method of the returned object will contain an identifier for any BOM encountered. #[para] e.g utf-8,utf-16be, utf-16le, utf-32be, utf32-le, SCSU, BOCU-1,GB18030, UTF-EBCDIC, utf-1, utf-7 - #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes (binary translation) + #[para]If the encoding specified in the BOM isn't recognised by Tcl - the resulting data is likely to remain as the raw bytes of whatever encoding that is. #[para]Currently only utf-8, utf-16* and utf-32* are properly supported even though the other BOMs are detected, reported via get_bomid, and stripped from the data. - #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding binary if this isn't suitable and you need to do your own processing of the raw data. + #[para]GB18030 falls back to cp936/gbk (unless a gb18030 encoding has been installed). Use -encoding iso8859-1 if this isn't suitable and you need to do your own processing of the bytes. set argument_specification { -file -default {} -type existingfile - -translation -default binary + -translation -default iso8859-1 -encoding -default "\uFFFF" -includebom -default 0 *values -min 0 -max 1 @@ -1712,7 +1711,7 @@ namespace eval punk::fileline::ansi { #*** !doctools #[call [fun ansi::a]] #[call [fun ansi::a+]] - #[call [fun ansi::stripansi]] + #[call [fun ansi::ansistrip]] #*** !doctools #[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}] diff --git a/src/bootsupport/modules/punk/lib-0.1.1.tm b/src/bootsupport/modules/punk/lib-0.1.1.tm index 3d0332b5..3a5764b5 100644 --- a/src/bootsupport/modules/punk/lib-0.1.1.tm +++ b/src/bootsupport/modules/punk/lib-0.1.1.tm @@ -66,34 +66,34 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::lib::class { - #*** !doctools - #[subsection {Namespace punk::lib::class}] - #[para] class definitions - if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} +#tcl::namespace::eval punk::lib::class { +# #*** !doctools +# #[subsection {Namespace punk::lib::class}] +# #[para] class definitions +# if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { +# #*** !doctools +# #[list_begin enumerated] +# +# # oo::class create interface_sample1 { +# # #*** !doctools +# # #[enum] CLASS [class interface_sample1] +# # #[list_begin definitions] +# +# # method test {arg1} { +# # #*** !doctools +# # #[call class::interface_sample1 [method test] [arg arg1]] +# # #[para] test method +# # puts "test: $arg1" +# # } +# +# # #*** !doctools +# # #[list_end] [comment {-- end definitions interface_sample1}] +# # } +# +# #*** !doctools +# #[list_end] [comment {--- end class enumeration ---}] +# } +#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::lib::ensemble { @@ -395,105 +395,896 @@ namespace eval punk::lib { } } - proc pdict {args} { + #experiment with equiv of js template literals with ${expression} in templates + #e.g tstr {This is the value of x in calling scope ${$x} !} + #e.g tstr -allowcommands {This is the value of x in calling scope ${[set x]} !} + #e.g tstr -allowcommands {This is the value of [lindex $x 0] in calling scope ${[lindex [set x] 0]} !} + proc tstr {args} { + set argd [punk::args::get_dict { + *proc -name punk::lib::tstr -help "A rough equivalent of js template literals" + -allowcommands -default 0 -type none -help "if -allowcommands is true placeholder can contain commands e.g {${plaintext1 [lindex $var 0] plaintext2}}" + -return -default list -choices {dict list string} + *values -min 1 -max 1 + templatestring -help "This argument should be a braced string containing placeholders such as ${$var} e.g {The value is ${$var}} + where $var will be substituted from the calling context + The placeholder itself can contain plaintext portions as well as variables. + It can contain commands in square brackets if -allowcommands is true" + } $args] + set templatestring [dict get $argd values templatestring] + set opt_allowcommands [dict get $argd opts -allowcommands] + set opt_return [dict get $argd opts -return] + set nocommands "-nocommands" + if {$opt_allowcommands == 1} { + set nocommands "" + } + + #set parts [_tstr_split $templatestring] + set parts [_parse_tstr_parts $templatestring] + set textchunks [list] + #set expressions [list] + set params [list] + set idx 0 + foreach {pt expression} $parts { + lappend textchunks $pt + incr idx ;#pt incr + + #ignore last expression + if {$idx == [llength $parts]} { + break + } + #lappend expressions $expression + lappend params [uplevel 1 [list subst {*}$nocommands $expression]] + + incr idx ;#expression incr + } + switch -- $opt_return { + dict { + return [dict create template $textchunks params $params] + } + list { + return [list $textchunks {*}$params] + } + string { + set out "" + foreach pt $textchunks param $params { + append out $pt $param + } + return $out + } + default { + } + } + } + #test single placeholder tstr args where single placeholder must be an int + proc tstr_test_one {args} { + set argd [punk::args::get_dict { + *proc -name tstr_test_one -help {An example/test of a function designed to be called with a js-style curly-braced Tstr. + example: + set id 2 + tstr_test_one {*}[Tstr {Select * from table where id = ${$id} and etc... ;}] + } + + *values -min 2 -max 2 + template -type list -minlen 2 -maxlen 2 -help "This could be supplied directly as a 2 element list of each half of the sql statement - + but the Tstr method above does this for you, and also passes in the id automatically" + + where -type int -help {Integer param for where clause. Tstr mechanism above will pass the id as the second parameter} + } $args] + set template [dict get $argd values template] + set where [dict get $argd values where] + set result [join [list [lindex $template 0] $where [lindex $template 1]] ""] + return $result + } + proc _parse_tstr_parts {templatestring} { + if {$templatestring eq ""} { + return [list] + } + set chars [split $templatestring ""] + set in_placeholder 0 + set tchars "" + set echars "" + set parts [list] + set i 0 + foreach ch $chars { + if {!$in_placeholder} { + set nextch [lindex $chars [expr {$i+1}]] + if {"$ch$nextch" eq "\$\{"} { + set in_placeholder 2 ;#2 to signify we just entered placeholder + lappend parts $tchars + set tchars "" + } else { + append tchars $ch + } + } else { + if {$ch eq "\}"} { + if {[tcl::info::complete $echars]} { + set in_placeholder 0 + lappend parts $echars + set echars "" + } else { + append echars $ch + } + } else { + if {$in_placeholder == 2} { + #skip opening bracket + set in_placeholder 1 + } else { + append echars $ch + } + } + } + incr i + } + if {$tchars ne ""} { + lappend parts $tchars + } + if {[llength $parts] % 2 == 0} { + #always trail with pt for consistency with _perlish_split method so we can test other mechanisms with odd-length pt/code../pt style list + lappend parts "" + } + return $parts + } + #based on punk::ansi::ta::_perlish_split + proc _tstr_split {text} { + if {$text eq ""} { + return {} + } + set list [list] + set start 0 + #ideally re should allow curlies within but we will probably need a custom parser to do it + #(js allows nested string interpolation) + #set re {\$\{[^\}]*\}} + set re {\$\{(?:(?!\$\{).)*\}} + + #eg regexp {\x1b(?:\(0(?:(?:(?!\x1b\(B).)*\x1b\(B)|\)0(?:(?:(?!\x1b\)B).)*\x1b\)B))} $code + + #We can get $matchEnd < $matchStart; we need to ensure there is an exit condition for non-greedy empty results REVIEW + while {[regexp -start $start -indices -- $re $text match]} { + lassign $match matchStart matchEnd + #puts "->start $start ->match $matchStart $matchEnd" + if {$matchEnd < $matchStart} { + puts "e:$matchEnd < s:$matchStart" + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::index $text $matchStart] + incr start + if {$start >= [tcl::string::length $text]} { + break + } + continue + } + lappend list [tcl::string::range $text $start $matchStart-1] [tcl::string::range $text $matchStart+2 $matchEnd-1] + set start [expr {$matchEnd+1}] + #? + if {$start >= [tcl::string::length $text]} { + break + } + } + return [lappend list [tcl::string::range $text $start end]] + } + + #get info about punk nestindex key ie type: list,dict,undetermined + proc nestindex_info {args} { set argd [punk::args::get_dict { + -parent -default "" + nestindex + } $args] + set opt_parent [dict get $argd opts -parent] + if {$opt_parent eq ""} { + set parent_type undetermined + } else { + set parent_type [nestindex_info -parent "" $opt_parent] ;#make sure we explicitly set parent of parent to empty so we don't just recurse forever doing nothing + } + + + } + + + proc pdict {args} { + if {[catch {package require punk::ansi} errM]} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } + set argspec [string map [list %sep% $sep] { *proc -name pdict -help {Print dict keys,values to channel (see also showdict)} + *opts -any 1 + #default separator to provide similarity to tcl's parray function - -separator -default " = " + -separator -default "%sep%" + -roottype -default "dict" + -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" + *values -min 1 -max -1 - dictvar -type string -help "name of dict variable" - patterns -type string -default * -multiple 1 - } $args] + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + Segments are classified into list,dict and string operations. + Leading % indicates a string operation - e.g %# gives string length + A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' + The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. + e.g1 pdict env */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segement in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + + The pdict function operates on variable names - passing the value to the showdict function which operates on values + } + }] + #puts stderr "$argspec" + set argd [punk::args::get_dict $argspec $args] + set opts [dict get $argd opts] set dvar [dict get $argd values dictvar] set patterns [dict get $argd values patterns] - set dvalue [uplevel 1 [list set $dvar]] + set isarray [uplevel 1 [list array exists $dvar]] + if {$isarray} { + set dvalue [uplevel 1 [list array get $dvar]] + if {![dict exists $opts -keytemplates]} { + set arrdisplay [string map [list %dvar% $dvar] {${[if {[lindex $key 1] eq "query"} {val "%dvar% [lindex $key 0]"} {val "%dvar%($key)"}]}}] + dict set opts -keytemplates [list $arrdisplay] + } + dict set opts -keysorttype dictionary + } else { + set dvalue [uplevel 1 [list set $dvar]] + } showdict {*}$opts $dvalue {*}$patterns } + + #TODO - much. + #showdict needs to be able to show different branches which share a root path + #e.g show key a1/b* in its entirety along with a1/c* - (or even exact duplicates) + # - specify ansi colour per pattern so different branches can be highlighted? + # - ideally we want to be able to use all the dict & list patterns from the punk pipeline system eg @head @tail # (count) etc + # - The current version is incomplete but passably usable. + # - Copy proc and attempt rework so we can get back to this as a baseline for functionality proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) - set argd [punk::args::get_dict { - *id punk::lib::pdict - *proc -name punk::lib::pdict -help "display dictionary keys and values" + #set sep " [a+ Web-seagreen]=[a] " + if {[catch {package require punk::ansi} errM]} { + set sep " = " + set RST "" + set sep_mismatch " mismatch " + } else { + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " ;#stick to basic default colours for wider terminal support + set RST [punk::ansi::a] + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch[punk::ansi::a] " + } + package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + *id punk::lib::showdict + *proc -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} -channel -default none -trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line. This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding " - -separator -default " " -help "Separator column between keys and values" - -ansibase_keys -default "" - -ansibase_values -default "" + -separator -default {%sep%} -help "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help "Separator to use when patterns mismatch" + -roottype -default "dict" -help "list,dict,string" + -ansibase_keys -default "" -help "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} + -ansibase_values -default "" + -keytemplates -default {${$key}} -type list -help "list of templates for keys at each level" -keysorttype -default "none" -choices {none dictionary ascii integer real} - -keysortdirection -default ascending -choices {ascending descending} + -keysortdirection -default increasing -choices {increasing decreasing} *values -min 1 -max -1 - dictvalue -type dict -help "dict value" - patterns -default * -type string -multiple 1 -help "key or key glob pattern" - } $args] + dictvalue -type list -help "dict or list value" + patterns -default "*" -type string -multiple 1 -help "key or key glob pattern" + }] $args] set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] set opt_keysorttype [dict get $argd opts -keysorttype] set opt_keysortdirection [dict get $argd opts -keysortdirection] set opt_trimright [dict get $argd opts -trimright] - set opt_ansibase_key [dict get $argd opts -ansibase_keys] - set opt_ansibase_value [dict get $argd opts -ansibase_values] + set opt_keytemplates [dict get $argd opts -keytemplates] + set opt_ansibase_keys [dict get $argd opts -ansibase_keys] + set opt_ansibase_values [dict get $argd opts -ansibase_values] set opt_return [dict get $argd opts -return] + set opt_roottype [dict get $argd opts -roottype] + set opt_structure [dict get $argd opts -substructure] set dval [dict get $argd values dictvalue] set patterns [dict get $argd values patterns] set result "" + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated + set pattern_next_substructure [dict create] + set pattern_this_structure [dict create] + + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + set filtered_keys [list] - foreach p $patterns { - lappend filtered_keys {*}[dict keys $dval $p] - } - if {$opt_keysorttype eq "none"} { - #we can only get duplicate keys if there are multiple patterns supplied - #ignore keysortdirection - doesn't apply - if {[llength $patterns] > 1} { - #order-maintaining (order of keys as they appear in dict) - set filtered_keys [punk::lib::lunique $filtered_keys] + if {$opt_roottype in {dict list string}} { + #puts "getting keys for roottype:$opt_roottype" + if {[llength $dval]} { + set re_numdashnum {^([-+]{0,1}\d+)-([-+]{0,1}\d+)$} + set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} + foreach pattern_nest $patterns { + set keyset [list] + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protext commas that appear within quotes) + set patterninfo [punk::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string + } + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + puts ---->HERE<---- + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + @k@* - @K@* { + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict + } + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string + lappend keyset $p + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + lappend keyset $p + lappend keyset_structure list + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds + if {${lower_resolve} == -1} { + #lower bound is above upper list range + #match with decreasing indices is still possible + set lower [expr {[llength $dval]-1}] ;#set to max + } elseif {$lower_resolve == -2} { + set lower 0 + } else { + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve $dval $b] + if {$upper == -2} { + #upper bound is below list range - + if {$lower_resolve >=-1} { + set upper 0 + } else { + continue + } + } elseif {$upper == -1} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists + } + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset [list @$p query] + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + } else { + puts stderr "list: unrecognised pattern $p" + } + } + } + } + } + } + + # -- --- --- --- + #check next pattern-segment for substructure type to use + # -- --- --- --- + set substructure "" + set pnext [lindex $segments 1] + set patterninfo [punk::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + # single type in segment e.g /@@something/ + switch -exact $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + } + } + } + } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list + } + #puts "--pattern_nest: $pattern_nest substructure: $substructure" + dict set pattern_next_substructure $pattern_nest $substructure + # -- --- --- --- + + if {$opt_keysorttype ne "none"} { + set int_keyset 1 + foreach k $keyset { + if {![string is integer -strict $k]} { + set int_keyset 0 + break + } + } + if {$int_keyset} { + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] + } else { + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] + } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] + } + + foreach k $keyset { + lappend pattern_key_index $pattern_nest + } + + lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure + + #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" + } } + #puts stderr "[dict get $pattern_this_structure $pattern_nest] keys: $filtered_keys" } else { - set filtered_keys [lsort -unique -$opt_keysorttype $opt_keysortdirection $filtered_keys] + puts stdout "unrecognised roottype: $opt_roottype" + return $dval } if {[llength $filtered_keys]} { #both keys and values could have newline characters. #simple use of 'format' won't cut it for more complex dict keys/values #use block::width or our columns won't align in some cases - set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] - set RST [a] switch -- $opt_return { "tailtohead" { #last line of key is side by side (possibly with separator) with first line of value #This is more intelligible when terminal wrapping occurs - and is closer to what happens with parray multiline keys and values #we still pad the key to max width so that the separator appears in the same column - which in the case of wide keys could cause that to wrap for all entries - foreach key $filtered_keys { - lassign [textblock::size $key] _kw kwidth _kh kheight - lassign [textblock::size [dict get $dval $key]] _vw vwidth _vh vheight - set totalheight [expr {$kheight + $vheight -1}] - set blanks_above [string repeat \n [expr {$kheight -1}]] - set blanks_below [string repeat \n [expr {$vheight -1}]] - set sepwidth [textblock::width $opt_sep] - #append result [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep $opt_ansibase_value[dict get $dval $key]$RST \n - set kblock [textblock::pad $opt_ansibase_key$key$RST$blanks_below -width $maxl] - set sblock [textblock::pad $blanks_above$opt_sep$blanks_below -width $sepwidth] - set vblock $blanks_above$opt_ansibase_value[dict get $dval $key]$RST - #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace - append result [textblock::join_basic $kblock $sblock $vblock] \n + + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt {${$key}} + } + #set display_keys [lmap k $filtered_keys {tcl::string::map [list %k% $k] $kt}] + set display_keys [lmap key $filtered_keys {tstr -ret string -allowcommands $kt}] + set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] + + set kidx 0 + set last_hidekey 0 + foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" + set hidekey 0 + set pattern_nest [lindex $pattern_key_index $kidx] + set pattern_nest_list [split $pattern_nest /] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" + + set is_match 1 ;#whether to display the normal separator or bad-match separator + switch -- $this_type { + dict { + #todo? - slower lsearch if -dupes 1 flag set so we can display duplicate 'keys' if var not a proper dict but rather a dict-shaped list that we want to display as a dict + # - default highlight dupes (ansi underline?) + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + % thisval.= $qry= $dval + } else { + set thisval [tcl::dict::get $dval $key] + } + + #set substructure [lrange $opt_structure 1 end] + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + + set subansibasekeys [lrange $opt_ansibase_keys 1 end] + set nextkeytemplates [lrange $opt_keytemplates 1 end] + #dict set nextopts -substructure $nextsub + dict set nextopts -keytemplates $nextkeytemplates + dict set nextopts -ansibase_keys $subansibasekeys + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + #puts stderr "showdict {*}$nextopts $thisval [lindex $args end]" + + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + #puts stderr ">>> nextpatterns:'$nextpatterns' nextopts:'$nextopts'" + set is_match 0 + } + } + } + list { + if {[string is integer -strict $key]} { + set thisval [lindex $dval $key] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + % thisval.= $qry= $dval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + set nextopts [dict get $argd opts] + + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + #if {![llength $nextpatterns]} { + # set nextpatterns * + #} + if {[llength $nextpatterns]} { + if {[catch { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } errMsg]} { + set is_match 0 + } + } + } + string { + set hidekey 1 + if {$key eq "%string"} { + set hidekey 1 + set thisval $dval + } elseif {$key eq "%ansiview"} { + set thisval [ansistring VIEW -lf 1 $dval] + } elseif {$key eq "%ansiviewstyle"} { + set thisval [ansistring VIEWSTYLE -lf 1 $dval] + } elseif {[string match *lpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] + } elseif {[string match *rpad-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + $extra}] + set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] + } else { + if {[lindex $key 1] eq "query"} { + set qry [lindex $key 0] + } else { + set qry $key + } + set thisval $dval + if {[string index $key 0] ne "%"} { + set key %$key + } + % thisval.= $key= $thisval + } + + set nextpatterns [list] + #which pattern nest applies to this branch + set nextsub [dict get $pattern_next_substructure $pattern_nest] + if {[llength $pattern_nest_list]} { + set nest [lrange $pattern_nest_list 1 end] + lappend nextpatterns {*}[join $nest /] + } + #set nextopts [dict get $argd opts] + dict set nextopts -roottype $nextsub + dict set nextopts -channel none + + if {[llength $nextpatterns]} { + set thisval [showdict {*}$nextopts -- $thisval {*}$nextpatterns] + } + + } + } + if {$this_type eq "string" && $hidekey} { + lassign [textblock::size $thisval] _vw vwidth _vh vheight + #set blanks_above [string repeat \n [expr {$kheight -1}]] + set vblock $opt_ansibase_values$thisval$RST + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" + } else { + set ansibase_key [lindex $opt_ansibase_keys 0] + + lassign [textblock::size $keydisplay] _kw kwidth _kh kheight + lassign [textblock::size $thisval] _vw vwidth _vh vheight + + set totalheight [expr {$kheight + $vheight -1}] + set blanks_above [string repeat \n [expr {$kheight -1}]] + set blanks_below [string repeat \n [expr {$vheight -1}]] + + if {$is_match} { + set use_sep $opt_sep + } else { + set use_sep $opt_mismatch_sep + } + + + set sepwidth [textblock::width $use_sep] + set kblock [textblock::pad $ansibase_key$keydisplay$RST$blanks_below -width $maxl] + set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] + set vblock $blanks_above$opt_ansibase_values$thisval$RST + #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } + append result [textblock::join_basic -- $kblock $sblock $vblock] \n + } + set last_hidekey $hidekey + incr kidx } } "sidebyside" { + #todo #This is nice for multiline keys and values of reasonable length, will produce unintuitive results when line-wrapping occurs. #use ansibase_key etc to make the output more comprehensible in that situation. #This is why it is not the default. (review - terminal width detection and wrapping?) + set maxl [::tcl::mathfunc::max {*}[lmap v $filtered_keys {textblock::width $v}]] foreach key $filtered_keys { + set kt [lindex $opt_keytemplates 0] + if {$kt eq ""} { + set kt "%k%" + } + set keydisplay $opt_ansibase_keys[string map [list %k% $key] $kt]$RST #append result [format "%-*s = %s" $maxl $key [dict get $dval $key]] \n #differing height blocks (ie ragged) so we need a full textblock::join rather than join_basic - append result [textblock::join -- [textblock::pad $opt_ansibase_key$key$RST -width $maxl] $opt_sep "$opt_ansibase_value[dict get $dval $key]$RST"] \n + append result [textblock::join -- [textblock::pad $keydisplay -width $maxl] $opt_sep "$opt_ansibase_values[dict get $dval $key]$RST"] \n } } } @@ -765,19 +1556,23 @@ namespace eval punk::lib { #[para]This means the proc may be called with something like $x+2 end-$y etc #[para]Sometimes the actual integer index is desired. #[para]We want to resolve the index used, without passing arbitrary expressions into the 'expr' function - which could have security risks. - #[para]lindex_resolve will parse the index expression and return -1 if the supplied index expression is out of bounds for the supplied list. + #[para]lindex_resolve will parse the index expression and return: + #[para] a) -2 if the supplied index expression is below the lower bound for the supplied list. (< 0) + #[para] b) -1 if the supplied index expression is above the upper bound for the supplied list. (> end) #[para]Otherwise it will return an integer corresponding to the position in the list. + #[para]This is in stark contrast to Tcl list function indices which will return empty strings for out or bounds indices, or in the case of lrange, return results anyway. #[para]Like Tcl list commands - it will produce an error if the form of the index is not acceptable #Note that for an index such as $x+1 - we never see the '$x' as it is substituted in the calling command. We will get something like 10+1 - which we will resolve (hopefully safely) with expr - if {![llength $list]} { - return -1 - } + #if {![llength $list]} { + # #review + # return ??? + #} set index [tcl::string::map {_ {}} $index] ;#forward compatibility with integers such as 1_000 if {[string is integer -strict $index]} { #can match +i -i if {$index < 0} { - return -1 + return -2 } elseif {$index >= [llength $list]} { return -1 } else { @@ -794,16 +1589,28 @@ namespace eval punk::lib { return -1 } } else { - set offset 0 + #end + set index [expr {[llength $list]-1}] + if {$index < 0} { + #special case - end with empty list - treat end like a positive number out of bounds + return -1 + } else { + return $index + } } - #by now, if op = + then offset = 0 so we only need to handle the minus case if {$offset == 0} { set index [expr {[llength $list]-1}] + if {$index < 0} { + return -1 ;#special case + } else { + return $index + } } else { + #by now, if op = + then offset = 0 so we only need to handle the minus case set index [expr {([llength $list]-1) - $offset}] } if {$index < 0} { - return -1 + return -2 } else { return $index } @@ -823,16 +1630,25 @@ namespace eval punk::lib { } else { error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?" } - if {$index < 0 || $index >= [llength $list]} {return -1} + if {$index < 0} { + return -2 + } elseif {$index >= [llength $list]} { + return -1 + } return $index } } } proc lindex_resolve2 {list index} { - set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. - for {set i 0} {$i < [llength $list]} {incr i} { - lappend indices $i - } + #set indices [list] ;#building this may be somewhat expensive in terms of storage and compute for large lists - we could use lseq in Tcl 8.7+ but that's likely unavailable here. + #for {set i 0} {$i < [llength $list]} {incr i} { + # lappend indices $i + #} + if {[llength $list]} { + set indices [punk::lib::range 0 [expr {[llength $list]-1}]] ;# uses lseq if available, has fallback. + } else { + set indices [list] + } set idx [lindex $indices $index] if {$idx eq ""} { return -1 diff --git a/src/bootsupport/modules/punk/mix/base-0.1.tm b/src/bootsupport/modules/punk/mix/base-0.1.tm index 6eec4d8d..8a4456d1 100644 --- a/src/bootsupport/modules/punk/mix/base-0.1.tm +++ b/src/bootsupport/modules/punk/mix/base-0.1.tm @@ -351,8 +351,14 @@ namespace eval punk::mix::base { continue } set testfolder [file join $candidate src $sub] - set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] - if {[llength $tmfiles]} { + #ensure that if src/modules exists - it is always included even if empty + if {[string tolower $sub] eq "modules"} { + lappend tm_folders $testfolder + continue + } + #set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] + #set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*] + if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} { lappend tm_folders $testfolder } } @@ -428,9 +434,10 @@ namespace eval punk::mix::base { } #crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) + # - try builtin zlib crc instead? #sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. #adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) - #sha1 as at 2023 seems a good default + #sha1 as at 2023 seems a reasonable default proc cksum_algorithms {} { variable sha3_implementation #sha2 is an alias for sha256 @@ -459,10 +466,16 @@ namespace eval punk::mix::base { #adler32 via file-slurp proc cksum_adler32_file {filename} { package require zlib; #should be builtin anyway - set data [punk::mix::util::fcat -translation binary $filename] + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } + #zlib crc vie file-slurp + proc cksum_crc_file {filename} { + package require zlib + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] + zlib crc $data + } #required to be able to accept relative paths @@ -614,6 +627,9 @@ namespace eval punk::mix::base { package require cksum ;#tcllib set cksum_command [list crc::cksum -format 0x%X -file] } + crc { + set cksum_command [list cksum_crc_file] + } adler32 { set cksum_command [list cksum_adler32_file] } diff --git a/src/modules/punk/mix/cli-0.3.tm b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm similarity index 62% rename from src/modules/punk/mix/cli-0.3.tm rename to src/bootsupport/modules/punk/mix/cli-0.3.1.tm index db21a253..5843789f 100644 --- a/src/modules/punk/mix/cli-0.3.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.1.tm @@ -7,7 +7,7 @@ # (C) 2023 # # @@ Meta Begin -# Application punk::mix::cli 0.3 +# Application punk::mix::cli 0.3.1 # Meta platform tcl # Meta license # @@ Meta End @@ -18,6 +18,7 @@ ## Requirements ##e.g package require frobz package require punk::repo +package require punk::ansi package require punkcheck ;#checksum and/or timestamp records @@ -202,7 +203,8 @@ namespace eval punk::mix::cli { proc module_types {} { #first in list is default for unspecified -type when creating new module - return [list plain tarjar zipkit] + #return [list plain tarjar zipkit] + return [list plain tarjar zip] } proc validate_modulename {modulename args} { @@ -401,7 +403,7 @@ namespace eval punk::mix::cli { proc build_modules_from_source_to_base {srcdir basedir args} { - set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. + set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. set defaults [list\ -installer punk::mix::cli::build_modules_from_source_to_base\ -call-depth-internal 0\ @@ -409,6 +411,7 @@ namespace eval punk::mix::cli { -subdirlist {}\ -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ + -podglob #modpod-*\ ] set opts [dict merge $defaults $args] @@ -420,6 +423,7 @@ namespace eval punk::mix::cli { set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] + set podglob [dict get $opts -podglob] if {![string match "*.tm" $fileglob]} { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } @@ -475,99 +479,344 @@ namespace eval punk::mix::cli { #---------------------------------------- - + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } set did_skip 0 ;#flag for stdout/stderr formatting only - foreach m $src_modules { + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + set is_interesting 0 if {[string match "foobar" $current_source_dir]} { set is_interesting 1 } if {$is_interesting} { - puts "build_modules_from_source_to_base >>> module $current_source_dir/$m" + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" } - set fileparts [split [file rootname $m] -] - set tmfile_versionsegment [lindex $fileparts end] - if {$tmfile_versionsegment eq $magicversion} { - #rebuild the .tm from the #tarjar - set basename [join [lrange $fileparts 0 end-1] -] - set versionfile $current_source_dir/$basename-buildversion.txt - set versionfiledata "" - if {![file exists $versionfile]} { - puts stderr "\nWARNING: Missing buildversion text file: $versionfile" - puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" - set module_build_version "0.1" - } else { - set fd [open $versionfile r] - set versionfiledata [read $fd]; close $fd - set ln0 [lindex [split $versionfiledata \n] 0] - set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] - if {![util::is_valid_tm_version $ln0]} { - puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" - exit 3 + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + exit 1 + } + switch -- $modtype { + pod { + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment } - set module_build_version $ln0 - } - - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #TODO + set buildfolder $current_source_dir/_build file mkdir $buildfolder + # -- --- + set config [dict create\ + -glob *\ + -max_depth 100\ + ] + # -max_depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set had_error 0 + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + if 0 { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files + } + #zipfs mkzip does exactly what we need anyway in this case + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - } else { - - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? - set tmfile $basedir/_build/$basename-$module_build_version.tm - file mkdir $basedir/_build - file delete -force $basedir/_build/#tarjar-$basename-$module_build_version - file delete -force $tmfile - - - file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version - # - #bsdtar doesn't seem to work.. or I haven't worked out the right options? - #exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version - package require tar - tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version - if {![file exists $tmfile]} { - puts stdout "ERROR: Failed to build tarjar file $tmfile" - exit 4 - } - #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm - #file copy -force $tmfile $target - - lappend module_list $tmfile - } else { - #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. - if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { - puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED } + $build_event destroy + $build_installer destroy - #------------------------------ - # - #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] - #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $versionfile - $event targetset_addsource $current_source_dir/$m + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + file copy -force $modulefile $target_module_dir + puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } else { + puts -nonewline stderr "." + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + tarjar { + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar + } + file { + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #set basename [join [lrange $fileparts 0 end-1] -] + set versionfile $current_source_dir/$basename-buildversion.txt + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + #rebuild the .tm from the #tarjar + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + + } else { + + } + #REVIEW - should be in same structure/depth as $target_module_dir in _build? + + #TODO + set buildfolder $current_sourcedir/_build + file mkdir $buildfolder + + set tmfile $buildfolder/$basename-$module_build_version.tm + file delete -force $buildfolder/#tarjar-$basename-$module_build_version + file delete -force $tmfile + + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + # + #bsdtar doesn't seem to work.. or I haven't worked out the right options? + #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + package require tar + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + if {![file exists $tmfile]} { + puts stdout "ERROR: failed to build tarjar file $tmfile" + exit 4 + } + #copy the file? + #set target $target_module_dir/$basename-$module_build_version.tm + #file copy -force $tmfile $target + + lappend module_list $tmfile + } else { + #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. + if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { + puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + } + + #------------------------------ + # + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $versionfile + $event targetset_addsource $current_source_dir/$m + + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + set target $target_module_dir/$basename-$module_build_version.tm + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" + set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $target w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + #file copy -force $srcdir/$m $target + lappend module_list $target + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK + } else { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + } + + continue + } + ##------------------------------ + ## + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] #set changed_list [list] ## -- --- --- --- --- --- - #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] - #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - ## -- --- --- --- --- --- #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] ## -- --- --- --- --- --- #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] - - + #---------- + $event targetset_init INSTALL $target_module_dir/$m + $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ @@ -576,85 +825,27 @@ namespace eval punk::mix::cli { #set file_record [punkcheck::installfile_started_install $basedir $file_record] $event targetset_started # -- --- --- --- --- --- - set target $target_module_dir/$basename-$module_build_version.tm if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" - set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd - set data [string map [list $magicversion $module_build_version] $data] - set fdout [open $target w] - fconfigure $fdout -translation binary - puts -nonewline $fdout $data - close $fdout - #file copy -force $srcdir/$m $target - lappend module_list $target + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" # -- --- --- --- --- --- #set file_record [punkcheck::installfile_finished_install $basedir $file_record] - $event targetset_end OK + $event targetset_end OK -note "already versioned module" } else { - if {$is_interesting} { - puts stdout "skipping module $current_source_dir/$m - no change in sources detected" - } puts -nonewline stderr "." set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $event targetset_end SKIPPED } - - #------------------------------ - } - - continue - } - - - if {![util::is_valid_tm_version $tmfile_versionsegment]} { - #last segment doesn't look even slightly versiony - fail. - puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." - exit 1 } + } ;#end dict for {modpath modinfo} $process_modules - ##------------------------------ - ## - #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] - #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - #set changed_list [list] - ## -- --- --- --- --- --- - #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] - #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - ## -- --- --- --- --- --- - #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] - #set changed_list [dict get $changed_unchanged changed] - - #---------- - $event targetset_init INSTALL $target_module_dir/$m - $event targetset_addsource $current_source_dir/$m - if {\ - [llength [dict get [$event targetset_source_changes] changed]]\ - || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ - } { - - #set file_record [punkcheck::installfile_started_install $basedir $file_record] - $event targetset_started - # -- --- --- --- --- --- - if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $current_source_dir/$m - file copy -force $current_source_dir/$m $target_module_dir - puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" - # -- --- --- --- --- --- - #set file_record [punkcheck::installfile_finished_install $basedir $file_record] - $event targetset_end OK -note "already versioned module" - } else { - puts -nonewline stderr "." - set did_skip 1 - if {$is_interesting} { - puts stderr "$current_source_dir/$m [$event targetset_source_changes]" - } - #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] - $event targetset_end SKIPPED - } - } if {$CALLDEPTH >= $max_depth} { set subdirs [list] } else { @@ -680,6 +871,7 @@ namespace eval punk::mix::cli { -subdirlist [list {*}$subdirlist $d]\ -punkcheck_eventobj $event\ -glob $fileglob\ + -podglob $podglob\ ] } if {$did_skip} { @@ -931,6 +1123,6 @@ namespace eval punk::mix::cli { ## Ready package provide punk::mix::cli [namespace eval punk::mix::cli { variable version - set version 0.3 + set version 0.3.1 }] return diff --git a/src/bootsupport/modules/punk/mix/cli-0.3.tm b/src/bootsupport/modules/punk/mix/cli-0.3.tm index db21a253..263ccc96 100644 --- a/src/bootsupport/modules/punk/mix/cli-0.3.tm +++ b/src/bootsupport/modules/punk/mix/cli-0.3.tm @@ -18,6 +18,7 @@ ## Requirements ##e.g package require frobz package require punk::repo +package require punk::ansi package require punkcheck ;#checksum and/or timestamp records @@ -202,7 +203,8 @@ namespace eval punk::mix::cli { proc module_types {} { #first in list is default for unspecified -type when creating new module - return [list plain tarjar zipkit] + #return [list plain tarjar zipkit] + return [list plain tarjar zip] } proc validate_modulename {modulename args} { @@ -401,7 +403,7 @@ namespace eval punk::mix::cli { proc build_modules_from_source_to_base {srcdir basedir args} { - set antidir [list "#*" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders we don't want to search in. + set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. set defaults [list\ -installer punk::mix::cli::build_modules_from_source_to_base\ -call-depth-internal 0\ @@ -409,6 +411,7 @@ namespace eval punk::mix::cli { -subdirlist {}\ -punkcheck_eventobj "\uFFFF"\ -glob *.tm\ + -podglob #modpod-*\ ] set opts [dict merge $defaults $args] @@ -420,6 +423,7 @@ namespace eval punk::mix::cli { set subdirlist [dict get $opts -subdirlist] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set fileglob [dict get $opts -glob] + set podglob [dict get $opts -podglob] if {![string match "*.tm" $fileglob]} { error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." } @@ -475,99 +479,344 @@ namespace eval punk::mix::cli { #---------------------------------------- - + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } set did_skip 0 ;#flag for stdout/stderr formatting only - foreach m $src_modules { + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + set is_interesting 0 if {[string match "foobar" $current_source_dir]} { set is_interesting 1 } if {$is_interesting} { - puts "build_modules_from_source_to_base >>> module $current_source_dir/$m" + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" } - set fileparts [split [file rootname $m] -] - set tmfile_versionsegment [lindex $fileparts end] - if {$tmfile_versionsegment eq $magicversion} { - #rebuild the .tm from the #tarjar - set basename [join [lrange $fileparts 0 end-1] -] - set versionfile $current_source_dir/$basename-buildversion.txt - set versionfiledata "" - if {![file exists $versionfile]} { - puts stderr "\nWARNING: Missing buildversion text file: $versionfile" - puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" - set module_build_version "0.1" - } else { - set fd [open $versionfile r] - set versionfiledata [read $fd]; close $fd - set ln0 [lindex [split $versionfiledata \n] 0] - set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] - if {![util::is_valid_tm_version $ln0]} { - puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" - exit 3 + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + exit 1 + } + switch -- $modtype { + pod { + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment } - set module_build_version $ln0 - } - - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { - #TODO + set buildfolder $current_source_dir/_build file mkdir $buildfolder + # -- --- + set config [dict create\ + -glob *\ + -max_depth 100\ + ] + # -max_depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set had_error 0 + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + if 0 { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files + } + #zipfs mkzip does exactly what we need anyway in this case + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } - if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { - } else { - - } - #REVIEW - should be in same structure/depth as $target_module_dir in _build? - set tmfile $basedir/_build/$basename-$module_build_version.tm - file mkdir $basedir/_build - file delete -force $basedir/_build/#tarjar-$basename-$module_build_version - file delete -force $tmfile - - - file copy -force $current_source_dir/#tarjar-$basename-$magicversion $basedir/_build/#tarjar-$basename-$module_build_version - # - #bsdtar doesn't seem to work.. or I haven't worked out the right options? - #exec tar -cvf $basedir/_build/$basename-$module_build_version.tm $basedir/_build/#tarjar-$basename-$module_build_version - package require tar - tar::create $tmfile $basedir/_build/#tarjar-$basename-$module_build_version - if {![file exists $tmfile]} { - puts stdout "ERROR: Failed to build tarjar file $tmfile" - exit 4 - } - #copy the file? - #set target $target_module_dir/$basename-$module_build_version.tm - #file copy -force $tmfile $target - - lappend module_list $tmfile - } else { - #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. - if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { - puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED } + $build_event destroy + $build_installer destroy - #------------------------------ - # - #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] - #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm - $event targetset_addsource $versionfile - $event targetset_addsource $current_source_dir/$m + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + file copy -force $modulefile $target_module_dir + puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } else { + puts -nonewline stderr "." + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + tarjar { + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar + } + file { + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #set basename [join [lrange $fileparts 0 end-1] -] + set versionfile $current_source_dir/$basename-buildversion.txt + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + #rebuild the .tm from the #tarjar + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + + } else { + + } + #REVIEW - should be in same structure/depth as $target_module_dir in _build? + + #TODO + set buildfolder $current_sourcedir/_build + file mkdir $buildfolder + + set tmfile $buildfolder/$basename-$module_build_version.tm + file delete -force $buildfolder/#tarjar-$basename-$module_build_version + file delete -force $tmfile + + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + # + #bsdtar doesn't seem to work.. or I haven't worked out the right options? + #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + package require tar + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + if {![file exists $tmfile]} { + puts stdout "ERROR: failed to build tarjar file $tmfile" + exit 4 + } + #copy the file? + #set target $target_module_dir/$basename-$module_build_version.tm + #file copy -force $tmfile $target + + lappend module_list $tmfile + } else { + #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. + if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { + puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + } + + #------------------------------ + # + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $versionfile + $event targetset_addsource $current_source_dir/$m + + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + set target $target_module_dir/$basename-$module_build_version.tm + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" + set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $target w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + #file copy -force $srcdir/$m $target + lappend module_list $target + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK + } else { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + } + + continue + } + ##------------------------------ + ## + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] #set changed_list [list] ## -- --- --- --- --- --- - #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] - #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - ## -- --- --- --- --- --- #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] ## -- --- --- --- --- --- #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] #set changed_list [dict get $changed_unchanged changed] - - + #---------- + $event targetset_init INSTALL $target_module_dir/$m + $event targetset_addsource $current_source_dir/$m if {\ [llength [dict get [$event targetset_source_changes] changed]]\ || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ @@ -576,85 +825,27 @@ namespace eval punk::mix::cli { #set file_record [punkcheck::installfile_started_install $basedir $file_record] $event targetset_started # -- --- --- --- --- --- - set target $target_module_dir/$basename-$module_build_version.tm if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" - set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd - set data [string map [list $magicversion $module_build_version] $data] - set fdout [open $target w] - fconfigure $fdout -translation binary - puts -nonewline $fdout $data - close $fdout - #file copy -force $srcdir/$m $target - lappend module_list $target + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" # -- --- --- --- --- --- #set file_record [punkcheck::installfile_finished_install $basedir $file_record] - $event targetset_end OK + $event targetset_end OK -note "already versioned module" } else { - if {$is_interesting} { - puts stdout "skipping module $current_source_dir/$m - no change in sources detected" - } puts -nonewline stderr "." set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] $event targetset_end SKIPPED } - - #------------------------------ - } - - continue - } - - - if {![util::is_valid_tm_version $tmfile_versionsegment]} { - #last segment doesn't look even slightly versiony - fail. - puts stderr "ERROR: Unable to confirm file $current_source_dir/$m is a reasonably versioned .tm module - ABORTING." - exit 1 } + } ;#end dict for {modpath modinfo} $process_modules - ##------------------------------ - ## - #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] - #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] - #set changed_list [list] - ## -- --- --- --- --- --- - #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] - #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] - ## -- --- --- --- --- --- - #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] - #set changed_list [dict get $changed_unchanged changed] - - #---------- - $event targetset_init INSTALL $target_module_dir/$m - $event targetset_addsource $current_source_dir/$m - if {\ - [llength [dict get [$event targetset_source_changes] changed]]\ - || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ - } { - - #set file_record [punkcheck::installfile_started_install $basedir $file_record] - $event targetset_started - # -- --- --- --- --- --- - if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} - lappend module_list $current_source_dir/$m - file copy -force $current_source_dir/$m $target_module_dir - puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" - # -- --- --- --- --- --- - #set file_record [punkcheck::installfile_finished_install $basedir $file_record] - $event targetset_end OK -note "already versioned module" - } else { - puts -nonewline stderr "." - set did_skip 1 - if {$is_interesting} { - puts stderr "$current_source_dir/$m [$event targetset_source_changes]" - } - #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] - $event targetset_end SKIPPED - } - } if {$CALLDEPTH >= $max_depth} { set subdirs [list] } else { @@ -680,6 +871,7 @@ namespace eval punk::mix::cli { -subdirlist [list {*}$subdirlist $d]\ -punkcheck_eventobj $event\ -glob $fileglob\ + -podglob $podglob\ ] } if {$did_skip} { diff --git a/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm index 8ed735c1..c6c83b69 100644 --- a/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/debug-0.1.0.tm @@ -31,7 +31,7 @@ namespace eval punk::mix::commandset::debug { set out "" puts stdout "find_repos output:" set pathinfo [punk::repo::find_repos [pwd]] - pdict $pathinfo + pdict pathinfo set projectdir [dict get $pathinfo closest] set modulefolders [lib::find_source_module_paths $projectdir] @@ -39,7 +39,7 @@ namespace eval punk::mix::commandset::debug { set template_base_dict [punk::mix::base::lib::get_template_basefolders] puts stdout "get_template_basefolders output:" - pdict $template_base_dict + pdict template_base_dict */* return } diff --git a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm index 56aa8158..9955c53b 100644 --- a/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/module-0.1.0.tm @@ -159,7 +159,7 @@ namespace eval punk::mix::commandset::module { #set opts [dict merge $defaults $args] #todo - review compatibility between -template and -type - #-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) + #-type is the wrapping technology e.g 'plain' for none or tarjar or zip (modpod) etc (consider also snappy/snappy-tcl) #-template may be a folder - but only if the selected -type suports it @@ -293,6 +293,7 @@ namespace eval punk::mix::commandset::module { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_quiet [dict get $opts -quiet] + set opt_force [dict get $opts -force] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -378,13 +379,39 @@ namespace eval punk::mix::commandset::module { } set template_filedata [string map $strmap $template_filedata] - set modulefile $modulefolder/${moduletail}-$infile_version.tm - if {[file exists $modulefile]} { - set errmsg "module.new error: module file $modulefile already exists - aborting" - if {[string match "*$magicversion*" $modulefile]} { - append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" + set tmfile $modulefolder/${moduletail}-$infile_version.tm + set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + if {$has_tm && $has_pos} { + #invalid configuration - bomb out + error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again." + } + if {$opt_type eq "plain"} { + set modulefile $tmfile + } else { + set modulefile $podfile + } + if {$has_tm || $has_pod} { + if {!$opt_force} { + if {$has_tm} { + set errmsg "module.new error: module file $tmfile already exists - aborting" + } else { + set errmsg "module.new error: module file $podfile already exists - aborting" + } + if {[string match "*$magicversion*" $tmfile]} { + append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" + } + error $errmsg + } else { + #review - prompt here vs caller? + #we are committed to overwriting/replacing if there was a pre-existing module of same version + if {$has_pod} { + file delete -force [file dirname $podfile] + } elseif {$has_tm} { + file delete -force $tmfile + } } - error $errmsg } @@ -407,13 +434,20 @@ namespace eval punk::mix::commandset::module { } } - set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] + set existing_tm_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] #it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name + set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*] + set existing_versions [concat $existing_tm_versions $existing_pod_versions] + if {[llength $existing_versions]} { set name_version_pairs [list] lappend name_version_pairs [list $moduletail $infile_version] foreach existing $existing_versions { - lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored + lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored + if {[string match #modpod-* $namepart]} { + set namepart [string range $namepart 8 end] + } + lappend name_version_pairs [list $namepart $version] } set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { @@ -436,6 +470,8 @@ namespace eval punk::mix::commandset::module { if {!$opt_quiet} { puts stdout "Creating $modulefile from template $moduletemplate" } + file mkdir [file dirname $modulefile] + set fd [open $modulefile w] fconfigure $fd -translation binary puts -nonewline $fd $template_filedata diff --git a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm index 862bbf00..9cac531c 100644 --- a/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm +++ b/src/bootsupport/modules/punk/mix/commandset/project-0.1.0.tm @@ -320,6 +320,8 @@ namespace eval punk::mix::commandset::project { puts stderr "-force 1 or -update 1 not specified - aborting" return } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil } if {$fossil_repo_file eq ""} { @@ -415,12 +417,30 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc - punk::mix::commandset::module::new $m -project $projectname -type $opt_type + punk::mix::commandset::module::new -project $projectname -type $opt_type $m } else { + #we should rarely if ever want to force any src/modules to be overwritten if {$opt_force} { - punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } } } } diff --git a/src/bootsupport/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/bootsupport/modules/punk/mix/templates/layouts/project/src/make.tcl index c53315e9..20b0c29f 100644 --- a/src/bootsupport/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/bootsupport/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -13,7 +13,7 @@ namespace eval ::punkmake { variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] variable help_flags [list -help --help /?] - variable known_commands [list project get-project-info shell bootsupport] + variable known_commands [list project get-project-info shell vendor bootsupport] } if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" @@ -134,6 +134,8 @@ proc punkmake_gethelp {args} { append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n append h " $scriptname bootsupport" \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n \n + append h " $scriptname vendor" \n + append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " $scriptname get-project-info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n @@ -251,6 +253,100 @@ if {$::punkmake::command eq "shell"} { exit 1 } +if {$::punkmake::command eq "vendor"} { + puts "projectroot: $projectroot" + puts "script: [info script]" + #puts "-- [tcl::tm::list] --" + puts stdout "Updating vendor modules" + proc vendor_localupdate {projectroot} { + set local_modules [list] + set git_modules [list] + set fossil_modules [list] + #todo vendor/lib ? + set vendor_config $projectroot/src/vendormodules/include_modules.config + if {[file exists $vendor_config]} { + set targetroot $projectroot/src/vendormodules/modules + source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list + if {![llength $local_modules]} { + puts stderr "No local vendor modules configured for updating (config file: $vendor_config)" + } else { + if {[catch { + #---------- + set vendor_installer [punkcheck::installtrack new make.tcl $projectroot/src/vendormodules/.punkcheck] + $vendor_installer set_source_target $projectroot $projectroot/src/vendormodules + set installation_event [$vendor_installer start_event {-make_step vendor}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for vendor update. Error: $errM" + set installation_event "" + } + foreach {relpath module} $local_modules { + set module [string trim $module :] + set module_subpath [string map {:: /} [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for vendor module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$installation_event ne ""} { + #---------- + $installation_event targetset_init INSTALL $tgtfile + $installation_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$installation_event targetset_source_changes] changed]]\ + || [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $installation_event targetset_started + # -- --- --- --- --- --- + puts "VENDOR update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $installation_event targetset_end FAILED + } else { + $installation_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $installation_event targetset_end SKIPPED + } + $installation_event end + } else { + file copy -force $srcfile $tgtfile + } + } + + } + } else { + puts stderr "No config at $vendor_config - nothing configured to update" + } + } + + + puts stdout " vendor package update done " + flush stderr + flush stdout + ::exit 0 +} + if {$::punkmake::command eq "bootsupport"} { puts "projectroot: $projectroot" puts "script: [info script]" @@ -275,7 +371,7 @@ if {$::punkmake::command eq "bootsupport"} { set boot_event [$boot_installer start_event {-make_step bootsupport}] #---------- } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" + puts stderr "Unable to use punkcheck for bootsupport. Error: $errM" set boot_event "" } @@ -441,7 +537,7 @@ if {[file exists $sourcefolder/vendorlib]} { if {[file exists $sourcefolder/vendormodules]} { #install .tm *and other files* puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}] + set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stderr "VENDORMODULES: No src/vendormodules folder found." diff --git a/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl b/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl new file mode 100644 index 00000000..99320f87 --- /dev/null +++ b/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl @@ -0,0 +1,53 @@ +apply {code { + set scriptpath [file normalize [info script]] + if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { + #jump up an extra dir level if we are within a #modpod-loadscript file. + set mypath [file dirname [file dirname $scriptpath]] + #expect to be in folder #modpod-- + #Now we need to test if we are in a mounted folder vs an extracted folder + set container [file dirname $mypath] + if {[string match "#mounted-modpod-*" $container]} { + set mypath [file dirname $container] + } + set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-- + } else { + set mypath [file dirname $scriptpath] + set modver [file root [file tail [info script]]] + } + set mysegs [file split $mypath] + set overhang [list] + foreach libpath [tcl::tm::list] { + set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / + if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { + #mypath is below libpath + set overhang [lrange $mysegs [llength $libsegs]+1 end] + break + } + } + lassign [split $modver -] moduletail version + set ns [join [concat $overhang $moduletail] ::] + #if {![catch {package require modpod}]} { + # ::modpod::disconnect [info script] + #} + package provide $ns $version + namespace eval $ns $code +} ::} { + # + # Module procs here, where current namespace is that of the module. + # Package version can, if needed, be accessed as [uplevel 1 {set version}] + # Last element of module name: [uplevel 1 {set moduletail}] + # Full module name: [uplevel 1 {set ns}] + + # + # + # + + # + # + # + + # + # + # + +} diff --git a/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z b/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z new file mode 100644 index 00000000..a8f7b05a --- /dev/null +++ b/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z @@ -0,0 +1,2 @@ +#Do not remove the trailing ctrl-z character from this file + \ No newline at end of file diff --git a/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip b/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip new file mode 100644 index 00000000..665234de Binary files /dev/null and b/src/bootsupport/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip differ diff --git a/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt b/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt index 53815fbd..6266c016 100644 --- a/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt +++ b/src/bootsupport/modules/punk/mix/templates/modules/modulename_buildversion.txt @@ -1,3 +1,3 @@ -%Major.Minor.Level% -#First line must be a semantic version number -#all other lines are ignored. +%Major.Minor.Level% +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/bootsupport/modules/punk/mix/templates/modules/modulename_description.txt b/src/bootsupport/modules/punk/mix/templates/modules/modulename_description.txt index ddb209af..571e4cf5 100644 --- a/src/bootsupport/modules/punk/mix/templates/modules/modulename_description.txt +++ b/src/bootsupport/modules/punk/mix/templates/modules/modulename_description.txt @@ -1,10 +1,10 @@ -Identifier: %package% -Version: %version% -Title: %title% -Creator: %name% <%email%> -Description: %description% -Rights: BSD -URL: %url% -Available: -Architecture: tcl -Subject: +Identifier: %package% +Version: %version% +Title: %title% +Creator: %name% <%email%> +Description: %description% +Rights: BSD +URL: %url% +Available: +Architecture: tcl +Subject: diff --git a/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat b/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat deleted file mode 100644 index 4f798a83..00000000 --- a/src/bootsupport/modules/punk/mix/templates/utility/a b/tcltest.bat +++ /dev/null @@ -1,7 +0,0 @@ -::lindex tcl;#\ -@call tclsh "%~dp0%~n0.bat" %* & goto :eof -# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl -puts stdout "script: [info script]" -puts stdout "argv: $::argc" -puts stdout "args: '$::argv'" - diff --git a/src/bootsupport/modules/punk/mix/templates/utility/tclbatheader.txt b/src/bootsupport/modules/punk/mix/templates/utility/tclbatheader.txt index b2e0367f..88326d54 100644 --- a/src/bootsupport/modules/punk/mix/templates/utility/tclbatheader.txt +++ b/src/bootsupport/modules/punk/mix/templates/utility/tclbatheader.txt @@ -1,3 +1,3 @@ -::lindex tcl;#\ -@call tclsh "%~dp0%~n0.bat" %* & goto :eof -# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl +::lindex tcl;#\ +@call tclsh "%~dp0%~n0.bat" %* & goto :eof +# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl diff --git a/src/bootsupport/modules/punk/mix/templates/utility/tclbattest.bat b/src/bootsupport/modules/punk/mix/templates/utility/tclbattest.bat index 396aea56..fd2e9511 100644 --- a/src/bootsupport/modules/punk/mix/templates/utility/tclbattest.bat +++ b/src/bootsupport/modules/punk/mix/templates/utility/tclbattest.bat @@ -1,8 +1,8 @@ -::lindex tcl;#\ -@call tclsh "%~dp0%~n0.bat" %* & goto :eof -# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl -puts stdout "exe: [info nameof]" -puts stdout "scr: [info script]" -puts stdout "argc: $::argc" -puts stdout "argv: '$::argv'" - +::lindex tcl;#\ +@call tclsh "%~dp0%~n0.bat" %* & goto :eof +# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl +puts stdout "exe: [info nameof]" +puts stdout "scr: [info script]" +puts stdout "argc: $::argc" +puts stdout "argv: '$::argv'" + diff --git a/src/bootsupport/modules/punk/mix/templates/utility/tclbattest2.bat b/src/bootsupport/modules/punk/mix/templates/utility/tclbattest2.bat index fbf2fcd0..4765515a 100644 --- a/src/bootsupport/modules/punk/mix/templates/utility/tclbattest2.bat +++ b/src/bootsupport/modules/punk/mix/templates/utility/tclbattest2.bat @@ -1,19 +1,19 @@ -::set - { -@goto start -# -- tcl bat -:start -@echo off -set script=%0 -echo %* -if exist %script%.bat set script=%script%.bat -tclsh %script% %* -goto end of BAT file -};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl - -puts stdout "exe: [info nameof]" -puts stdout "scr: [info script]" -puts stdout "argc: $::argc" -puts stdout "argv: '$::argv'" - -# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ -:end of BAT file +::set - { +@goto start +# -- tcl bat +:start +@echo off +set script=%0 +echo %* +if exist %script%.bat set script=%script%.bat +tclsh %script% %* +goto end of BAT file +};unset - ;# --- --- --- --- --- --- --- --- --- --- --- --- ---begin Tcl + +puts stdout "exe: [info nameof]" +puts stdout "scr: [info script]" +puts stdout "argc: $::argc" +puts stdout "argv: '$::argv'" + +# -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- ---end Tcl\ +:end of BAT file diff --git a/src/bootsupport/modules/punk/ns-0.1.0.tm b/src/bootsupport/modules/punk/ns-0.1.0.tm index 10a8d9a5..70f924d7 100644 --- a/src/bootsupport/modules/punk/ns-0.1.0.tm +++ b/src/bootsupport/modules/punk/ns-0.1.0.tm @@ -1166,24 +1166,6 @@ tcl::namespace::eval punk::ns { lappend allooclasses $cmd } } - if {[catch { - if {$cmd eq ""} { - #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. - set nsorigin [namespace origin ${location}::] - } elseif {[string match :* $cmd]} { - set nsorigin [nseval $location "::namespace origin $cmd"] - } else { - set nsorigin [namespace origin [nsjoin $location $cmd]] - } - } errM]} { - puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" - puts stderr "error message: $errM" - lappend allundetermined $cmd - } else { - if {[nsprefix $nsorigin] ne $location} { - lappend allimported $cmd - } - } } default { if {$ctype eq "imported"} { @@ -1242,6 +1224,25 @@ tcl::namespace::eval punk::ns { } } + #JMN + if {[catch { + if {$cmd eq ""} { + #empty command was previously marked as "::" - too confusing - nslist updated to properly display empty string. + set nsorigin [namespace origin ${location}::] + } elseif {[string match :* $cmd]} { + set nsorigin [nseval $location "::namespace origin $cmd"] + } else { + set nsorigin [namespace origin [nsjoin $location $cmd]] + } + } errM]} { + puts stderr "get_ns_dicts failed to determine origin of command '$cmd' adding to 'undetermined'" + puts stderr "error message: $errM" + lappend allundetermined $cmd + } else { + if {[nsprefix $nsorigin] ne $location} { + lappend allimported $cmd + } + } } if {$glob ne "*"} { set childtailmatches [lsearch -all -inline $childtails $glob] diff --git a/src/bootsupport/modules/punk/path-0.1.0.tm b/src/bootsupport/modules/punk/path-0.1.0.tm index 4abba695..933ef860 100644 --- a/src/bootsupport/modules/punk/path-0.1.0.tm +++ b/src/bootsupport/modules/punk/path-0.1.0.tm @@ -217,7 +217,8 @@ namespace eval punk::path { -directory -default "\uFFFF" -call-depth-internal -default 0 -type integer -antiglob_paths -default {} - *values -min 0 -max -1 -type string + *values -min 0 -max -1 -optional 1 -type string + tailglobs -multiple 1 } $args] lassign [dict values $argd] opts values set tailglobs [dict values $values] diff --git a/src/bootsupport/modules/punk/repo-0.1.1.tm b/src/bootsupport/modules/punk/repo-0.1.1.tm index 4b1e2f4f..ee2384b4 100644 --- a/src/bootsupport/modules/punk/repo-0.1.1.tm +++ b/src/bootsupport/modules/punk/repo-0.1.1.tm @@ -1447,6 +1447,7 @@ namespace eval punk::repo { #Must accept empty prefix - which is effectively noop. #MUCH faster version for absolute path prefix (pre-normalized) + #review - will error on file join if lrange returns empty list ie if prefix longer than path proc path_strip_alreadynormalized_prefixdepth {path prefix} { if {$prefix eq ""} { return $path @@ -1488,11 +1489,11 @@ namespace eval punk::repo { interp alias {} git_revision {} ::punk::repo::git_revision - interp alias {} gs {} git status -sb - interp alias {} gr {} ::punk::repo::git_revision - interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console - interp alias {} glast {} git log -1 HEAD --stat - interp alias {} gconf {} git config --global -l + interp alias {} gs {} shellrun::runconsole git status -sb + interp alias {} gr {} ::punk::repo::git_revision + interp alias {} gl {} shellrun::runconsole git log --oneline --decorate ;#decorate so stdout consistent with what we see on console + interp alias {} glast {} shellrun::runconsole git log -1 HEAD --stat + interp alias {} gconf {} shellrun::runconsole git config --global -l } namespace eval punk::repo::lib { diff --git a/src/bootsupport/modules/punkcheck-0.1.0.tm b/src/bootsupport/modules/punkcheck-0.1.0.tm index 56d42b23..5d4f5c27 100644 --- a/src/bootsupport/modules/punkcheck-0.1.0.tm +++ b/src/bootsupport/modules/punkcheck-0.1.0.tm @@ -37,7 +37,7 @@ namespace eval punkcheck { start_installer_event installfile_* #antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators - variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] + variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"] variable default_antiglob_file_core "" proc uuid {} { set has_twapi 0 @@ -1196,7 +1196,7 @@ namespace eval punkcheck { #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0 - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max_depth] ;# -1 for no limit set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill set fileglob [dict get $opts -glob] set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting @@ -1598,7 +1598,7 @@ namespace eval punkcheck { } - if {$CALLDEPTH >= $max_depth} { + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { #don't process any more subdirs set subdirs [list] } else { diff --git a/src/bootsupport/modules/textblock-0.1.1.tm b/src/bootsupport/modules/textblock-0.1.1.tm index 055fdfcd..04e219bb 100644 --- a/src/bootsupport/modules/textblock-0.1.1.tm +++ b/src/bootsupport/modules/textblock-0.1.1.tm @@ -29,6 +29,7 @@ package require textutil tcl::namespace::eval textblock { #review - what about ansi off in punk::console? tcl::namespace::import ::punk::ansi::a ::punk::ansi::a+ + tcl::namespace::export block frame frame_cache framedef frametypes gcross height width widthtopline join join_basic list_as_table pad testblock tcl::namespace::eval class { variable opts_table_defaults @@ -836,7 +837,7 @@ tcl::namespace::eval textblock { set args_got_header_colspans 1 #check columns to left to make sure each new colspan for this column makes sense in the overall context #user may have to adjust colspans in order left to right to avoid these check errors - #note that 'all' represents span all up to the next non-zero defined colspan. + #note that 'any' represents span all up to the next non-zero defined colspan. set cspans [my header_colspans] set h 0 if {[llength $v] > [tcl::dict::size $cspans]} { @@ -846,34 +847,34 @@ tcl::namespace::eval textblock { if {$cidx == 0} { if {[tcl::string::is integer -strict $s]} { if {$s < 1} { - error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'all' or a positive integer" + error "configure_column $cidx -header_colspans bad first value '$s' for header '$h' . First column cannot have span less than 1. use 'any' or a positive integer" } } else { - if {$s ne "all" && $s ne ""} { - error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'" + if {$s ne "any" && $s ne ""} { + error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" } } } else { #if {![tcl::string::is integer -strict $s]} { - # if {$s ne "all" && $s ne ""} { - # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'all'" + # if {$s ne "any" && $s ne ""} { + # error "configure_column $cidx -header_colspans unrecognised value '$s' for header '$h' - must be a positive integer or the keyword 'any'" # } #} else { set header_spans [tcl::dict::get $cspans $h] set remaining [lindex $header_spans 0] - if {$remaining ne "all"} { + if {$remaining ne "any"} { incr remaining -1 } #look at spans defined for previous cols #we are presuming previous column entries are valid - and only validating if our new entry is ok under that assumption for {set c 0} {$c < $cidx} {incr c} { set span [lindex $header_spans $c] - if {$span eq "all"} { - set remaining "all" + if {$span eq "any"} { + set remaining "any" } else { - if {$remaining eq "all"} { + if {$remaining eq "any"} { if {$span ne "0"} { - #a previous column has ended the 'all' span + #a previous column has ended the 'any' span set remaining [expr {$span -1}] } } else { @@ -886,8 +887,8 @@ tcl::namespace::eval textblock { } } } - if {$remaining eq "all"} { - #any int >0 ok - what about 'all' immediately following all? + if {$remaining eq "any"} { + #any int >0 ok - what about 'any' immediately following any? } else { if {$remaining > 0} { if {$s ne "0" && $s ne ""} { @@ -895,7 +896,7 @@ tcl::namespace::eval textblock { } } else { if {$s == 0} { - error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'all'" + error "configure_column $cidx -header_colspans bad span $s for header '$h'. No span in place - need >=1 or 'any'" } } } @@ -1020,10 +1021,11 @@ tcl::namespace::eval textblock { #return a dict keyed on header index with values representing colspans #e.g - # 0 {all 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} # method header_colspans {} { - set num_headers [my header_count_calc] + #set num_headers [my header_count_calc] + set num_headers [my header_count] set colspans_by_header [tcl::dict::create] tcl::dict::for {cidx cdef} $o_columndefs { set headerlist [tcl::dict::get $cdef -headers] @@ -1033,17 +1035,17 @@ tcl::namespace::eval textblock { set defined_span [lindex $colspans_for_column $h] set i 0 set spanremaining [lindex $headerspans 0] - if {$spanremaining ne "all"} { + if {$spanremaining ne "any"} { if {$spanremaining eq ""} { set spanremaining 1 } incr spanremaining -1 } foreach s $headerspans { - if {$s eq "all"} { - set spanremaining "all" + if {$s eq "any"} { + set spanremaining "any" } elseif {$s == 0} { - if {$spanremaining ne "all"} { + if {$spanremaining ne "any"} { incr spanremaining -1 } } else { @@ -1055,7 +1057,7 @@ tcl::namespace::eval textblock { if {$spanremaining eq "0"} { lappend headerspans 1 } else { - #"all" or an integer + #"any" or an integer lappend headerspans 0 } } else { @@ -1067,6 +1069,39 @@ tcl::namespace::eval textblock { return $colspans_by_header } + #e.g + # 0 {any 0 0 0} 1 {1 1 1 1} 2 {2 0 any 1} 3 {any 0 0 1} + #convert to + # 0 {4 0 0 0} 1 {1 1 1 1} 2 {2 0 1 1} 3 {3 0 0 1} + method header_colspans_numeric {} { + set hcolspans [my header_colspans] + if {![tcl::dict::size $hcolspans]} { + return + } + set numcols [llength [tcl::dict::get $hcolspans 0]] ;#assert: all are the same + tcl::dict::for {h spans} $hcolspans { + set c 0 ;#column index + foreach s $spans { + if {$s eq "any"} { + set spanlen 1 + for {set i [expr {$c+1}]} {$i < $numcols} {incr i} { + #next 'any' or non-zero ends an 'any' span + if {[lindex $spans $i] ne "0"} { + break + } + incr spanlen + } + #overwrite the 'any' with it's actual span + set modified_spans [dict get $hcolspans $h] + lset modified_spans $c $spanlen + dict set hcolspans $h $modified_spans + } + incr c + } + } + return $hcolspans + } + #should be configure_headerrow ? method configure_header {index_expression args} { #the header data being configured or returned here is mostly derived from the column defs and if necessary written to the column defs. @@ -1103,6 +1138,10 @@ tcl::namespace::eval textblock { #set val [tcl::dict::get $o_rowdefs $ridx $k] set infodict [tcl::dict::create] + #todo + # -blockalignments and -textalignments lists + # must match number of values if not empty? - e.g -blockalignments {left right "" centre left ""} + #if there is a value it overrides alignments specified on the column switch -- $k { -values { set header_row_items [list] @@ -1190,54 +1229,54 @@ tcl::namespace::eval textblock { if {[llength $v]} { set firstspan [lindex $v 0] set first_is_ok 0 - if {$firstspan eq "all"} { + if {$firstspan eq "any"} { set first_is_ok 1 } elseif {[tcl::string::is integer -strict $firstspan] && $firstspan > 0 && $firstspan <= $numcols} { set first_is_ok 1 } if {!$first_is_ok} { - error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"all\"" + error "textblock::table::configure_header -colspans first value '$firstspan' must be integer > 0 & <= $numcols or the string \"any\"" } #we don't mind if there are less colspans specified than columns.. the tail can be deduced from the leading ones specified (review) set remaining $firstspan - if {$remaining ne "all"} { + if {$remaining ne "any"} { incr remaining -1 } set spanview $v set sidx 1 - #because we allow 'all' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'all' first + #because we allow 'any' - be careful when doing < or > comparisons - as we are mixing integer and string comparisons if we don't test for 'any' first foreach span [lrange $v 1 end] { - if {$remaining eq "all"} { - if {$span eq "all"} { - set remaining "all" + if {$remaining eq "any"} { + if {$span eq "any"} { + set remaining "any" } elseif {$span > 0} { - #ok to reset to higher val immediately or after an all and any number of following zeros + #ok to reset to higher val immediately or after an any and any number of following zeros if {$span > ($numcols - $sidx)} { lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"all\".[a] $spanview" + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span incr remaining -1 } else { - #zero following an all - leave remaining as all + #zero following an any - leave remaining as any } } else { if {$span eq "0"} { if {$remaining eq "0"} { lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"all\" value.[a] $spanview" + error "textblock::table::configure_header -colspans sequence incorrect at span '$span' remaining is $remaining. Require positive or \"any\" value.[a] $spanview" } else { incr remaining -1 } } else { if {$remaining eq "0"} { - #ok for new span value of all or > 0 - if {$span ne "all" && $span > ($numcols - $sidx)} { + #ok for new span value of any or > 0 + if {$span ne "any" && $span > ($numcols - $sidx)} { lset spanview $sidx [a+ web-red]$span[a] - error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"all\".[a] $spanview" + error "textblock::table::configure_header -colspans sequence incorrect at span '$span'. Require span <= [expr {$numcols-$sidx}] or \"any\".[a] $spanview" } set remaining $span - if {$remaining ne "all"} { + if {$remaining ne "any"} { incr remaining -1 } } else { @@ -1760,8 +1799,8 @@ tcl::namespace::eval textblock { set hdrmap [tcl::dict::get $hmap only${opt_posn}] set topseps_h [tcl::dict::get $sep_elements_horizontal top$opt_posn] - set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] set midseps_h [tcl::dict::get $sep_elements_horizontal middle$opt_posn] + set topseps_v [tcl::dict::get $sep_elements_vertical top$opt_posn] set midseps_v [tcl::dict::get $sep_elements_vertical middle$opt_posn] set botseps_v [tcl::dict::get $sep_elements_vertical bottom$opt_posn] set onlyseps_v [tcl::dict::get $sep_elements_vertical only$opt_posn] @@ -1795,16 +1834,19 @@ tcl::namespace::eval textblock { #set hcolwidth [my column_width_configured $cidx] set hcell_line_blank [tcl::string::repeat " " $hcolwidth] - set all_colspans [my header_colspans] + set all_colspans [my header_colspans_numeric] + #put our framedef calls together + set fdef_header [textblock::framedef $ftype_header] + set framedef_leftbox [textblock::framedef -joins left $ftype_header] + set framedef_headerdown_same [textblock::framedef -joins {down} $ftype_header] + set framedef_headerdown_body [textblock::framedef -joins [list down-$fname_body] $ftype_header] #default span_extend_map - used as base to customise with specific joins - set fdef_header [textblock::framedef $ftype_header] set span_extend_map [tcl::dict::create \ vll " "\ tlc [tcl::dict::get $fdef_header hlt]\ blc [tcl::dict::get $fdef_header hlb]\ ] - set framedef_leftbox [textblock::framedef $ftype_header -joins left] #used for colspan-zero header frames @@ -1851,7 +1893,10 @@ tcl::namespace::eval textblock { } #puts ">>> headerspans: $headerspans cidx: $cidx" - if {$this_span eq "all" || $this_span > 0} { + #if {$this_span eq "any" || $this_span > 0} {} + #changed to processing only numeric colspans + + if {$this_span > 0} { set startmap [tcl::dict::get $hmap $rowpos${opt_posn}] #look at spans in header below to determine joins required at blc if {$show_seps_v} { @@ -1882,7 +1927,7 @@ tcl::namespace::eval textblock { # -boxlimits $hlims -boxmap $startmap -joins $header_joins $hval\ # ] - if {$this_span eq "1"} { + if {$this_span == 1} { #write the actual value now set cellcontents $hval } else { @@ -1894,13 +1939,20 @@ tcl::namespace::eval textblock { -boxlimits $hlims -boxmap $startmap -joins $header_joins $cellcontents\ ] - if {$this_span ne "1"} { + if {$this_span != 1} { #puts "===>\n$header_cell_startspan\n<===" set spanned_parts [list $header_cell_startspan] - #assert this_span == "all" or >1 ie a header that spans other columns + #assert this_span == "any" or >1 ie a header that spans other columns #therefore more parts to append #set remaining_cols [lrange [tcl::dict::keys $o_columndefs] $cidx end] set remaining_spans [lrange $headerspans $cidx+1 end] + set spanval [join $remaining_spans ""] ;#so we can test for all zeros + set spans_to_rhs 0 + if {[expr {$spanval}] == 0} { + #puts stderr "SPANS TO RHS" + set spans_to_rhs 1 + } + #puts ">> remaining_spans: $remaining_spans" set spancol [expr {$cidx + 1}] set h_lines [lrepeat $rowh ""] @@ -1944,13 +1996,11 @@ tcl::namespace::eval textblock { if {[llength $next_spanlist]} { set spanbelow [lindex $next_spanlist $spancol] if {$spanbelow != 0} { - set downbox [textblock::framedef $ftype_header -joins {down}] - tcl::dict::set this_span_map blc [tcl::dict::get $downbox hlbj] ;#horizontal line bottom with down join - to same frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_same hlbj] ;#horizontal line bottom with down join - to same frametype } } else { #join to body - set downbox [textblock::framedef $ftype_header -joins [list down-$fname_body]] - tcl::dict::set this_span_map blc [tcl::dict::get $downbox hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype + tcl::dict::set this_span_map blc [tcl::dict::get $framedef_headerdown_body hlbj] ;#horizontal line bottom with down join - from header frametype to body frametype } } @@ -1980,17 +2030,38 @@ tcl::namespace::eval textblock { #spanned_parts are all built with textblock::frame - therefore uniform-width lines - can use join_basic set spanned_frame [textblock::join_basic -- {*}$spanned_parts] - if {$hrow == 0} { - set hlims $header_boxlimits_toprow + if {$spans_to_rhs} { + if {$cidx == 0} { + set fake_posn solo + } else { + set fake_posn right + } + set x_limj [my Get_boxlimits_and_joins $fake_posn $fname_body] + if {$hrow == 0} { + set x_boxlimits_toprow [tcl::dict::get $x_limj boxlimits_top] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_toprow] + } else { + set x_boxlimits_position [tcl::dict::get $x_limj boxlimits] + set hlims [struct::set intersect [tcl::dict::get $o_opts_table_effective -framelimits_header] $x_boxlimits_position] + } } else { - set hlims $header_boxlimits + if {$hrow == 0} { + set hlims $header_boxlimits_toprow + } else { + set hlims $header_boxlimits + } } if {!$show_seps_v} { set hlims [struct::set difference $hlims $headerseps_v] } if {![tcl::dict::get $o_opts_table -show_edge]} { - #use the edge_parts corresponding to the column being written to ie use opt_posn - set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + if {$spans_to_rhs} { + #assert fake_posn has been set above based on cidx and spans_to_rhs + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts ${rowpos}$fake_posn] ] + } else { + #use the edge_parts corresponding to the column being written to ie use opt_posn + set hlims [struct::set difference $hlims [tcl::dict::get $::textblock::class::header_edge_parts $rowpos$opt_posn] ] + } } set spacemap [list hl " " vl " " tlc " " blc " " trc " " brc " "] ;#transparent overlay elements @@ -2005,7 +2076,21 @@ tcl::namespace::eval textblock { #set spanned_frame [overtype::renderspace -experimental test_mode -transparent 1 $spanned_frame $hblock] #spanned values default left - todo make configurable + + #TODO + #consider that currently blockaligning for spanned columns must always use the blockalign value from the starting column of the span + #we could conceivably have an override that could be set somehow with configure_header for customization of alignments of individual spans or span sizes? + #this seems like a likely requirement. The first spanned column may well have different alignment requirements than the span. + #(e.g if first spanned col happens to be numeric it probably warrants right textalign (if not blockalign) but we don't necessarily want the spanning header or even a non-spanning header to be right aligned) + set spanned_frame [overtype::block -blockalign $col_blockalign -overflow 1 -transparent 1 $spanned_frame $hblock] + #POTENTIAL BUG (fixed with spans_to_rhs above) + #when -blockalign right and colspan extends to rhs - last char of longest of that spanlength will overlap right edge (if show_edge 1) + #we need to shift 1 to the left when doing our overtype with blockalign right + #we normally do this by using the hlims based on position - effectively we need a rhs position set of hlims for anything that colspans to the right edge + #(even though the column position may be left or inner) + + } else { #this_span == 1 @@ -2301,11 +2386,9 @@ tcl::namespace::eval textblock { error "table::get_column_cells_by_index no such index $index_expression. Valid range is $range" } #assert cidx is integer >=0 + set num_header_rows [my header_count] set cdef [tcl::dict::get $o_columndefs $cidx] set headerlist [tcl::dict::get $cdef -headers] - set num_header_rows [my header_count] - - set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] set ansibase_col [tcl::dict::get $cdef -ansibase] set textalign [tcl::dict::get $cdef -textalign] switch -- $textalign { @@ -2316,20 +2399,23 @@ tcl::namespace::eval textblock { } } + set ansibase_body [tcl::dict::get $o_opts_table -ansibase_body] set ansibase_header [tcl::dict::get $o_opts_table -ansibase_header] #set header_underlay $ansibase_header$cell_line_blank #set hdrwidth [my column_width_configured $cidx] - set all_colspans [my header_colspans] - + #set all_colspans [my header_colspans] + #we need to replace the 'any' entries with their actual span lengths before passing any -colspan values to column_datawidth - hence use header_colspans_numeric + set all_colspans [my header_colspans_numeric] + #JMN #store configured widths so we don't look up for each header line - set configured_widths [list] - foreach c [tcl::dict::keys $o_columndefs] { - #lappend configured_widths [my column_width $c] - #we don't just want the width of the column in the body - or the headers will get truncated - lappend configured_widths [my column_width_configured $c] - } + #set configured_widths [list] + #foreach c [tcl::dict::keys $o_columndefs] { + # #lappend configured_widths [my column_width $c] + # #we don't just want the width of the column in the body - or the headers will get truncated + # lappend configured_widths [my column_width_configured $c] + #} set output [tcl::dict::create] tcl::dict::set output headers [list] @@ -2342,7 +2428,7 @@ tcl::namespace::eval textblock { set this_span [lindex $headerrow_colspans $cidx] #set this_hdrwidth [lindex $configured_widths $cidx] - set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span] ;#widest of headers in this col with same span - allows textalign to work with blockalign + set this_hdrwidth [my column_datawidth $cidx -headers 1 -colspan $this_span -cached 1] ;#widest of headers in this col with same span - allows textalign to work with blockalign set hcell_line_blank [tcl::string::repeat " " $this_hdrwidth] set hcell_lines [lrepeat $header_maxdataheight $hcell_line_blank] @@ -2704,7 +2790,7 @@ tcl::namespace::eval textblock { set width_max [expr {max($test_width,$width_max)}] continue } - if {$spanc eq "all" || $spanc > 1} { + if {$spanc eq "any" || $spanc > 1} { set spanned [list] ;#spanned is other columns spanned - not including this one set cnext [expr {$cidx +1}] set spanlength [lindex $colspans $cnext] @@ -2773,10 +2859,12 @@ tcl::namespace::eval textblock { set opts [tcl::dict::create\ -headers 0\ -footers 0\ - -colspan *\ + -colspan unspecified\ -data 1\ -cached 1\ ] + #NOTE: -colspan any is not the same as * + # #-colspan is relevant to header/footer data only foreach {k v} $args { switch -- $k { @@ -2789,6 +2877,17 @@ tcl::namespace::eval textblock { } } set opt_colspan [tcl::dict::get $opts -colspan] + switch -- $opt_colspan { + * - unspecified {} + any { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0 (use header_colspans_numeric to get actual spans)" + } + default { + if {![string is integer -strict $opt_colspan]} { + error "method column_datawidth invalid -colspan '$opt_colspan' must be * or an integer >= 0" + } + } + } set cidx [lindex [tcl::dict::keys $o_columndefs] $index_expression] @@ -2801,26 +2900,26 @@ tcl::namespace::eval textblock { set bwidest 0 set fwidest 0 if {[tcl::dict::get $opts -headers]} { - if {$opt_colspan eq "*"} { + if {$opt_colspan in {* unspecified}} { set hwidest [tcl::dict::get $o_columnstates $cidx maxwidthheaderseen] } else { + #this is not cached + # -- --- --- --- set colheaders [tcl::dict::get $o_columndefs $cidx -headers] - set all_colspans_by_header [my header_colspans] + set all_colspans_by_header [my header_colspans_numeric] set hlist [list] tcl::dict::for {hrow cspans} $all_colspans_by_header { set s [lindex $cspans $cidx] - #todo - map 'all' entries to a number? - #we should build a version of header_colspans that does this if {$s eq $opt_colspan} { lappend hlist [lindex $colheaders $hrow] } } - #set widest1 [tcl::mathfunc::max {*}[lmap v $cmds {tcl::string::length $v}]] if {[llength $hlist]} { set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] } else { set hwidest 0 } + # -- --- --- --- } } if {[tcl::dict::get $opts -data]} { @@ -2835,8 +2934,28 @@ tcl::namespace::eval textblock { #assert cidx is >=0 integer in valid range of keys for o_columndefs set values [list] + set hwidest 0 if {[tcl::dict::get $opts -headers]} { - lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + if {$opt_colspan in {* unspecified}} { + lappend values {*}[tcl::dict::get $o_columndefs $cidx -headers] + } else { + # -- --- --- --- + set colheaders [tcl::dict::get $o_columndefs $cidx -headers] + set all_colspans_by_header [my header_colspans_numeric] + set hlist [list] + tcl::dict::for {hrow cspans} $all_colspans_by_header { + set s [lindex $cspans $cidx] + if {$s eq $opt_colspan} { + lappend hlist [lindex $colheaders $hrow] + } + } + if {[llength $hlist]} { + set hwidest [tcl::mathfunc::max {*}[lmap v $hlist {textblock::width $v}]] + } else { + set hwidest 0 + } + # -- --- --- --- + } } if {[tcl::dict::get $opts -data]} { if {[tcl::dict::exists $o_columndata $cidx]} { @@ -2847,9 +2966,10 @@ tcl::namespace::eval textblock { lappend values {*}[tcl::dict::get $o_columndefs $cidx -footers] } if {[llength $values]} { - set widest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set valwidest [tcl::mathfunc::max {*}[lmap v $values {textblock::width $v}]] + set widest [expr {max($valwidest,$hwidest)}] } else { - set widest 0 + set widest $hwidest } return $widest } @@ -3143,24 +3263,43 @@ tcl::namespace::eval textblock { set colspans_for_column [tcl::dict::get $o_columndefs $cidx -header_colspans] set spaninfo [list] set numcols [tcl::dict::size $o_columndefs] - #note that 'all' can occur in positions other than column 0 - meaning all remaining + #note that 'any' can occur in positions other than column 0 - meaning any remaining until next non-zero span tcl::dict::for {hrow rawspans} $spans_by_header { set thiscol_spanval [lindex $rawspans $cidx] - if {$thiscol_spanval eq "all" || $thiscol_spanval > 0} { + if {$thiscol_spanval eq "any" || $thiscol_spanval > 0} { set spanstartcol $cidx ;#own column - if {$thiscol_spanval eq "all"} { - set spanlen [expr {$numcols - $cidx}] + if {$thiscol_spanval eq "any"} { + #scan right to first non-zero to get actual length of 'any' span + #REVIEW! + set spanlen 1 + for {set i [expr {$cidx+1}]} {$i < $numcols} {incr i} { + #abort at next any or number or empty string + if {[lindex $rawspans $i] ne "0"} { + break + } + incr spanlen + } + #set spanlen [expr {$numcols - $cidx}] } else { set spanlen $thiscol_spanval } } else { - #look left til we see an all or a non-zero value + #look left til we see an any or a non-zero value for {set i $cidx} {$i > -1} {incr i -1} { set s [lindex $rawspans $i] - if {$s eq "all" || $s > 0} { + if {$s eq "any" || $s > 0} { set spanstartcol $i - if {$s eq "all"} { - set spanlen [expr {$numcols - $i}] + if {$s eq "any"} { + #REVIEW! + #set spanlen [expr {$numcols - $i}] + set spanlen 1 + #now scan right to see how long the 'any' actually is + for {set j [expr {$i+1}]} {$j < $numcols} {incr j} { + if {[lindex $rawspans $j] ne "0"} { + break + } + incr spanlen + } } else { set spanlen $s } @@ -3295,7 +3434,7 @@ tcl::namespace::eval textblock { set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] #JMN - #set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth @@ -3303,7 +3442,7 @@ tcl::namespace::eval textblock { } if {[llength $cols]} { - #return [textblock::join {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3399,11 +3538,11 @@ tcl::namespace::eval textblock { } else { set table [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $table $nextcol] - #set nextcol [textblock::join [textblock::block $padwidth $height $TSUB] $nextcol] + #set nextcol [textblock::join -- [textblock::block $padwidth $height $TSUB] $nextcol] #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent $TSUB $table[unset table] $nextcol] #JMN - #set nextcol [textblock::join [textblock::block $padwidth $height "\uFFFF"] $nextcol] + #set nextcol [textblock::join -- [textblock::block $padwidth $height "\uFFFF"] $nextcol] #set table [overtype::renderspace -overflow 1 -experimental test_mode -transparent \uFFFF $table $nextcol] } incr padwidth $bodywidth @@ -3411,7 +3550,7 @@ tcl::namespace::eval textblock { } if {[llength $cols]} { - #return [textblock::join {*}$blocks] + #return [textblock::join -- {*}$blocks] if {[tcl::dict::get $o_opts_table -show_edge]} { #title is considered part of the edge ? set offset 1 ;#make configurable? @@ -3517,7 +3656,7 @@ tcl::namespace::eval textblock { set header_build [overtype::renderspace -startcolumn [expr {$padwidth + 1}] -overflow 1 -experimental test_mode -transparent $TSUB $header_build[unset header_build] $nextcol_header[unset nextcol_header]] } lappend body_blocks $nextcol_body - #set body_build [textblock::join $body_build[unset body_build] $nextcol_body] + #set body_build [textblock::join -- $body_build[unset body_build] $nextcol_body] } incr padwidth $bodywidth incr colposn @@ -3595,7 +3734,6 @@ tcl::namespace::eval textblock { #Note: A textblock does not necessarily have lines the same length - either in number of characters or print-width # tcl::namespace::eval textblock { - tcl::namespace::export block width tcl::namespace::eval cd { #todo - save and restore existing tcl::namespace::export in case macros::cd has default exports in future tcl::namespace::eval ::term::ansi::code::macros::cd {tcl::namespace::export *} @@ -3605,18 +3743,29 @@ tcl::namespace::eval textblock { proc spantest {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers [list span3 "1-span4\n2-span4 second line" span5/5 "span-all etc blah 123 hmmmmm" span2] - $t configure_column 0 -header_colspans {3 4 5 all 2} + $t configure_column 0 -header_colspans {3 4 5 any 2} $t configure_column 2 -headers {"" "" "" "" c2span2_etc} $t configure_column 2 -header_colspans {0 0 0 0 2} $t configure -show_header 1 -ansiborder_header [a+ cyan] return $t } + proc spantest1 {} { + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] + $t configure_column 0 -headers [list "span3-any longer than other span any" "1-span4\n2-span4 second line" "span-any short aligned?" "span5/5 longest etc blah 123" span2] + $t configure_column 0 -header_colspans {any 4 any 5 2} + $t configure_column 2 -headers {"" "" "" "" c2span2_etc} + $t configure_column 2 -header_colspans {0 0 0 0 2} + $t configure_column 3 -header_colspans {1 0 0 0 0} + $t configure -show_header 1 -ansiborder_header [a+ cyan] + $t configure_column 0 -blockalign right ;#trigger KNOWN BUG overwrite of right edge by last char of spanning col (in this case fullspan from left - but also happens for any span extending to rhs) + return $t + } #more complex colspans proc spantest2 {} { set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" c0span2} - $t configure_column 0 -header_colspans {3 4 1 all 2} + $t configure_column 0 -header_colspans {3 4 1 any 2} $t configure_column 1 -header_colspans {0 0 2 0 0} $t configure_column 2 -headers {"" "" "" "" c2span2} $t configure_column 2 -header_colspans {0 0 0 0 2} @@ -3625,9 +3774,9 @@ tcl::namespace::eval textblock { return $t } proc spantest3 {} { - set t [list_as_table -columns 5 -return tableobjec {a b c d e aa bb cc dd ee X Y}] + set t [list_as_table -columns 5 -return tableobject {a b c d e aa bb cc dd ee X Y}] $t configure_column 0 -headers {c0span3 c0span4 c0span1 "c0span-all etc blah 123 hmmmmm" "c0span2 etc blah" c0span1} - $t configure_column 0 -header_colspans {3 4 1 all 2 1} + $t configure_column 0 -header_colspans {3 4 1 any 2 1} $t configure_column 1 -header_colspans {0 0 4 0 0 1} $t configure_column 1 -headers {"" "" "c1span4" "" "" "c1nospan"} $t configure_column 2 -headers {"" "" "" "" "" c2span2} @@ -3650,6 +3799,7 @@ tcl::namespace::eval textblock { -choices {table tableobject}\ -help "default choice 'table' returns the displayable table output" -compact -default 1 -type boolean -help "compact true defaults: -show_vseps 0 -show_header 0 -show_edge 0" + -frame -default 1 -type boolean -show_vseps -default "" -type boolean -show_header -default "" -type boolean -show_edge -default "" -type boolean @@ -3690,21 +3840,24 @@ tcl::namespace::eval textblock { } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - set ansi [a+ {*}$fc web-black Web-lightgreen] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - set ansi [a+ {*}$fc web-black Web-Khaki] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - set ansi [a+ {*}$fc web-black Web-lightsalmon] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -3718,7 +3871,8 @@ tcl::namespace::eval textblock { } set cat [list B Si Ge As Sb Te At] - set ansi [a+ {*}$fc web-black Web-turquoise] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val @@ -3739,7 +3893,8 @@ tcl::namespace::eval textblock { } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - set ansi [a+ {*}$fc web-black Web-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val @@ -3794,14 +3949,22 @@ tcl::namespace::eval textblock { $t configure \ -frametype_header light\ - -ansiborder_header [a+ {*}$fc web-white]\ - -ansibase_header [a+ {*}$fc Web-black]\ - -ansibase_body [a+ {*}$fc Web-black]\ - -ansiborder_body [a+ {*}$fc web-black]\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ -frametype block + #-ansiborder_header [a+ {*}$fc web-white]\ + if {$opt_return eq "table"} { - set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]] + if {[dict get $opts -frame]} { + #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + } else { + set output [$t print] + } $t destroy return $output } @@ -4106,8 +4269,8 @@ tcl::namespace::eval textblock { set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[punk::ansi::ta::detect $textblock]} { - #stripansiraw slightly faster than stripansi - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::stripansiraw $textblock] + #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) + set textblock [punk::ansi::ansistripraw $textblock] } if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] @@ -4123,7 +4286,7 @@ tcl::namespace::eval textblock { set tl $textblock } if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::stripansiraw $tl] + set tl [punk::ansi::ansistripraw $tl] } return [punk::char::ansifreestring_width $tl] } @@ -4158,9 +4321,9 @@ tcl::namespace::eval textblock { } set textblock [textutil::tabify::untabify2 $textblock $tw] } - #stripansiraw on entire block in one go rather than line by line - result should be the same - review - make tests + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansiraw $textblock] + set textblock [punk::ansi::ansistripraw $textblock] } if {[tcl::string::last \n $textblock] >= 0} { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] @@ -4189,16 +4352,16 @@ tcl::namespace::eval textblock { } set block [textutil::tabify::untabify2 $block $tw] if {[tcl::string::last \n $block] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [stripansi $v]}]] + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] } if {[catch {llength $block}]} { - return [::punk::char::string_width [stripansi $block]] + return [::punk::char::string_width [ansistrip $block]] } if {[llength $block] == 0} { #could be just a whitespace string return [tcl::string::length $block] } - return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [stripansi $v]}]] + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] } #we shouldn't make textblock depend on the punk pipeline system @@ -4279,9 +4442,21 @@ tcl::namespace::eval textblock { set lines [list] + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] if {$block eq ""} { #we need to treat as a line - return [tcl::string::repeat $padchar $width] + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } } #review - tcl format can only pad with zeros or spaces? @@ -4321,6 +4496,7 @@ tcl::namespace::eval textblock { } set line_chunks [list] set line_len 0 + set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { if {$pt ne ""} { set has_nl [expr {[tcl::string::last \n $pt]>=0}] @@ -4335,12 +4511,26 @@ tcl::namespace::eval textblock { foreach pl $partlines { lappend line_chunks $pl #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW if {$p != $last} { #do padding set missing [expr {$width - $line_len}] if {$missing > 0} { - set pad [tcl::string::repeat $padchar $missing] + #commonly in a block - many lines will have the same pad - cache based on missing + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } switch -- $which-$opt_withinansi { r-0 { lappend line_chunks $pad @@ -4397,7 +4587,18 @@ tcl::namespace::eval textblock { #pad last line set missing [expr {$width - $line_len}] if {$missing > 0} { - set pad [tcl::string::repeat $padchar $missing] + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] switch -- $which-$opt_withinansi { r-0 { lappend line_chunks $pad @@ -4667,6 +4868,7 @@ tcl::namespace::eval textblock { # Already uniform blocks will join faster than textblock::join, and ragged blocks will join in a ragged manner #" set argd [punk::args::get_dict { + -- -type none -optional 0 -help "end of options marker -- is mandatory because joined blocks may easily conflict with flags" -ansiresets -type any -default auto blocks -type any -multiple 1 } $args] @@ -4726,13 +4928,22 @@ tcl::namespace::eval textblock { -ansiresets { if {[lindex $args 2] eq "--"} { set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] } else { - set blocks [lrange $args 2 end] + error "end of opts marker -- is mandatory." } - set ansiresets [lindex $args 1] } default { - set blocks $args + if {[catch {tcl::prefix::match {-ansiresets} [lindex $args 0]} fullopt]} { + error "first flag must be -ansiresets or end of opts marker --" + } else { + if {[lindex $args 2] eq "--"} { + set blocks [lrange $args 3 end] + set ansiresets [lindex $args 1] + } else { + error "end of opts marker -- is mandatory" + } + } } } @@ -4836,11 +5047,12 @@ tcl::namespace::eval textblock { proc example3 {{text "test\netc\nmore text"}} { package require patternpunk - .= textblock::join [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join " " |> .=>1 textblock::join $text |> .=>1 textblock::join [>punk . rhs] |> .=>1 textblock::join [punk::lib::list_as_lines -- [lrepeat 7 " | "]] + .= textblock::join -- [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7]] [>punk . lhs] |> .=>1 textblock::join -- " " |> .=>1 textblock::join -- $text |> .=>1 textblock::join -- [>punk . rhs] |> .=>1 textblock::join -- [punk::lib::list_as_lines -- [lrepeat 7 " | "]] } proc example2 {{text "test\netc\nmore text"}} { package require patternpunk .= textblock::join\ + --\ [punk::lib::list_as_lines -- [list 1 2 3 4 5 6 7 8]]\ [>punk . lhs]\ " "\ @@ -4900,67 +5112,96 @@ tcl::namespace::eval textblock { } variable frametypes - set frametypes [list light heavy arc double block block1 ascii altg] + set frametypes [list light heavy arc double block block1 block2 ascii altg] #class::table needs to be able to determine valid frametypes proc frametypes {} { variable frametypes return $frametypes } proc frametype {f} { - variable frametypes - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] #set custom_keys [list hl hlt hlb vl vll vlr tlc trc blc brc] - if {$f ni $frametypes} { - set is_custom_dict_ok 1 - if {[llength $f] %2 == 0} { - #custom dict may leave out keys - but cannot have unknown keys - foreach {k v} $f { - switch -- $k { - hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} - default { - #k not in custom_keys - set is_custom_dict_ok 0 - break + switch -- $f { + light - heavy - arc - double - block - block1 - block2 - ascii - altg { + return [tcl::dict::create category predefined type $f] + } + default { + set is_custom_dict_ok 1 + if {[llength $f] %2 == 0} { + #custom dict may leave out keys - but cannot have unknown keys + foreach {k v} $f { + switch -- $k { + hl - hlt - hlb - vl - vll - vlr - tlc - trc - blc - brc {} + default { + #k not in custom_keys + set is_custom_dict_ok 0 + break + } } } + } else { + set is_custom_dict_ok 0 } - } else { - set is_custom_dict_ok 0 - } - if {!$is_custom_dict_ok} { - error "frame option -type must be one of known types: $frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + if {!$is_custom_dict_ok} { + error "frame option -type must be one of known types: $textblock::frametypes or a dictionary with any of keys hl,hlt,hlb,vl,vll,vlr,tlc,trc,blc,brc" + } + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] + set custom_frame [tcl::dict::merge $default_custom $f] + return [tcl::dict::create category custom type $custom_frame] } - set custom_frame [tcl::dict::merge $default_custom $f] - return [tcl::dict::create category custom type $custom_frame] - } else { - return [tcl::dict::create category predefined type $f] } } variable framedef_cache [tcl::dict::create] - proc framedef {f args} { + proc framedef {args} { #unicode box drawing only provides enough characters for seamless joining of unicode boxes light and heavy. #e.g with characters such as \u2539 Box Drawings Right Light and Left Up Heavy. #the double glyphs in box drawing can do a limited set of joins to light lines - but not enough for seamless table layouts. #the arc set can't even join to itself e.g with curved equivalents of T-like shapes + + #we use the simplest cache_key possible - performance sensitive as called multiple times in table building. variable framedef_cache - set cache_key [concat $f $args] + set cache_key $args if {[tcl::dict::exists $framedef_cache $cache_key]} { return [tcl::dict::get $framedef_cache $cache_key] } + set argopts [lrange $args 0 end-1] + set f [lindex $args end] + + #here we avoid the punk::args usage on the happy path, even though punk::args is fairly fast, in favour of an even faster literal switch on the happy path + #this means we have some duplication in where our flags/opts are defined: here in opts, and in spec below to give nicer error output without affecting performance. + #It also means we can't specify checks on the option types etc set opts [tcl::dict::create\ -joins ""\ -boxonly 0\ ] - foreach {k v} $args { + set bad_option 0 + foreach {k v} $argopts { switch -- $k { -joins - -boxonly { tcl::dict::set opts $k $v } default { - error "framedef unknown option '$k'. Known options [tcl::dict::keys $opts]" + set bad_option + break } } } + if {[llength $args] % 2 == 0 || $bad_option} { + #no framedef supplied, or unrecognised opt seen + set spec [string map [list $::textblock::frametypes] { + *proc -name textblock::framedef + -joins -default "" -help "List of join directions, any of: up down left right + or those combined with another frametype e.g left-heavy down-light" + -boxonly -default 0 -help "-boxonly true restricts results to the corner,vertical and horizontal box elements + It excludes the extra top and side join elements htlj,hlbj,vllj,vlrj" + *values -min 1 -max 1 + frametype -help "name from the predefined frametypes: + or an adhoc + }] + append spec \n "frametype -help \"A predefined \"" + punk::args::get_dict $spec $args + return + } + set joins [tcl::dict::get $opts -joins] set boxonly [tcl::dict::get $opts -boxonly] @@ -5986,6 +6227,7 @@ tcl::namespace::eval textblock { } } block1 { + #box drawing as far as we can go without extra blocks from legacy computing unicode block - which is unfortunately not commonly supported set hlt \u2581 ;# lower one eighth block set hlb \u2594 ;# upper one eighth block set vll \u258f ;# left one eighth block @@ -6002,17 +6244,19 @@ tcl::namespace::eval textblock { set vlrj $vlr } - blockxx { + block2 { + #the resultant table will have text appear towards top of each box + #with 'legacy' computing unicode block - hopefully these become more widely supported - as they are useful and fill in some gaps set hlt \u2594 ;# upper one eighth block set hlb \u2581 ;# lower one eighth block - set vll \u2595 ;# right one eighth block - set vlr \u258f ;# left one eighth block + set vlr \u2595 ;# right one eighth block + set vll \u258f ;# left one eighth block - set tlc \u2595 ;# right one eighth block - set trc \u258f ;# left one eighth block + set tlc \U1fb7d ;#legacy block + set trc \U1fb7e ;#legacy block - set blc \u2595 ;# right one eighth block - set brc \u258f ;# left one eighth block + set blc \U1fb7c ;#legacy block + set brc \U1fb7f ;#legacy block #horizontal and vertical bar joins set hltj $hlt @@ -6039,36 +6283,36 @@ tcl::namespace::eval textblock { set vlrj $vlr } default { - set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] - set custom_frame [tcl::dict::merge $default_custom $f] - tcl::dict::with custom_frame {} ;#extract keys as vars - - if {[tcl::dict::exists $custom_frame hlt]} { - set hlt [tcl::dict::get $custom_frame hlt] - } else { - set hlt $hl + set default_custom [tcl::dict::create hl " " vl " " tlc " " trc " " blc " " brc " "] ;#only default the general types - these form defaults for more specific types if they're missing + if {[llength $f] % 2 != 0} { + #todo - retrieve usage from punk::args + error "textblock::frametype frametype '$f' is not one of the predefined frametypes: $textblock::frametypes and does not appear to be a dictionary for a custom frametype" } - if {[tcl::dict::exists $custom_frame hlb]} { - set hlb [tcl::dict::get $custom_frame hlb] - } else { - set hlb $hl - } - - if {[tcl::dict::exists $custom_frame vll]} { - set vll [tcl::dict::get $custom_frame vll] - } else { - set vll $vl + #unknown order of keys specified by user - validate before creating vars as we need more general elements to be available as defaults + dict for {k v} $f { + switch -- $k { + hl - vl - tlc - trc - blc - brc - hlt - hlb - vll - vlr - hltj - hlbj - vllj - vlrj {} + default { + error "textblock::frametype '$f' has unknown element '$k'" + } + } } - if {[tcl::dict::exists $custom_frame vlr]} { - set vlr [tcl::dict::get $custom_frame vlr] - } else { - set vlr $vl + #verified keys - safe to extract as vars + set custom_frame [tcl::dict::merge $default_custom $f] + tcl::dict::with custom_frame {} ;#extract keys as vars + #longer j vars must be after their more specific counterparts in the list being processed by foreach + foreach t {hlt hlb vll vlr hltj hlbj vllj vlrj} { + if {[tcl::dict::exists $custom_frame $t]} { + set $t [tcl::dict::get $custom_frame $t] + } else { + #set more explicit type to it's more general counterpart if it's missing + #e.g hlt -> hl + #e.g hltj -> hlt + set $t [set [string range $t 0 end-1]] + } } - #horizontal and vertical bar joins - set hltj $hlt - set hlbj $hlb - set vllj $vll - set vlrj $vlr + #assert vars hl vl tlc trc blc brc hlt hlb vll vlr hltj hlbj vllj vlrj are all set + #horizontal and vertical bar joins - key/variable ends with 'j' } } if {$boxonly} { @@ -6096,33 +6340,44 @@ tcl::namespace::eval textblock { variable frame_cache set frame_cache [tcl::dict::create] - proc frame_cache {{action ""}} { + proc frame_cache {args} { + set argd [punk::args::get_dict { + -action -default "" -choices {clear} -help "Clear the textblock::frame_cache dictionary" + -pretty -default 1 -help "Use 'pdict textblock::frame_cache */*' for prettier output" + *values -min 0 -max 0 + } $args] + set action [dict get $argd opts -action] + if {$action ni [list clear ""]} { error "frame_cache action '$action' not understood. Valid actions: clear" } variable frame_cache - set out "" - if {[catch { - set termwidth [tcl::dict::get [punk::console::get_size] columns] - }]} { - set termwidth 80 - } + if {[dict get $argd opts -pretty]} { + set out [pdict -chan none frame_cache */*] + } else { + set out "" + if {[catch { + set termwidth [tcl::dict::get [punk::console::get_size] columns] + }]} { + set termwidth 80 + } - tcl::dict::for {k v} $frame_cache { - lassign $v _f frame _used used - set fwidth [textblock::widthtopline $frame] - #review - are cached frames uniform width lines? - #set fwidth [textblock::width $frame] - set frameinfo "$k used:$used " - set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] - if {$allinone_width >= $termwidth} { - #split across 2 lines - append out "$frameinfo\n" - append out $frame \n - } else { - append out [textblock::join -- $frameinfo $frame]\n + tcl::dict::for {k v} $frame_cache { + lassign $v _f frame _used used + set fwidth [textblock::widthtopline $frame] + #review - are cached frames uniform width lines? + #set fwidth [textblock::width $frame] + set frameinfo "$k used:$used " + set allinone_width [expr {[tcl::string::length $frameinfo] + $fwidth}] + if {$allinone_width >= $termwidth} { + #split across 2 lines + append out "$frameinfo\n" + append out $frame \n + } else { + append out [textblock::join -- $frameinfo $frame]\n + } + append out \n ;# frames used to build tables often have joins - keep a line in between for clarity } - append out \n ;# frames used to build tables often have joins - keep a line in between for clarity } if {$action eq "clear"} { set frame_cache [tcl::dict::create] @@ -6270,7 +6525,7 @@ tcl::namespace::eval textblock { } } switch -- $target { - "" - light - heavy - ascii - altg - arc - double - custom - block - block1 {} + "" - light - heavy - ascii - altg - arc - double - custom - block - block1 - block2 {} default { set is_joins_ok 0 break @@ -6473,7 +6728,7 @@ tcl::namespace::eval textblock { set vll_width 1 ;#default for all except custom (printing width) set vlr_width 1 - set framedef [textblock::framedef $framedef -joins $opt_joins] + set framedef [textblock::framedef -joins $opt_joins $framedef] tcl::dict::with framedef {} ;#extract vll,hlt,tlc etc vars #puts "---> $opt_boxmap" @@ -6846,15 +7101,24 @@ tcl::namespace::eval textblock { return $fs } } - proc gcross {{size 1} args} { + proc gcross {args} { + set argd [punk::args::get_dict { + -max_cross_size -default 0 -type integer -help "Largest size cross to use to make up the block + Only cross sizes that divide the size of the overall block will be used. + e.g if the 'size' chosen is 19 (a prime number) - only 1 or the full size of 19 can be used as the crosses to make up the block. + Whereas for a block size of 24, -max_cross_size of 1,2,3,4,6,8,12 or 24 will work. (all divisors) + If a number chosen for -max_cross_size isn't a divisor, the largest divisor below the chosen value will be used. + " + *values -min 1 + size -default 1 -type integer + } $args] + set size [dict get $argd values size] + set opts [dict get $argd opts] + if {$size == 0} { return "" } - set defaults [list\ - -max_cross_size 0 - ] - set opts [tcl::dict::merge $defaults $args] set opt_max_cross_size [tcl::dict::get $opts -max_cross_size] #set fit_size [punk::lib::greatestOddFactor $size] @@ -6932,14 +7196,14 @@ tcl::namespace::eval textblock { #Test we can join two coloured blocks proc test_colour {} { - set b1 [a= red]1\n2\n3[a=] - set b2 [a= green]a\nb\nc[a=] - set result [textblock::join $b1 $b2] + set b1 [a red]1\n2\n3[a] + set b2 [a green]a\nb\nc[a] + set result [textblock::join -- $b1 $b2] puts $result #return [list $b1 $b2 $result] return [ansistring VIEW $result] } - tcl::namespace::import ::punk::ansi::stripansi + tcl::namespace::import ::punk::ansi::ansistrip } diff --git a/src/bootsupport/modules_tcl8/include_modules.config b/src/bootsupport/modules_tcl8/include_modules.config new file mode 100644 index 00000000..05ce61ae --- /dev/null +++ b/src/bootsupport/modules_tcl8/include_modules.config @@ -0,0 +1,9 @@ + +#bootsupport modules can be pulled in from within other areas of src or from the built module folders of the project +#They must be already built, so generally shouldn't come directly from src/modules. + +#each entry - base module +set bootsupport_modules [list\ + modules_tcl8 thread\ +] + diff --git a/src/make.tcl b/src/make.tcl index f4eef65f..e25031ed 100644 --- a/src/make.tcl +++ b/src/make.tcl @@ -13,7 +13,7 @@ namespace eval ::punkmake { variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] variable help_flags [list -help --help /?] - variable known_commands [list project get-project-info shell bootsupport] + variable known_commands [list project get-project-info shell vendorupdate bootsupport] } if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" @@ -134,6 +134,8 @@ proc punkmake_gethelp {args} { append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n append h " $scriptname bootsupport" \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n \n + append h " $scriptname vendorupdate" \n + append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " $scriptname get-project-info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n @@ -251,124 +253,225 @@ if {$::punkmake::command eq "shell"} { exit 1 } -if {$::punkmake::command eq "bootsupport"} { +if {$::punkmake::command eq "vendorupdate"} { puts "projectroot: $projectroot" puts "script: [info script]" #puts "-- [tcl::tm::list] --" - puts stdout "Updating bootsupport from local files" - - proc bootsupport_localupdate {projectroot} { - set bootsupport_modules [list] - set bootsupport_module_folders [list] - set bootsupport_config $projectroot/src/bootsupport/include_modules.config ;# - if {[file exists $bootsupport_config]} { - set targetroot $projectroot/src/bootsupport/modules - source $bootsupport_config ;#populate $bootsupport_modules with project-specific list - if {![llength $bootsupport_modules]} { - puts stderr "No local bootsupport modules configured for updating" - } else { - - if {[catch { - #---------- - set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] - $boot_installer set_source_target $projectroot $projectroot/src/bootsupport - set boot_event [$boot_installer start_event {-make_step bootsupport}] - #---------- - } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" - set boot_event "" + puts stdout "Updating vendor modules in src folder" + + proc vendor_localupdate {projectroot} { + set local_modules [list] + set git_modules [list] + set fossil_modules [list] + set sourcefolder $projectroot/src + #todo vendor/lib + set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] + + set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] + lappend vendormodulefolders vendormodules + foreach vf $vendormodulefolders { + if {[file exists $sourcefolder/$vf]} { + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" } - foreach {relpath module} $bootsupport_modules { - set module [string trim $module :] - set module_subpath [string map [list :: /] [namespace qualifiers $module]] - set srclocation [file join $projectroot $relpath $module_subpath] - #puts stdout "$relpath $module $module_subpath $srclocation" - set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] - #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 - if {![llength $pkgmatches]} { - puts stderr "Missing source for bootsupport module $module - not found in $srclocation" - continue - } - set latestfile [lindex $pkgmatches 0] - set latestver [lindex [split [file rootname $latestfile] -] 1] - foreach m $pkgmatches { - lassign [split [file rootname $m] -] _pkg ver - #puts "comparing $ver vs $latestver" - if {[package vcompare $ver $latestver] == 1} { - set latestver $ver - set latestfile $m - } - } - set srcfile [file join $srclocation $latestfile] - set tgtfile [file join $targetroot $module_subpath $latestfile] - if {$boot_event ne ""} { - #---------- - $boot_event targetset_init INSTALL $tgtfile - $boot_event targetset_addsource $srcfile - #---------- - if {\ - [llength [dict get [$boot_event targetset_source_changes] changed]]\ - || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ - } { - file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists - $boot_event targetset_started - # -- --- --- --- --- --- - puts "BOOTSUPPORT update: $srcfile -> $tgtfile" - if {[catch { - file copy -force $srcfile $tgtfile - } errM]} { - $boot_event targetset_end FAILED + set vendor_config $sourcefolder/vendormodules$which/include_modules.config + if {[file exists $vendor_config]} { + set targetroot $sourcefolder/vendormodules$which + source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list + if {![llength $local_modules]} { + puts stderr "src/vendormodules$which No local vendor modules configured for updating (config file: $vendor_config)" + } else { + if {[catch { + #---------- + set vendor_installer [punkcheck::installtrack new make.tcl $sourcefolder/vendormodules$which/.punkcheck] + $vendor_installer set_source_target $projectroot $sourcefolder/vendormodules$which + set installation_event [$vendor_installer start_event {-make_step vendorupdate}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for vendormodules$which update. Error: $errM" + set installation_event "" + } + foreach {relpath module} $local_modules { + set module [string trim $module :] + set module_subpath [string map {:: /} [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for vendor module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$installation_event ne ""} { + #---------- + $installation_event targetset_init INSTALL $tgtfile + $installation_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$installation_event targetset_source_changes] changed]]\ + || [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $installation_event targetset_started + # -- --- --- --- --- --- + puts "VENDORMODULES$which update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $installation_event targetset_end FAILED + } else { + $installation_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $installation_event targetset_end SKIPPED + } + $installation_event end } else { - $boot_event targetset_end OK + file copy -force $srcfile $tgtfile } - # -- --- --- --- --- --- - } else { - puts -nonewline stderr "." - $boot_event targetset_end SKIPPED } - $boot_event end - } else { - file copy -force $srcfile $tgtfile + } - } - if {$boot_event ne ""} { - puts \n - $boot_event destroy - $boot_installer destroy + } else { + puts stderr "No config at $vendor_config - nothing configured to update" } } + } + } - if {[llength $bootsupport_module_folders] % 2 != 0} { - #todo - change include_modules.config structure to be line based? we have no way of verifying paired entries because we accept a flat list - puts stderr "WARNING - Skipping bootsupport_module_folders - list should be a list of base subpath pairs" - } else { - foreach {base subfolder} $bootsupport_module_folders { - #user should be careful not to include recursive/cyclic structures e.g module that has a folder which contains other modules from this project - #It will probably work somewhat.. but may make updates confusing.. or worse - start making deeper and deeper copies - set src [file join $projectroot $base $subfolder] - if {![file isdirectory $src]} { - puts stderr "bootsupport folder not found: $src" - continue - } + vendor_localupdate $projectroot + + puts stdout " vendor package update done " + flush stderr + flush stdout + ::exit 0 +} - #subfolder is the common relative path - so don't include the base in the target path - set tgt [file join $targetroot $subfolder] - file mkdir $tgt +if {$::punkmake::command eq "bootsupport"} { + puts "projectroot: $projectroot" + puts "script: [info script]" + #puts "-- [tcl::tm::list] --" + puts stdout "Updating bootsupport from local files" - puts stdout "BOOTSUPPORT non_tm_files $src - copying to $tgt (if source file changed)" - set overwrite "installedsourcechanged-targets" - set resultdict [punkcheck::install_non_tm_files $src $tgt -installer make.tcl -overwrite $overwrite -punkcheck_folder $projectroot/src/bootsupport] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] + proc bootsupport_localupdate {projectroot} { + set bootsupport_modules [list] ;#variable populated by include_modules.config file - review + + set bootmodulefolders [glob -nocomplain -dir $sourcefolder/bootsupport -type d -tails modules_tcl*] + lappend bootmodulefolder modules + foreach bm $bootmodulefolders { + if {[file exists $sourcefolder/bootsupport/$bm]} { + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" } - } + set bootsupport_config $projectroot/src/bootsupport/modules$which/include_modules.config ;# + if {[file exists $bootsupport_config]} { + set targetroot $projectroot/src/bootsupport/modules$which + source $bootsupport_config ;#populate $bootsupport_modules with project-specific list + if {![llength $bootsupport_modules]} { + puts stderr "bootsupport/modules$which - No local bootsupport modules configured for updating" + } else { + if {[catch { + #---------- + set boot_installer [punkcheck::installtrack new make.tcl $projectroot/src/bootsupport/.punkcheck] + $boot_installer set_source_target $projectroot $projectroot/src/bootsupport + set boot_event [$boot_installer start_event {-make_step bootsupport}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for bootsupport error: $errM" + set boot_event "" + } + + foreach {relpath module} $bootsupport_modules { + set module [string trim $module :] + set module_subpath [string map [list :: /] [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for bootsupport module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$boot_event ne ""} { + #---------- + $boot_event targetset_init INSTALL $tgtfile + $boot_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$boot_event targetset_source_changes] changed]]\ + || [llength [$boot_event get_targets_exist]] < [llength [$boot_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $boot_event targetset_started + # -- --- --- --- --- --- + puts "BOOTSUPPORT module$which update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $boot_event targetset_end FAILED + } else { + $boot_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $boot_event targetset_end SKIPPED + } + $boot_event end + } else { + file copy -force $srcfile $tgtfile + } + } + if {$boot_event ne ""} { + puts \n + $boot_event destroy + $boot_installer destroy + } + } + + } + } } } bootsupport_localupdate $projectroot - #/modules/punk/mix/templates/layouts only applies if the project has it's own copy of the punk/mix modules. Generally this should only apply to the punkshell project itself. + #if this project has custom project layouts, and there is a bootsupport folder - update their bootsupport + set layout_bases [list\ $sourcefolder/project_layouts/custom/_project\ ] @@ -381,14 +484,26 @@ if {$::punkmake::command eq "bootsupport"} { set antipaths [list\ README.md\ ] - set sourcemodules $projectroot/src/bootsupport/modules - set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules] - file mkdir $targetroot - - puts stdout "BOOTSUPPORT layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" - set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] - flush stdout + set boot_module_folders [glob -nocomplain -dir $projectroot/src/bootsupport/modules_tcl*] + lappend bootsupport_module_folders "modules" + foreach bm $bootsupport_module_folders { + if {[file exists $projectroot/src/bootsupport/$bm]} { + lassign [split $bm _] _bm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set sourcemodules $projectroot/src/bootsupport/modules$which + set targetroot [file join $project_layout_base $layoutname/src/bootsupport/modules$which] + file mkdir $targetroot + + puts stdout "BOOTSUPPORT$which layouts/$layoutname: copying from $sourcemodules to $targetroot (if source file changed)" + set resultdict [punkcheck::install $sourcemodules $targetroot -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + flush stdout + } + } } } } else { @@ -412,39 +527,66 @@ if {$::punkmake::command ne "project"} { exit 1 } -file mkdir $projectroot/lib ;#needs to exist - -#only a single consolidated /modules folder used for target -set target_modules_base $projectroot/modules -file mkdir $target_modules_base #external libs and modules first - and any supporting files - no 'building' required -if {[file exists $sourcefolder/vendorlib]} { - #exclude README.md from source folder - but only the root one - #-antiglob_paths takes relative patterns e.g - # */test.txt will only match test.txt exactly one level deep. - # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. - # **/test.txt will match at any level below the root (but not in the root) - set antipaths [list\ - README.md\ - ] - puts stdout "VENDORLIB: copying from $sourcefolder/vendorlib to $projectroot/lib (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/vendorlib $projectroot/lib -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] +#install src vendor contents (from version controlled src folder) to base of project (same target folders as our own src/modules etc ie to paths that go on the auto_path and in tcl::tm::list) -} else { - puts stderr "VENDORLIB: No src/vendorlib folder found." +set vendorlibfolders [glob -nocomplain -dir $sourcefolder -type d -tails vendorlib_tcl*] +lappend vendorlibfolders vendorlib + +foreach lf $vendorlibfolders { + if {[file exists $sourcefolder/$lf]} { + lassign [split $lf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_lib_folder $projectroot/lib$which + file mkdir $projectroot/lib$which + + #exclude README.md from source folder - but only the root one + #-antiglob_paths takes relative patterns e.g + # */test.txt will only match test.txt exactly one level deep. + # */*/*.foo will match any path ending in .foo that is exactly 2 levels deep. + # **/test.txt will match at any level below the root (but not in the root) + set antipaths [list\ + README.md\ + ] + + puts stdout "VENDORLIB$which: copying from $sourcefolder/$lf to $target_lib_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$lf $target_lib_folder -overwrite installedsourcechanged-targets -antiglob_paths $antipaths] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } +} +if {![llength $vendorlibfolders]} { + puts stderr "VENDORLIB: No src/vendorlib or src/vendorlib_tcl* folder found." } -if {[file exists $sourcefolder/vendormodules]} { - #install .tm *and other files* - puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}] - puts stdout [punkcheck::summarize_install_resultdict $resultdict] -} else { - puts stderr "VENDORMODULES: No src/vendormodules folder found." +set vendormodulefolders [glob -nocomplain -dir $sourcefolder -type d -tails vendormodules_tcl*] +lappend vendormodulefolders vendormodules + +foreach vf $vendormodulefolders { + if {[file exists $sourcefolder/$vf]} { + lassign [split $vf _] _vm tclx + if {$tclx ne ""} { + set which _$tclx + } else { + set which "" + } + set target_module_folder $projectroot/modules$which + file mkdir $target_module_folder + + #install .tm *and other files* + puts stdout "VENDORMODULES$which: copying from $sourcefolder/$vf to $target_module_folder (if source file changed)" + set resultdict [punkcheck::install $sourcefolder/$vf $target_module_folder -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] + puts stdout [punkcheck::summarize_install_resultdict $resultdict] + } +} +if {![llength $vendormodulefolders]} { + puts stderr "VENDORMODULES: No src/vendormodules or src/vendormodules_tcl* folders found." } ######################################################## @@ -516,11 +658,22 @@ foreach layoutbase $layout_bases { } ######################################################## +#consolidated /modules /modules_tclX folder used for target where X is tcl major version +#the make process will process for any _tclX not just the major version of the current interpreter -#default source module folder is at projectroot/src/modules +#default source module folders are at projectroot/src/modules and projectroot/src/modules_tclX (where X is tcl major version) #There may be multiple other src module folders at same level (e.g folder not being other special-purpose folder and not matching name vendor* that contains at least one .tm file in its root) set source_module_folderlist [punk::mix::cli::lib::find_source_module_paths $projectroot] +puts stdout "SOURCEMODULES: scanning [llength $source_module_folderlist] folders" foreach src_module_dir $source_module_folderlist { + set mtail [file tail $src_module_dir] + if {[string match "modules_tcl*" $mtail]} { + set target_modules_base $projectroot/$mtail + } else { + set target_modules_base $projectroot/modules + } + file mkdir $target_modules_base + puts stderr "Processing source module dir: $src_module_dir" set dirtail [file tail $src_module_dir] #modules and associated files belonging to this package/app diff --git a/src/modules/#modpod-modpodtest-999999.0a1.0/#modpod-loadscript.tcl b/src/modules/#modpod-modpodtest-999999.0a1.0/#modpod-loadscript.tcl new file mode 100644 index 00000000..9487b6e6 --- /dev/null +++ b/src/modules/#modpod-modpodtest-999999.0a1.0/#modpod-loadscript.tcl @@ -0,0 +1,53 @@ +apply {code { + set scriptpath [file normalize [info script]] + if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { + #jump up an extra dir level if we are within a #modpod-loadscript file. + set mypath [file dirname [file dirname $scriptpath]] + #expect to be in folder #modpod-- + #Now we need to test if we are in a mounted folder vs an extracted folder + set container [file dirname $mypath] + if {[string match "#mounted-modpod-*" $container]} { + set mypath [file dirname $container] + } + set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-- + } else { + set mypath [file dirname $scriptpath] + set modver [file root [file tail [info script]]] + } + set mysegs [file split $mypath] + set overhang [list] + foreach libpath [tcl::tm::list] { + set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / + if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { + #mypath is below libpath + set overhang [lrange $mysegs [llength $libsegs]+1 end] + break + } + } + lassign [split $modver -] moduletail version + set ns [join [concat $overhang $moduletail] ::] + #if {![catch {package require modpod}]} { + # ::modpod::disconnect [info script] + #} + package provide $ns $version + namespace eval $ns $code +} ::} { + # + # Module procs here, where current namespace is that of the module. + # Package version can, if needed, be accessed as [uplevel 1 {set version}] + # Last element of module name: [uplevel 1 {set moduletail}] + # Full module name: [uplevel 1 {set ns}] + + # + # + # + + # + # + # + + # + # + # + +} diff --git a/src/modules/#modpod-modpodtest-999999.0a1.0/#z b/src/modules/#modpod-modpodtest-999999.0a1.0/#z new file mode 100644 index 00000000..a8f7b05a --- /dev/null +++ b/src/modules/#modpod-modpodtest-999999.0a1.0/#z @@ -0,0 +1,2 @@ +#Do not remove the trailing ctrl-z character from this file + \ No newline at end of file diff --git a/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm b/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm new file mode 100644 index 00000000..b10d2cb9 --- /dev/null +++ b/src/modules/#modpod-modpodtest-999999.0a1.0/modpodtest-999999.0a1.0.tm @@ -0,0 +1,181 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# 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) 2024 +# +# @@ Meta Begin +# Application modpodtest 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_modpodtest 0 999999.0a1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require modpodtest] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of modpodtest +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by modpodtest +#[list_begin itemized] + +package require Tcl 8.6- +#*** !doctools +#[item] [package {Tcl 8.6}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval modpodtest::class { + #*** !doctools + #[subsection {Namespace modpodtest::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval modpodtest { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace modpodtest}] + #[para] Core API functions for modpodtest + #[list_begin definitions] + + + + #proc sample1 {p1 n args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] + # #[para]Description of sample1 + # #[para] Arguments: + # # [list_begin arguments] + # # [arg_def tring p1] A description of string argument p1. + # # [arg_def integer n] A description of integer argument n. + # # [list_end] + # return "ok" + #} + + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpodtest ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval modpodtest::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace modpodtest::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpodtest::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval modpodtest::system { + #*** !doctools + #[subsection {Namespace modpodtest::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide modpodtest [tcl::namespace::eval modpodtest { + variable pkg modpodtest + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/#modpod-zipper-0.11/zipper-0.11.tm b/src/modules/#modpod-zipper-0.11/zipper-0.11.tm new file mode 100644 index 00000000..2e9b8baa --- /dev/null +++ b/src/modules/#modpod-zipper-0.11/zipper-0.11.tm @@ -0,0 +1,120 @@ +# ZIP file constructor + +package provide zipper 0.11 + +namespace eval zipper { + namespace export initialize addentry finalize + + namespace eval v { + variable fd + variable base + variable toc + } + + proc initialize {fd} { + set v::fd $fd + set v::base [tell $fd] + set v::toc {} + fconfigure $fd -translation binary -encoding binary + } + + proc emit {s} { + puts -nonewline $v::fd $s + } + + proc dostime {sec} { + set f [clock format $sec -format {%Y %m %d %H %M %S} -gmt 1] + regsub -all { 0(\d)} $f { \1} f + foreach {Y M D h m s} $f break + set date [expr {(($Y-1980)<<9) | ($M<<5) | $D}] + set time [expr {($h<<11) | ($m<<5) | ($s>>1)}] + return [list $date $time] + } + + proc addentry {name contents {date ""} {force 0}} { + if {$date == ""} { set date [clock seconds] } + foreach {date time} [dostime $date] break + set flag 0 + set type 0 ;# stored + set fsize [string length $contents] + set csize $fsize + set fnlen [string length $name] + + if {$force > 0 && $force != [string length $contents]} { + set csize $fsize + set fsize $force + set type 8 ;# if we're passing in compressed data, it's deflated + } + + if {[catch { zlib crc32 $contents } crc]} { + set crc 0 + } elseif {$type == 0} { + set cdata [zlib deflate $contents] + if {[string length $cdata] < [string length $contents]} { + set contents $cdata + set csize [string length $cdata] + set type 8 ;# deflate + } + } + + lappend v::toc "[binary format a2c6ssssiiiss4ii PK {1 2 20 0 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen \ + {0 0 0 0} 128 [tell $v::fd]]$name" + + emit [binary format a2c4ssssiiiss PK {3 4 20 0} \ + $flag $type $time $date $crc $csize $fsize $fnlen 0] + emit $name + emit $contents + } + + proc finalize {} { + set pos [tell $v::fd] + + set ntoc [llength $v::toc] + foreach x $v::toc { emit $x } + set v::toc {} + + set len [expr {[tell $v::fd] - $pos}] + incr pos -$v::base + + emit [binary format a2c2ssssiis PK {5 6} 0 0 $ntoc $ntoc $len $pos 0] + + return $v::fd + } +} + +if {[info exists pkgtest] && $pkgtest} { + puts "no test code" +} + +# test code below runs when this is launched as the main script +if {[info exists argv0] && [string match zipper-* [file tail $argv0]]} { + + catch { package require zlib } + + zipper::initialize [open try.zip w] + + set dirs [list .] + while {[llength $dirs] > 0} { + set d [lindex $dirs 0] + set dirs [lrange $dirs 1 end] + foreach f [lsort [glob -nocomplain [file join $d *]]] { + if {[file isfile $f]} { + regsub {^\./} $f {} f + set fd [open $f] + fconfigure $fd -translation binary -encoding binary + zipper::addentry $f [read $fd] [file mtime $f] + close $fd + } elseif {[file isdir $f]} { + lappend dirs $f + } + } + } + + close [zipper::finalize] + + puts "size = [file size try.zip]" + puts [exec unzip -v try.zip] + + file delete try.zip +} diff --git a/src/modules/#modpod-zipper-0.11/zipper.README b/src/modules/#modpod-zipper-0.11/zipper.README new file mode 100644 index 00000000..9af16f04 --- /dev/null +++ b/src/modules/#modpod-zipper-0.11/zipper.README @@ -0,0 +1,28 @@ +Creating ZIP archives in Tcl +============================ + + Rev 0.11: Added ?force? arg to bypass re-compression + Rev 0.10: Initial release + + +Zipper is a package to create ZIP archives with a few simple commands: + + zipper::initialize $fd + initialize things to start writing zip file entries + + zipper::addentry name contents ?date? ?force? + add one entry, modification date defaults to [clock seconds] + + zipper::finalize + write trailing table of contents, returns file descriptor + +Example: + + package require zipper + zipper::initialize [open try.zip w] + zipper::addentry dir/file.txt "some data to store" + close [zipper::finalize] + +If the "zlib" package is available, it will be used to to compress the +data when possible and to calculate proper CRC-32 checksums. Otherwise, +the output file will contain uncompressed data and zero checksums. diff --git a/src/modules/modpodtest-buildversion.txt b/src/modules/modpodtest-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/modpodtest-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/oolib-0.1.2.tm b/src/modules/oolib-0.1.2.tm index af5da523..858c61cd 100644 --- a/src/modules/oolib-0.1.2.tm +++ b/src/modules/oolib-0.1.2.tm @@ -1,201 +1,201 @@ -#JMN - api should be kept in sync with package patternlib where possible -# -package provide oolib [namespace eval oolib { - variable version - set version 0.1.2 -}] - -namespace eval oolib { - oo::class create collection { - variable o_data ;#dict - #variable o_alias - constructor {} { - set o_data [dict create] - } - method info {} { - return [dict info $o_data] - } - method count {} { - return [dict size $o_data] - } - method isEmpty {} { - expr {[dict size $o_data] == 0} - } - method names {{globOrIdx {}}} { - if {[llength $globOrIdx]} { - if {[string is integer -strict $globOrIdx]} { - set idx $globOrIdx - if {$idx < 0} { - set idx "end-[expr {abs($idx + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $idx} result]} { - error "[self object] no such index : '$idx'" - } else { - return $result - } - } else { - #glob - return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] - } - } else { - return [dict keys $o_data] - } - } - #like names but without globbing - method keys {} { - dict keys $o_data - } - method key {{posn 0}} { - if {$posn < 0} { - set posn "end-[expr {abs($posn + 1)}]" - } - if {[catch {lindex [dict keys $o_data] $posn} result]} { - error "[self object] no such index : '$posn'" - } else { - return $result - } - } - method hasKey {key} { - dict exists $o_data $key - } - method get {} { - return $o_data - } - method items {} { - return [dict values $o_data] - } - method item {key} { - if {[string is integer -strict $key]} { - if {$key >= 0} { - set valposn [expr {(2*$key) +1}] - return [lindex $o_data $valposn] - } else { - set key "end-[expr {abs($key + 1)}]" - return [lindex $o_data $key] - #return [lindex [dict keys $o_data] $key] - } - } - if {[dict exists $o_data $key]} { - return [dict get $o_data $key] - } - } - #inverse lookup - method itemKeys {value} { - set value_indices [lsearch -all [dict values $o_data] $value] - set keylist [list] - foreach i $value_indices { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - method search {value args} { - set matches [lsearch {*}$args [dict values $o_data] $value] - if {"-inline" in $args} { - return $matches - } else { - set keylist [list] - foreach i $matches { - set idx [expr {(($i + 1) *2) -2}] - lappend keylist [lindex $o_data $idx] - } - return $keylist - } - } - #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? - #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? - #method alias {newAlias existingKeyOrAlias} { - # if {[string is integer -strict $newAlias]} { - # error "[self object] collection key alias cannot be integer" - # } - # if {[string length $existingKeyOrAlias]} { - # set o_alias($newAlias) $existingKeyOrAlias - # } else { - # unset o_alias($newAlias) - # } - #} - #method aliases {{key ""}} { - # if {[string length $key]} { - # set result [list] - # foreach {n v} [array get o_alias] { - # if {$v eq $key} { - # lappend result $n $v - # } - # } - # return $result - # } else { - # return [array get o_alias] - # } - #} - ##if the supplied index is an alias, return the underlying key; else return the index supplied. - #method realKey {idx} { - # if {[catch {set o_alias($idx)} key]} { - # return $idx - # } else { - # return $key - # } - #} - method add {value key} { - if {[string is integer -strict $key]} { - error "[self object] collection key must not be an integer. Use another structure if integer keys required" - } - if {[dict exists $o_data $key]} { - error "[self object] col_processors object error: key '$key' already exists in collection" - } - dict set o_data $key $value - return [expr {[dict size $o_data] - 1}] ;#return index of item - } - method remove {idx {endRange ""}} { - if {[string length $endRange]} { - error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" - } - if {[string is integer -strict $idx]} { - if {$idx < 0} { - set idx "end-[expr {abs($idx+1)}]" - } - set key [lindex [dict keys $o_data] $idx] - set posn $idx - } else { - set key $idx - set posn [lsearch -exact [dict keys $o_data] $key] - if {$posn < 0} { - error "[self object] no such index: '$idx' in this collection" - } - } - dict unset o_data $key - return - } - method clear {} { - set o_data [dict create] - return - } - method reverse_the_collection {} { - #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs - #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. - #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. - set dictnew [dict create] - foreach k [lreverse [dict keys $o_data]] { - dict set dictnew $k [dict get $o_data $k] - } - set o_data $dictnew - return - } - #review - cmd as list vs cmd as script? - method map {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list {*}$cmd $v]] - } - return $seed - } - method objectmap {cmd} { - set seed [list] - dict for {k v} $o_data { - lappend seed [uplevel #0 [list $v {*}$cmd]] - } - return $seed - } - } - -} - +#JMN - api should be kept in sync with package patternlib where possible +# +package provide oolib [namespace eval oolib { + variable version + set version 0.1.2 +}] + +namespace eval oolib { + oo::class create collection { + variable o_data ;#dict + #variable o_alias + constructor {} { + set o_data [dict create] + } + method info {} { + return [dict info $o_data] + } + method count {} { + return [dict size $o_data] + } + method isEmpty {} { + expr {[dict size $o_data] == 0} + } + method names {{globOrIdx {}}} { + if {[llength $globOrIdx]} { + if {[string is integer -strict $globOrIdx]} { + set idx $globOrIdx + if {$idx < 0} { + set idx "end-[expr {abs($idx + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $idx} result]} { + error "[self object] no such index : '$idx'" + } else { + return $result + } + } else { + #glob + return [lsearch -glob -all -inline [dict keys $o_data] $globOrIdx] + } + } else { + return [dict keys $o_data] + } + } + #like names but without globbing + method keys {} { + dict keys $o_data + } + method key {{posn 0}} { + if {$posn < 0} { + set posn "end-[expr {abs($posn + 1)}]" + } + if {[catch {lindex [dict keys $o_data] $posn} result]} { + error "[self object] no such index : '$posn'" + } else { + return $result + } + } + method hasKey {key} { + dict exists $o_data $key + } + method get {} { + return $o_data + } + method items {} { + return [dict values $o_data] + } + method item {key} { + if {[string is integer -strict $key]} { + if {$key >= 0} { + set valposn [expr {(2*$key) +1}] + return [lindex $o_data $valposn] + } else { + set key "end-[expr {abs($key + 1)}]" + return [lindex $o_data $key] + #return [lindex [dict keys $o_data] $key] + } + } + if {[dict exists $o_data $key]} { + return [dict get $o_data $key] + } + } + #inverse lookup + method itemKeys {value} { + set value_indices [lsearch -all [dict values $o_data] $value] + set keylist [list] + foreach i $value_indices { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + method search {value args} { + set matches [lsearch {*}$args [dict values $o_data] $value] + if {"-inline" in $args} { + return $matches + } else { + set keylist [list] + foreach i $matches { + set idx [expr {(($i + 1) *2) -2}] + lappend keylist [lindex $o_data $idx] + } + return $keylist + } + } + #review - see patternlib. Is the intention for aliases to be configurable independent of whether the target exists? + #review - what is the point of alias anyway? - why slow down other operations when a variable can hold a keyname perfectly well? + #method alias {newAlias existingKeyOrAlias} { + # if {[string is integer -strict $newAlias]} { + # error "[self object] collection key alias cannot be integer" + # } + # if {[string length $existingKeyOrAlias]} { + # set o_alias($newAlias) $existingKeyOrAlias + # } else { + # unset o_alias($newAlias) + # } + #} + #method aliases {{key ""}} { + # if {[string length $key]} { + # set result [list] + # foreach {n v} [array get o_alias] { + # if {$v eq $key} { + # lappend result $n $v + # } + # } + # return $result + # } else { + # return [array get o_alias] + # } + #} + ##if the supplied index is an alias, return the underlying key; else return the index supplied. + #method realKey {idx} { + # if {[catch {set o_alias($idx)} key]} { + # return $idx + # } else { + # return $key + # } + #} + method add {value key} { + if {[string is integer -strict $key]} { + error "[self object] collection key must not be an integer. Use another structure if integer keys required" + } + if {[dict exists $o_data $key]} { + error "[self object] col_processors object error: key '$key' already exists in collection" + } + dict set o_data $key $value + return [expr {[dict size $o_data] - 1}] ;#return index of item + } + method remove {idx {endRange ""}} { + if {[string length $endRange]} { + error "[self object] collection error: ranged removal not yet implemented.. remove one item at a time" + } + if {[string is integer -strict $idx]} { + if {$idx < 0} { + set idx "end-[expr {abs($idx+1)}]" + } + set key [lindex [dict keys $o_data] $idx] + set posn $idx + } else { + set key $idx + set posn [lsearch -exact [dict keys $o_data] $key] + if {$posn < 0} { + error "[self object] no such index: '$idx' in this collection" + } + } + dict unset o_data $key + return + } + method clear {} { + set o_data [dict create] + return + } + method reverse_the_collection {} { + #named slightly obtusely because reversing the data when there may be references held is a potential source of bugs + #the name reverse_the_collection should make it clear that the object is being modified in place as opposed to simply 'reverse' which may imply a view/copy. + #todo - consider implementing a get_reverse which provides an interface to the same collection without affecting original references, yet both allowing delete/edit operations. + set dictnew [dict create] + foreach k [lreverse [dict keys $o_data]] { + dict set dictnew $k [dict get $o_data $k] + } + set o_data $dictnew + return + } + #review - cmd as list vs cmd as script? + method map {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list {*}$cmd $v]] + } + return $seed + } + method objectmap {cmd} { + set seed [list] + dict for {k v} $o_data { + lappend seed [uplevel #0 [list $v {*}$cmd]] + } + return $seed + } + } + +} + diff --git a/src/modules/punk-0.1.tm b/src/modules/punk-0.1.tm index 6821acc8..afeacf7e 100644 --- a/src/modules/punk-0.1.tm +++ b/src/modules/punk-0.1.tm @@ -505,6 +505,8 @@ namespace eval punk { proc splitstrposn_nonzero {s p} { scan $s %${p}s%s } + + #split top level of patterns only. proc _split_patterns {varspecs} { set name_mapped [pipecmd_namemapping $varspecs] set cmdname ::punk::pipecmds::split_patterns_$name_mapped @@ -519,11 +521,13 @@ namespace eval punk { # % string functions # ! not set var_terminals [list "@" "/" "#" "%" "!" ">" "<"] ;# (> required for insertionspecs at rhs of = & .= ) + #right bracket ) also ends a var - but is different depending on whether var is array or basic. For array - it forms part of the varname + #except when prefixed directly by pin classifier ^ set protect_terminals [list "^"] ;# e.g sequence ^# #also - an atom usually doesn't need the / as a terminal - because it can't match a missing element unless it's empty string #ie the one usecase is '/n to match either empty string or missing item at position n. For this one usecase - we miss the capability to atom match paths/urls .. '/usr/local/et' - set in_brackets 0 + set in_brackets 0 ;#count depth set in_atom 0 #set varspecs [string trimleft $varspecs ,] set token "" @@ -532,22 +536,38 @@ namespace eval punk { #} set first_term -1 set token_index 0 ;#index of terminal char within each token + set indq 0 + set inesc 0 ;#whether last char was backslash (see also punk::escv) set prevc "" set char_index 0 foreach c [split $varspecs ""] { - if {$in_atom} { + if {$indq} { + if {$inesc} { + #puts stderr "inesc adding '$c'" + append token $c + } else { + if {$c eq {"}} { + set indq 0 + } else { + append token $c + } + } + } elseif {$in_atom} { + #ignore dquotes/brackets in atoms - pass through append token $c #set nextc [lindex $chars $char_index+1] if {$c eq "'"} { set in_atom 0 } - } elseif {$in_brackets} { + } elseif {$in_brackets > 0} { append token $c if {$c eq ")"} { - set in_brackets 0 + incr in_brackets -1 } } else { - if {$c eq ","} { + if {$c eq {"} && !$inesc} { + set indq 1 + } elseif {$c eq ","} { #lappend varlist [splitstrposn $token $first_term] set var $token set spec "" @@ -568,16 +588,33 @@ namespace eval punk { set first_term -1 } else { append token $c - if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { - set first_term $token_index - } elseif {$c eq "'"} { - set in_atom 1 - } elseif {$c eq "("} { - set in_brackets 1 + switch -exact -- $c { + ' { + set in_atom 1 + } + ( { + incr in_brackets + } + default { + if {$first_term == -1 && (($c in $var_terminals) && ($prevc ni $protect_terminals))} { + set first_term $token_index + } + } } } } set prevc $c + if {$c eq "\\"} { + #review + if {$inesc} { + set inesc 0 + } else { + set token [string range $token 0 end-1] + set inesc 1 + } + } else { + set inesc 0 + } incr token_index incr char_index } @@ -1268,8 +1305,10 @@ namespace eval punk { append script \n "# index_operation listindex-nested" \n lappend INDEX_OPERATIONS listindex-nested } - append script \n [string map [list $subindices] { - set leveldata [lindex $leveldata ] + append script \n [tstr -return string -allowcommands { + if {[catch {lindex $leveldata ${$subindices}} leveldata]} { + ${[tstr -ret string $tpl_return_mismatch_not_a_list]} + } }] # -- --- --- #append script \n $returnline \n @@ -1283,7 +1322,7 @@ namespace eval punk { set keypath [string range $selector 2 end] set keylist [split $keypath /] lappend INDEX_OPERATIONS dict_path - if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1)} { + if {([lindex $rawkeylist 0] ne "@@") && ([lsearch $keylist @*] == -1) && ([lsearch $keylist #*] == -1) && ([lsearch $keylist %*] == -1)} { #pure keylist for dict - process in one go #dict exists will return 0 if not a valid dict. # is equivalent to {*}keylist when substituted @@ -1333,7 +1372,7 @@ namespace eval punk { #thse have anyhead and anytail for explicit allowance to be used on lists with insufficient items to produce values. #append script \n {set do_boundscheck 0} switch -exact -- $index { - # { + # - @# { #list length set active_key_type "list" if {$get_not} { @@ -1395,16 +1434,96 @@ namespace eval punk { append script \n {set assigned [string length $leveldata]} set level_script_complete 1 } + %%# { + #experimental + set active_key_type "string" + if $get_not { + error "!%%# not string length is not supported" + } + #string length - REVIEW - + lappend INDEX_OPERATIONS ansistring-length + append script \n {# set active_key_type "" index_operation: ansistring-length} + append script \n {set assigned [ansistring length $leveldata]} + set level_script_complete 1 + } %str { set active_key_type "string" if $get_not { - error "!%# not string-get is not supported" + error "!%str - not string-get is not supported" } lappend INDEX_OPERATIONS string-get append script \n {# set active_key_type "" index_operation: string-get} append script \n {set assigned $leveldata} set level_script_complete 1 } + %sp { + #experimental + set active_key_type "string" + if $get_not { + error "!%sp - not string-space is not supported" + } + lappend INDEX_OPERATIONS string-space + append script \n {# set active_key_type "" index_operation: string-space} + append script \n {set assigned " "} + set level_script_complete 1 + } + %empty { + #experimental + set active_key_type "string" + if $get_not { + error "!%empty - not string-empty is not supported" + } + lappend INDEX_OPERATIONS string-empty + append script \n {# set active_key_type "" index_operation: string-empty} + append script \n {set assigned ""} + set level_script_complete 1 + } + @words { + set active_key_type "string" + if $get_not { + error "!%words - not list-words-from-string is not supported" + } + lappend INDEX_OPERATIONS list-words-from-string + append script \n {# set active_key_type "" index_operation: list-words-from-string} + append script \n {set assigned [regexp -inline -all {\S+} $leveldata]} + set level_script_complete 1 + } + @chars { + #experimental - leading character based on result not input(?) + #input type is string - but output is list + set active_key_type "list" + if $get_not { + error "!%chars - not list-chars-from-string is not supported" + } + lappend INDEX_OPERATIONS list-from_chars + append script \n {# set active_key_type "" index_operation: list-chars-from-string} + append script \n {set assigned [split $leveldata ""]} + set level_script_complete 1 + } + @join { + #experimental - flatten one level of list + #join without arg - output is list + set active_key_type "string" + if $get_not { + error "!@join - not list-join-list is not supported" + } + lappend INDEX_OPERATIONS list-join-list + append script \n {# set active_key_type "" index_operation: list-join-list} + append script \n {set assigned [join $leveldata]} + set level_script_complete 1 + } + %join { + #experimental + #input type is list - but output is string + set active_key_type "string" + if $get_not { + error "!%join - not string-join-list is not supported" + } + lappend INDEX_OPERATIONS string-join-list + append script \n {# set active_key_type "" index_operation: string-join-list} + append script \n {set assigned [join $leveldata ""]} + set level_script_complete 1 + } %ansiview { set active_key_type "string" if $get_not { @@ -1434,7 +1553,7 @@ namespace eval punk { #v_list_idx in context of _multi_bind_result append script \n {upvar v_list_idx v_list_idx} set active_key_type "list" - append script \n {# set active_key_type "list" index_operation: get-next} + append script \n {# set active_key_type "list" index_operation: list-get-next} #e.g @1/1/@/1 the lone @ is a positional spec for this specific subkey #no normalization done - ie @2/@ will not be considered same subkey as @end/@ or @end-0/@ even if llength = 3 #while x@,y@.= is reasonably handy - especially for args e.g $scopepattern] { #we still need to bind whether list is empty or not to allow any patternmatch to succeed/fail - set d [punk::_multi_bind_result "" $segmenttail] + set d [punk::_multi_bind_result {} $segmenttail] #return [punk::_handle_bind_result $d] #maintenance: inlined if {![dict exists $d result]} { @@ -3816,6 +3977,7 @@ namespace eval punk { } #return a script for inserting data into listvar + #review - needs updating for list-return semantics of patterns? proc list_insertion_script {keyspec listvar {data }} { set positionspec [string trimright $keyspec "*"] set do_expand [expr {[string index $keyspec end] eq "*"}] @@ -4495,7 +4657,7 @@ namespace eval punk { } append insertion_script \n {set insertion_data $v} } else { - + #todo - we should potentially group by the variable name and pass as a single call to _multi_bind_result - because stateful @ and @@ won't work in independent calls append insertion_script \n [string map [list $cmdname] { #puts ">>> v: $v dict_tagval:'$dict_tagval'" if {$v eq ""} { @@ -5042,93 +5204,96 @@ namespace eval punk { if {![info exists auto_noexec]} { set new [auto_execok $name] if {$new ne ""} { - set redir "" - if {[namespace which -command console] eq ""} { - set redir ">&@stdout <@stdin" - } + set redir "" + if {[namespace which -command console] eq ""} { + set redir ">&@stdout <@stdin" + } - #windows experiment todo - use twapi and named pipes - #twapi::namedpipe_server {\\.\pipe\something} - #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones - #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc - # - - if {[string first " " $new] > 0} { - set c1 $name - } else { - set c1 $new - } - - # -- --- --- --- --- - set idlist_stdout [list] - set idlist_stderr [list] - #set shellrun::runout "" - #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks - #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] - #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + #windows experiment todo - use twapi and named pipes + #twapi::namedpipe_server {\\.\pipe\something} + #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones + #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc + # - if {![dict get $::punk::config::running exec_unknown]} { - #This runs external executables in a context in which they are not attached to a terminal - #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output - #ctrl-c propagation also needs to be considered - - set teehandle punksh - uplevel 1 [list ::catch \ - [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ - ::tcl::UnknownResult ::tcl::UnknownOptions] - - if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { - dict set ::tcl::UnknownOptions -code error - set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + if {[string first " " $new] > 0} { + set c1 $name } else { - #no point returning "exitcode 0" if that's the only non-error return. - #It is misleading. Better to return empty string. - set ::tcl::UnknownResult "" + set c1 $new } - } else { - set repl_runid [punk::get_repl_runid] - #set ::punk::last_run_display [list] - - set redir ">&@stdout <@stdin" - uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] - #we can't detect stdout/stderr output from the exec - #for now emit an extra \n on stderr - #todo - there is probably no way around this but to somehow exec in the context of a completely separate console - #This is probably a tricky problem - especially to do cross-platform - # - # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit - if {[dict get $::tcl::UnknownOptions -code] == 0} { - set c green - set m "ok" + + # -- --- --- --- --- + set idlist_stdout [list] + set idlist_stderr [list] + #set shellrun::runout "" + #when using exec with >&@stdout (to ensure process is connected to console) - the output unfortunately doesn't go via the shellfilter stacks + #lappend idlist_stderr [shellfilter::stack::add stderr ansiwrap -settings {-colour {red bold}}] + #lappend idlist_stdout [shellfilter::stack::add stdout tee_to_var -action float -settings {-varname ::shellrun::runout}] + + if {[dict get $::punk::config::running auto_exec_mechanism] eq "experimental"} { + #TODO - something cross-platform that allows us to maintain a separate console(s) with an additional set of IO channels to drive it + #not a trivial task + + #This runs external executables in a context in which they are not attached to a terminal + #VIM for example won't run, and various programs can't detect terminal dimensions etc and/or will default to ansi-free output + #ctrl-c propagation also needs to be considered + + set teehandle punksh + uplevel 1 [list ::catch \ + [list ::shellfilter::run [concat [list $new] [lrange $args 1 end]] -teehandle $teehandle -inbuffering line -outbuffering none ] \ + ::tcl::UnknownResult ::tcl::UnknownOptions] + + if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} { + dict set ::tcl::UnknownOptions -code error + set ::tcl::UnknownResult "Non-zero exit code from command '$args' $::tcl::UnknownResult" + } else { + #no point returning "exitcode 0" if that's the only non-error return. + #It is misleading. Better to return empty string. + set ::tcl::UnknownResult "" + } } else { - set c yellow - set m "errorCode $::errorCode" - } - set chunklist [list] - lappend chunklist [list "info" "[a $c]$m[a] " ] - if {$repl_runid != 0} { - tsv::lappend repl runchunks-$repl_runid {*}$chunklist - } + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } - } + } - foreach id $idlist_stdout { - shellfilter::stack::remove stdout $id - } - foreach id $idlist_stderr { - shellfilter::stack::remove stderr $id - } - # -- --- --- --- --- + foreach id $idlist_stdout { + shellfilter::stack::remove stdout $id + } + foreach id $idlist_stderr { + shellfilter::stack::remove stderr $id + } + # -- --- --- --- --- - #uplevel 1 [list ::catch \ - # [concat exec $redir $new [lrange $args 1 end]] \ - # ::tcl::UnknownResult ::tcl::UnknownOptions] + #uplevel 1 [list ::catch \ + # [concat exec $redir $new [lrange $args 1 end]] \ + # ::tcl::UnknownResult ::tcl::UnknownOptions] - #puts "===exec with redir:$redir $::tcl::UnknownResult ==" - dict incr ::tcl::UnknownOptions -level - return -options $::tcl::UnknownOptions $::tcl::UnknownResult + #puts "===exec with redir:$redir $::tcl::UnknownResult ==" + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult } } @@ -5374,8 +5539,6 @@ namespace eval punk { # #know {[regexp {^([^\t\r\n=]*)\=([^ \t\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} #know {[regexp {^{([^\t\r\n=]*)\=([^ \t\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} - know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} - know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} @@ -5449,9 +5612,43 @@ namespace eval punk { return [uplevel 1 [list ::punk::pipeline .= $pattern $equalsrhs {*}$argstail]] } + + # + know {[regexp {^([^\t\r\n=]*)\=([^\r\n]*)} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + know {[regexp {^{([^\t\r\n=]*)\=([^\r\n]*)}} [lindex $args 0] matchedon pattern equalsrhs]} {tailcall ::punk::_unknown_assign_dispatch $matchedon $pattern $equalsrhs {*}$args} + #variable re_dot_assign {^([^ \t\r\n=\{]*)\.=(.*)} #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} - know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^ \t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=\{]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + #know {[regexp {^([^\t\r\n=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + know {[regexp {^([^=]*)\.=(.*)} [lindex $args 0] partzerozero varspecs rhs]} {tailcall punk::_unknown_dot_assign_dispatch $partzerozero $varspecs $rhs {*}$args} + + #add escaping backslashes to a value + #matching odd keys in dicts using pipeline syntax can be tricky - as + #e.g + #set ktest {a"b} + #@@[escv $ktest].= list a"b val + #without escv: + #@@"a\\"b".= list a"b val + #with more backslashes in keys the escv use becomes more apparent: + #set ktest {\\x} + #@@[escv $ktest].= list $ktest val + #without escv we would need: + #@@\\\\\\\\x.= list $ktest val + proc escv {v} { + #https://stackoverflow.com/questions/11135090/is-there-any-tcl-function-to-add-escape-character-automatically + #thanks to DKF + regsub -all {\W} $v {\\&} + } + interp alias {} escv {} punk::escv + #review + #set v "\u2767" + # + #escv $v + #\ + #the + #know {[regexp $punk::re_dot_assign [lindex $args 0 0] partzerozero varspecs rhs]} { # set argstail [lassign $args hd] @@ -7859,7 +8056,7 @@ namespace eval punk { set displaycount "" } if {$opt_ansi == 0} { - set displayval [punk::ansi::stripansi $displayval] + set displayval [punk::ansi::ansistrip $displayval] } elseif {$opt_ansi == 2} { set displayval [ansistring VIEW $displayval] } @@ -7951,20 +8148,26 @@ namespace eval punk { set text "" if {$topic in [list env environment]} { #todo - move to punk::config? + upvar ::punk::config::punk_env_vars_config punkenv_config + upvar ::punk::config::other_env_vars_config otherenv_config - set known_punk $::punk::config::known_punk_env_vars - set known_other $::punk::config::known_other_env_vars + set known_punk [dict keys $punkenv_config] + set known_other [dict keys $otherenv_config] append text \n set usetable 1 if {$usetable} { set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - foreach v $known_punk { + foreach {v vinfo} $punkenv_config { if {[info exists ::env($v)]} { set c2 [set ::env($v)] } else { set c2 "(NOT SET)" } - $t add_row [list $v $c2] + set help "" + if {[dict exists $vinfo help]} { + set help [dict get $vinfo help] + } + $t add_row [list $v $c2 $help] } $t configure_column 0 -headers [list "Punk environment vars"] $t configure_column 0 -minwidth [expr {[$t column_datawidth 0]+4}] -blockalign left -textalign left -header_colspans {any} @@ -7973,7 +8176,7 @@ namespace eval punk { $t destroy set t [textblock::class::table new -show_hseps 0 -show_header 1 -ansiborder_header [a+ web-green]] - foreach v $known_other { + foreach {v vinfo} $otherenv_config { if {[info exists ::env($v)]} { set c2 [set ::env($v)] } else { @@ -8318,13 +8521,15 @@ namespace eval punk { # ls aliases - note that tcl doesn't exand * but sh_xxx functions pass to sh -c allowing shell expansion interp alias {} l {} sh_runout -n ls -A ;#plain text listing #interp alias {} ls {} sh_runout -n ls -AF --color=always - interp alias {} ls {} unknown ls -AF --color=always ;#use unknown to use terminal and allow | more | less + interp alias {} ls {} shellrun::runconsole ls -AF --color=always ;#use unknown to use terminal and allow | more | less #note that shell globbing with * won't work on unix systems when using unknown/exec interp alias {} lw {} sh_runout -n ls -AFC --color=always ;#wide listing (use A becaus no extra info on . & ..) interp alias {} ll {} sh_runout -n ls -laFo --color=always ;#use a instead of A to see perms/owner of . & .. # -v for natural number sorting not supported on freeBSD. Todo - test at startup and modify aliases? #interp alias {} lw {} ls -aFv --color=always + interp alias {} dir {} shellrun::console dir + interp alias {} ./ {} punk::d/ interp alias {} ../ {} punk::dd/ @@ -8358,8 +8563,8 @@ namespace eval punk { interp alias {} psr {} run -n pwsh -nop -nolo -c interp alias {} psout {} runout -n pwsh -nop -nolo -c interp alias {} pserr {} runerr -n pwsh -nop -nolo -c - interp alias {} psls {} pwsh -nop -nolo -c ls - interp alias {} psps {} pwsh -nop -nolo -c ps + interp alias {} psls {} shellrun::runconsole pwsh -nop -nolo -c ls + interp alias {} psps {} shellrun::runconsole pwsh -nop -nolo -c ps } else { set ps_missing "powershell missing (powershell is open source and can be installed on windows and most unix-like platforms)" interp alias {} ps {} puts stderr $ps_missing diff --git a/src/modules/punk/aliascore-999999.0a1.0.tm b/src/modules/punk/aliascore-999999.0a1.0.tm index 55926216..90a31f7c 100644 --- a/src/modules/punk/aliascore-999999.0a1.0.tm +++ b/src/modules/punk/aliascore-999999.0a1.0.tm @@ -112,7 +112,8 @@ tcl::namespace::eval punk::aliascore { plist [list ::punk::lib::pdict -roottype list]\ showlist [list ::punk::lib::showdict -roottype list]\ showdict ::punk::lib::showdict\ - ansistrip ::punk::ansi::stripansi\ + ansistrip ::punk::ansi::ansistrip\ + stripansi ::punk::ansi::ansistrip\ ] #*** !doctools @@ -165,18 +166,31 @@ tcl::namespace::eval punk::aliascore { error "punk::aliascore::init declined to create any aliases or imports because -force == 0 and conflicts found:$conflicts" } } + set tempns ::temp_[info cmdcount] ;#temp ns for renames dict for {a cmd} $aliases { + #puts "aliascore $a -> $cmd" if {[llength $cmd] > 1} { interp alias {} $a {} {*}$cmd } else { if {[tcl::info::commands $cmd] ne ""} { #todo - ensure exported? noclobber? - tcl::namespace::eval :: [list namespace import $cmd] + if {[tcl::namespace::tail $a] eq [tcl::namespace::tail $cmd]} { + #puts stderr "importing $cmd" + tcl::namespace::eval :: [list namespace import $cmd] + } else { + #target command name differs from exported name + #e.g stripansi -> punk::ansi::ansistrip + #import and rename + #puts stderr "importing $cmd (with rename to ::$a)" + tcl::namespace::eval $tempns [list namespace import $cmd] + catch {rename ${tempns}::[namespace tail $cmd] ::$a} + } } else { interp alias {} $a {} {*}$cmd } } } + #tcl::namespace::delete $tempns return [dict keys $aliases] } @@ -188,7 +202,7 @@ tcl::namespace::eval punk::aliascore { #interp alias {} list_as_lines {} punk::lib::list_as_lines #interp alias {} lines_as_list {} punk::lib::lines_as_list -#interp alias {} ansistrip {} punk::ansi::stripansi ;#review +#interp alias {} ansistrip {} punk::ansi::ansistrip ;#review #interp alias {} linelist {} punk::lib::linelist ;#critical for = assignment features #interp alias {} linesort {} punk::lib::linesort diff --git a/src/modules/punk/ansi-999999.0a1.0.tm b/src/modules/punk/ansi-999999.0a1.0.tm index 8017b5e6..747364c1 100644 --- a/src/modules/punk/ansi-999999.0a1.0.tm +++ b/src/modules/punk/ansi-999999.0a1.0.tm @@ -265,13 +265,13 @@ tcl::namespace::eval punk::ansi::class { } set opts_width [tcl::dict::get $opts -width] if {$opts_width eq ""} { - return [punk::ansi::stripansiraw [$o_ansistringobj get]] + return [punk::ansi::ansistripraw [$o_ansistringobj get]] } elseif {$opts_width eq "auto"} { lassign [punk::console::get_size] _cols columns _rows rows set displaycols [expr {$columns -4}] ;#review - return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]] + return [overtype::renderspace -width $displaycols -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]] } elseif {[tcl::string::is integer -strict $opts_width] && $opts_width > 0} { - return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::stripansiraw [$o_ansistringobj get]]] + return [overtype::renderspace -width $opts_width -wrap 1 "" [punk::ansi::ansistripraw [$o_ansistringobj get]]] } else { error "viewchars unrecognised value for -width. Try auto or a positive integer" } @@ -420,7 +420,7 @@ tcl::namespace::eval punk::ansi { get_*\ move*\ reset*\ - strip*\ + ansistrip*\ test_decaln\ titleset\ @@ -750,7 +750,7 @@ tcl::namespace::eval punk::ansi { #mqj #m = boxd_lur - #don't call detect_g0 in here. Leave for caller. e.g stripansi uses detect_g0 to decide whether to call this. + #don't call detect_g0 in here. Leave for caller. e.g ansistrip uses detect_g0 to decide whether to call this. set re_g0_open_or_close {\x1b\(0|\x1b\(B} set parts [::punk::ansi::ta::_perlish_split $re_g0_open_or_close $text] @@ -813,14 +813,17 @@ tcl::namespace::eval punk::ansi { proc g0 {text} { return \x1b(0$text\x1b(B } + proc ansistrip_gx {text} { + #e.g "\033(0" - select VT100 graphics for character set G0 + #e.g "\033(B" - reset + #e.g "\033)0" - select VT100 graphics for character set G1 + #e.g "\033)X" - where X is any char other than 0 to reset ?? + + #return [convert_g0 $text] + return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] + } proc stripansi_gx {text} { - #e.g "\033(0" - select VT100 graphics for character set G0 - #e.g "\033(B" - reset - #e.g "\033)0" - select VT100 graphics for character set G1 - #e.g "\033)X" - where X is any char other than 0 to reset ?? - - #return [convert_g0 $text] - return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] + return [tcl::string::map [list "\x1b(0" "" \x1b(B" "" "\x1b)0" "" "\x1b)X" ""] $text] } @@ -1085,7 +1088,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #This is an in depth analysis of the xterm colour set which gives names(*) to all of the 256 colours and describes possible indexing by Hue,Luminance,Saturation #https://www.wowsignal.io/articles/xterm256 - #*The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard. + # *The names are wildly-imaginative, often unintuitively so, and multiple (5?) given for each colour - so they are unlikely to be of practical use or any sort of standard. #e.g who is to know that 'Rabbit Paws', 'Forbidden Thrill' and 'Tarsier' refer to a particular shade of pinky-red? (code 95) #Perhaps it's an indication that colour naming once we get to 256 colours or more is a fool's errand anyway. #The xterm names are boringly unimaginative - and also have some oddities such as: @@ -2263,23 +2266,25 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #sgr_cache clear called by punk::console::ansi when set to off proc sgr_cache {args} { set argd [punk::args::get_dict { - -action -default "" -choices "clear" - -pretty -default 1 -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" + *proc -name punk::ansi::sgr_cache -help "Convenience function to view and optionally clear the ansi character attribute cache (ansi SGR codes) + " + -action -default "" -choices "clear" -help "-action clear will unset the keys in the punk::ansi::sgr_cache dict + This is called automatically when setting 'colour false' in the console" + + -pretty -default 1 -type boolean -help "use 'pdict punk::ansi::sgr_cache */%str,%ansiview' output" *values -min 0 -max 0 } $args] set action [dict get $argd opts -action] set pretty [dict get $argd opts -pretty] variable sgr_cache - if {$action ni {"" clear}} { - error "sgr_cache action '$action' not understood. Valid actions: clear" - } if {$action eq "clear"} { set sgr_cache [tcl::dict::create] return "sgr_cache cleared" } if {$pretty} { - return [pdict -channel none sgr_cache */%str,%ansiview] + #return [pdict -channel none sgr_cache */%str,%ansiview] + return [pdict -channel none sgr_cache */%rpadstr-"sample",%ansiviewstyle] } if {[catch { @@ -2323,7 +2328,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #function name part of cache-key because a and a+ return slightly different results (a has leading reset) variable sgr_cache - set cache_key a+$args ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key + set cache_key "a+ $args" ;#ensure cache_key static - we may remove for example 'forcecolour' from args - but it needs to remain part of cache_key if {[tcl::dict::exists $sgr_cache $cache_key]} { return [tcl::dict::get $sgr_cache $cache_key] } @@ -2682,7 +2687,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #It's important to put the functionname in the cache-key because a and a+ return slightly different results variable sgr_cache - set cache_key a_$args + set cache_key "a $args" if {[tcl::dict::exists $sgr_cache $cache_key]} { return [tcl::dict::get $sgr_cache $cache_key] } @@ -2693,7 +2698,7 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu variable TERM_colour_map set colour_disabled 0 - #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache clear + #whatever function disables or re-enables colour should have made a call to punk::ansi::sgr_cache -action clear if {[tcl::info::exists ::punk::console::colour_disabled] && $::punk::console::colour_disabled} { set colour_disabled 1 } @@ -3393,10 +3398,10 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu #arguably - \b and \r are cursor move operations too - so processing them here is not very symmetrical - review #the purpose of backspace (or line cr) in embedded text is unclear. Should it allow some sort of character combining/overstrike as it has sometimes done historically (nroff/less)? e.g a\b` as an alternative combiner or bolding if same char #This should presumably only be done if the over_strike (os) capability is enabled in the terminal. Either way - it presumably won't affect printing width? - set line [punk::ansi::stripansi $line] + set line [punk::ansi::ansistrip $line] #we can't use simple \b processing if we get ansi codes and aren't actually processing them (e.g moves) - set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after stripansi - some like BEL are part of ansi + set line [punk::char::strip_nonprinting_ascii $line] ;#only strip nonprinting after ansistrip - some like BEL are part of ansi #backspace 0x08 only erases* printing characters anyway - so presumably order of processing doesn't matter #(* more correctly - moves cursor back) #Note some terminals process backspace before \v - which seems quite wrong @@ -3512,6 +3517,40 @@ Brightblack 100 Brightred 101 Brightgreen 102 Brightyellow 103 Brightblu } + #ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks + proc ansistrip {text} { + #*** !doctools + #[call [fun ansistrip] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) + + if {[punk::ansi::ta::detect_g0 $text]} { + set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters + } + set parts [punk::ansi::ta::split_codes $text] + set out "" + foreach {pt code} $parts { + append out $pt + } + return $out + } + #interp alias {} stripansi {} ::punk::ansi::ansistrip + proc ansistripraw {text} { + #*** !doctools + #[call [fun ansistripraw] [arg text] ] + #[para]Return a string with ansi codes stripped out + #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. + #[para]ie instead of a horizontal line you may see: qqqqqq + + set parts [punk::ansi::ta::split_codes $text] + set out "" + foreach {pt code} $parts { + append out $pt + } + return $out + } + #interp alias {} stripansiraw {} ::punk::ansi::ansistripraw + #*** !doctools #[list_end] [comment {--- end definitions namespace punk::ansi ---}] } @@ -4293,16 +4332,16 @@ tcl::namespace::eval punk::ansi::ta { #*** !doctools #[call [fun strip] [arg text]] #[para]Return text stripped of Ansi codes - #[para]This is a tailcall to punk::ansi::stripansi - tailcall stripansi $text + #[para]This is a tailcall to punk::ansi::ansistrip + tailcall ansistrip $text } proc length {text} { #*** !doctools #[call [fun length] [arg text]] #[para]Return the character length after stripping ansi codes - not the printing length - #we can use stripansiraw to avoid g0 conversion - as the length should remain the same - tcl::string::length [stripansiraw $text] + #we can use ansistripraw to avoid g0 conversion - as the length should remain the same + tcl::string::length [ansistripraw $text] } #todo - handle newlines #not in perl ta @@ -5451,32 +5490,8 @@ tcl::namespace::eval punk::ansi::class { } } tcl::namespace::eval punk::ansi { - proc stripansi {text} { - #ever so slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks - if {[punk::ansi::ta::detect_g0 $text]} { - set text [convert_g0 $text];#Convert ansi borders to unicode line drawing instead of ascii letters - } - set parts [punk::ansi::ta::split_codes $text] - set out "" - foreach {pt code} $parts { - append out $pt - } - return $out - } - proc stripansiraw {text} { - #slightly slower on short strings - much faster than split_at_codes version for large/complex ansi blocks - set parts [punk::ansi::ta::split_codes $text] - set out "" - foreach {pt code} $parts { - append out $pt - } - return $out - } + proc stripansi3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #*** !doctools - #[call [fun stripansi] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics chars are replaced with modern unicode equivalents (e.g boxdrawing glyphs) #using detect costs us a couple of uS - but saves time on plain text #we should probably leave this for caller - otherwise it ends up being called more than necessary @@ -5493,11 +5508,6 @@ tcl::namespace::eval punk::ansi { }] proc stripansiraw3 {text} [string map [list $::punk::ansi::ta::re_ansi_split] { - #*** !doctools - #[call [fun stripansi] [arg text] ] - #[para]Return a string with ansi codes stripped out - #[para]Alternate graphics modes will be stripped rather than converted to unicode - exposing the raw ascii characters as they appear without graphics mode. - #[para]ie instead of a horizontal line you may see: qqqqqq #join [::punk::ansi::ta::split_at_codes $text] "" punk::ansi::ta::Do_split_at_codes_join $text {} @@ -5923,7 +5933,7 @@ tcl::namespace::eval punk::ansi::ansistring { #[para]Returns the count of visible graphemes and non-ansi control characters #[para]Incomplete! grapheme clustering support not yet implemented - only diacritics are currently clustered to count as one grapheme. #[para]This will not count strings hidden inside a 'privacy message' or other ansi codes which may have content between their opening escape and their termination sequence. - #[para]This is not quite equivalent to calling string length on the result of stripansi $string due to diacritics and/or grapheme combinations + #[para]This is not quite equivalent to calling string length on the result of ansistrip $string due to diacritics and/or grapheme combinations #[para]Note that this returns the number of characters in the payload (after applying combiners) #It is not always the same as the width of the string as rendered on a terminal due to 2wide Unicode characters and the usual invisible control characters such as \r and \n #[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware. @@ -5935,17 +5945,17 @@ tcl::namespace::eval punk::ansi::ansistring { set string [regsub -all $re_diacritics $string ""] #we want length to return number of glyphs.. not screen width. Has to be consistent with index function - tcl::string::length [stripansi $string] + tcl::string::length [ansistrip $string] } #included as a test/verification - slightly slower. #grapheme split version may end up being used once it supports unicode grapheme clusters proc count2 {string} { #we want count to return number of glyphs.. not screen width. Has to be consistent with index function - return [llength [punk::char::grapheme_split [stripansi $string]]] + return [llength [punk::char::grapheme_split [ansistrip $string]]] } proc length {string} { - tcl::string::length [stripansi $string] + tcl::string::length [ansistrip $string] } proc _splits_trimleft {sclist} { @@ -6055,9 +6065,9 @@ tcl::namespace::eval punk::ansi::ansistring { #[para]The string could contain non SGR ansi codes - and these will (mostly) be ignored, so shouldn't affect the output. #[para]Some terminals don't hide 'privacy message' and other strings within an ESC X ESC ^ or ESC _ sequence (terminated by ST) #[para]It's arguable some of these are application specific - but this function takes the view that they are probably non-displaying - so index won't see them. - #[para]If the caller wants just the character - they should use a normal string index after calling stripansi, or call stripansi afterwards. - #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use stripansi and standard string index if the ansi coded output isn't required and they are using and end-based index. - #[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using stripansi and normal string operations on that. + #[para]If the caller wants just the character - they should use a normal string index after calling ansistrap, or call ansistrip afterwards. + #[para]As any operation using end-+ will need to strip ansi to precalculate the length anyway; the caller should probably just use ansistrip and standard string index if the ansi coded output isn't required and they are using and end-based index. + #[para]In fact, any operation where the ansi info isn't required in the output would probably be slightly more efficiently obtained by using ansistrip and normal string operations on that. #[para]The returned character will (possibly) have a leading ansi escape sequence but no trailing escape sequence - even if the string was taken from a position immediately before a reset or other SGR ansi code #[para]The ansi-code prefix in the returned string is built up by concatenating previous SGR ansi codes seen - but it is optimised to re-start the process if any full SGR reset is encountered. #[para]The code sequence doesn't detect individual properties being turned on and then off again, only full resets; so in some cases the ansi-prefix may not be as short as it could be. diff --git a/src/modules/punk/args-999999.0a1.0.tm b/src/modules/punk/args-999999.0a1.0.tm index 1b85cfec..b41c9fb5 100644 --- a/src/modules/punk/args-999999.0a1.0.tm +++ b/src/modules/punk/args-999999.0a1.0.tm @@ -267,6 +267,9 @@ tcl::namespace::eval punk::args { #[list_begin definitions] + #todo? -synonym ? (applies to opts only not values) + #e.g -background -synonym -bg -default White + proc Get_argspecs {optionspecs args} { variable argspec_cache variable argspecs @@ -333,7 +336,7 @@ tcl::namespace::eval punk::args { foreach rawline $linelist { set recordsofar [tcl::string::cat $linebuild $rawline] #ansi colours can stop info complete from working (contain square brackets) - if {![tcl::info::complete [punk::ansi::stripansi $recordsofar]]} { + if {![tcl::info::complete [punk::ansi::ansistrip $recordsofar]]} { #append linebuild [string trimleft $rawline] \n if {$in_record} { if {[tcl::string::length $lastindent]} { @@ -696,6 +699,7 @@ tcl::namespace::eval punk::args { } proc arg_error {msg spec_dict {badarg ""}} { + # use basic colours here to support terminals without extended colours #todo - add checks column (e.g -minlen -maxlen) set errmsg $msg if {![catch {package require textblock}]} { @@ -704,18 +708,21 @@ tcl::namespace::eval punk::args { set procname [punk::lib::dict_getdef $spec_dict proc_info -name ""] set prochelp [punk::lib::dict_getdef $spec_dict proc_info -help ""] - set t [textblock::class::table new [a+ web-yellow]Usage[a]] + #set t [textblock::class::table new [a+ web-yellow]Usage[a]] + set t [textblock::class::table new [a+ brightyellow]Usage[a]] set blank_header_col [list ""] if {$procname ne ""} { lappend blank_header_col "" - set procname_display [a+ web-white]$procname[a] + #set procname_display [a+ web-white]$procname[a] + set procname_display [a+ brightwhite]$procname[a] } else { set procname_display "" } if {$prochelp ne ""} { lappend blank_header_col "" - set prochelp_display [a+ web-white]$prochelp[a] + #set prochelp_display [a+ web-white]$prochelp[a] + set prochelp_display [a+ brightwhite]$prochelp[a] } else { set prochelp_display "" } @@ -738,9 +745,12 @@ tcl::namespace::eval punk::args { $t configure_header 2 -values {Arg Type Default Multiple Help} } - set c_default [a+ web-white Web-limegreen] - set c_badarg [a+ web-crimson] - set greencheck [a+ web-limegreen]\u2713[a] + #set c_default [a+ web-white Web-limegreen] + set c_default [a+ brightwhite Brightgreen] + #set c_badarg [a+ web-crimson] + set c_badarg [a+ brightred] + #set greencheck [a+ web-limegreen]\u2713[a] + set greencheck [a+ brightgreen]\u2713[a] foreach arg [dict get $spec_dict opt_names] { set arginfo [dict get $spec_dict arg_info $arg] @@ -789,7 +799,8 @@ tcl::namespace::eval punk::args { } - $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + #$t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ web-white] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] + $t configure -show_hseps 0 -show_header 1 -ansibase_body [a+ brightwhite] -ansibase_header [a+ brightyellow] -ansiborder_header [a+ brightyellow] -ansiborder_body [a+ brightyellow] $t configure -maxwidth 80 append errmsg [$t print] $t destroy @@ -1209,7 +1220,7 @@ tcl::namespace::eval punk::args { package require punk::ansi set vlist_check [list] foreach e $vlist { - lappend vlist_check [punk::ansi::stripansi $e] + lappend vlist_check [punk::ansi::ansistrip $e] } } else { #validate_without_ansi 0 @@ -1437,7 +1448,7 @@ tcl::namespace::eval punk::args { } } if {$is_strip_ansi} { - set stripped_list [lmap e $vlist {punk::ansi::stripansi $e}] ;#no faster or slower, but more concise than foreach + set stripped_list [lmap e $vlist {punk::ansi::ansistrip $e}] ;#no faster or slower, but more concise than foreach if {[tcl::dict::get $thisarg -multiple]} { if {[tcl::dict::get $thisarg -ARGTYPE] eq "option"} { tcl::dict::set opts $argname $stripped_list diff --git a/src/modules/punk/char-999999.0a1.0.tm b/src/modules/punk/char-999999.0a1.0.tm index 4d8503c3..3f41f36d 100644 --- a/src/modules/punk/char-999999.0a1.0.tm +++ b/src/modules/punk/char-999999.0a1.0.tm @@ -1950,7 +1950,7 @@ tcl::namespace::eval punk::char { #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { - # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" #} @@ -2057,7 +2057,7 @@ tcl::namespace::eval punk::char { #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { - # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" #} @@ -2161,7 +2161,7 @@ tcl::namespace::eval punk::char { #we need to map remaining control characters to zero-width (under assumption we're not using a font/codepage that displays them - review!) #anyway - we must allow things like raw ESC,DEL, NUL etc to pass through without error #if {[tcl::string::first \033 $text] >= 0} { - # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::stripansi first" + # error "string_width doesn't accept ansi escape sequences. Use punk::ansi::ansistrip first" #} diff --git a/src/modules/punk/config-0.1.tm b/src/modules/punk/config-0.1.tm index cf23c15a..a1f11212 100644 --- a/src/modules/punk/config-0.1.tm +++ b/src/modules/punk/config-0.1.tm @@ -3,11 +3,13 @@ tcl::namespace::eval punk::config { variable loaded variable startup ;#include env overrides variable running - variable known_punk_env_vars - variable known_other_env_vars + variable punk_env_vars + variable other_env_vars variable vars + namespace export {[a-z]*} + #todo - XDG_DATA_HOME etc #https://specifications.freedesktop.org/basedir-spec/latest/ # see also: http://hiphish.github.io/blog/2020/08/30/dotfiles-were-a-mistake/ @@ -16,8 +18,10 @@ tcl::namespace::eval punk::config { variable defaults variable startup variable running - variable known_punk_env_vars - variable known_other_env_vars + variable punk_env_vars + variable punk_env_vars_config + variable other_env_vars + variable other_env_vars_config set exename "" catch { @@ -55,12 +59,13 @@ tcl::namespace::eval punk::config { set default_logfile_stderr "" } - # exec_unknown ;#whether to use exec instead of experimental shellfilter::run + # auto_exec_mechanism ;#whether to use exec instead of experimental shellfilter::run #startup color_stdout - parameters as suitable for punk::ansi::a+ (test with 'punk::ansi::a?') e.g "cyan bold" ;#not a good idea to default set default_color_stdout "" #This wraps the stderr stream as it comes in with Ansi - probably best to default to empty.. but it's useful. #set default_color_stderr "red bold" - set default_color_stderr "web-lightsalmon" + #set default_color_stderr "web-lightsalmon" + set default_color_stderr yellow ;#limit to basic colours for wider terminal support. yellow = term-olive set homedir "" if {[catch { @@ -134,7 +139,8 @@ tcl::namespace::eval punk::config { syslog_stdout "127.0.0.1:514"\ syslog_stderr "127.0.0.1:514"\ syslog_active 0\ - exec_unknown true\ + auto_exec_mechanism exec\ + auto_noexec 0\ xdg_config_home $default_xdg_config_home\ xdg_data_home $default_xdg_data_home\ xdg_cache_home $default_xdg_cache_home\ @@ -159,31 +165,53 @@ tcl::namespace::eval punk::config { #todo - load/save config file #todo - define which configvars are settable in env - set known_punk_env_vars [list \ - PUNK_APPS\ - PUNK_CONFIG\ - PUNK_CONFIGSET\ - PUNK_SCRIPTLIB\ - PUNK_EXECUNKNOWN\ - PUNK_COLOR_STDERR\ - PUNK_COLOR_STDOUT\ - PUNK_LOGFILE_STDOUT\ - PUNK_LOGFILE_STDERR\ - PUNK_LOGFILE_ACTIVE\ - PUNK_SYSLOG_STDOUT\ - PUNK_SYSLOG_STDERR\ - PUNK_SYSLOG_ACTIVE\ - PUNK_THEME_POSH_OVERRIDE\ + #list of varname varinfo where varinfo is a sub dictionary (type key is mandatory, with value from: string,pathlist,boolean) + set punk_env_vars_config [dict create \ + PUNK_APPS {type pathlist}\ + PUNK_CONFIG {type string}\ + PUNK_CONFIGSET {type string}\ + PUNK_SCRIPTLIB {type string}\ + PUNK_AUTO_EXEC_MECHANISM {type string}\ + PUNK_AUTO_NOEXEC {type string default 0 help "set 1 to set Tcl's ::auto_noexec true.\nStops 'unknown' from running external programs"}\ + PUNK_COLOR_STDERR {type string}\ + PUNK_COLOR_STDOUT {type string}\ + PUNK_LOGFILE_STDOUT {type string}\ + PUNK_LOGFILE_STDERR {type string}\ + PUNK_LOGFILE_ACTIVE {type string}\ + PUNK_SYSLOG_STDOUT {type string}\ + PUNK_SYSLOG_STDERR {type string}\ + PUNK_SYSLOG_ACTIVE {type string}\ + PUNK_THEME_POSH_OVERRIDE {type string}\ ] + set punk_env_vars [dict keys $punk_env_vars_config] #override with env vars if set - foreach evar $known_punk_env_vars { + foreach {evar varinfo} $punk_env_vars_config { if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] set f [set ::env($evar)] if {$f ne "default"} { #e.g PUNK_SCRIPTLIB -> scriptlib set varname [tcl::string::tolower [tcl::string::range $evar 5 end]] - tcl::dict::set startup $varname $f + if {$vartype eq "pathlist"} { + #colon vs semicolon path sep is problematic for windows environments where unix-like systems such as cygwin/wsl are used and a variable may be set for either the native path separator or the unix-like system + #Even without the colon vs semicolon issue, native vs unix-like paths on windows mixed environment systems can cause grief. + #For now at least, we will simply respect the platform pathSeparator and hope the user manages the environment variables appropriately. + #some programs do automatic translation - which is a nice idea in principle - but is also prone to error as we don't know if it's already occurred or not depending on how things are launched. + #An example of where this sort of thing can go wrong is env(TCLLIBPATH) - which is defined as a space separated list not requiring further splitting + # - but some programs have been known to split this value on colon anyway, which breaks things on windows. + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } } } } @@ -194,22 +222,37 @@ tcl::namespace::eval punk::config { # set colour_disabled 1 # } #} - set known_other_env_vars [list\ - NO_COLOR\ - XDG_CONFIG_HOME\ - XDG_DATA_HOME\ - XDG_CACHE_HOME\ - XDG_STATE_HOME\ - XDG_DATA_DIRS\ - POSH_THEME\ - POSH_THEMES_PATH\ + set other_env_vars_config [dict create\ + NO_COLOR {type string}\ + XDG_CONFIG_HOME {type string}\ + XDG_DATA_HOME {type string}\ + XDG_CACHE_HOME {type string}\ + XDG_STATE_HOME {type string}\ + XDG_DATA_DIRS {type pathlist}\ + POSH_THEME {type string}\ + POSH_THEMES_PATH {type string}\ ] - foreach evar $known_other_env_vars { + set other_env_vars [dict keys $other_env_vars_config] + + foreach {evar varinfo} $other_env_vars_config { if {[info exists ::env($evar)]} { + set vartype [dict get $varinfo type] set f [set ::env($evar)] if {$f ne "default"} { set varname [tcl::string::tolower $evar] - tcl::dict::set startup $varname $f + if {$vartype eq "pathlist"} { + set paths [split $f $::tcl_platform(pathSeparator)] + set final [list] + #eliminate empty values (leading or trailing or extraneous separators) + foreach p $paths { + if {[tcl::string::trim $p] ne ""} { + lappend final $p + } + } + tcl::dict::set startup $varname $final + } else { + tcl::dict::set startup $varname $f + } } } } @@ -217,11 +260,39 @@ tcl::namespace::eval punk::config { #unset -nocomplain vars + #todo set running [tcl::dict::create] set running [tcl::dict::merge $running $startup] } init + #todo + proc Apply {config} { + puts stderr "punk::config::Apply partially implemented" + set configname [string map {-config ""} $config] + if {$configname in {startup running}} { + upvar ::punk::config::$configname applyconfig + + if {[dict exists $applyconfig auto_noexec]} { + set auto [dict get $applyconfig auto_noexec] + if {![string is boolean -strict $auto]} { + error "config::Apply error - invalid data for auto_noexec:'$auto' - expected boolean" + } + if {$auto} { + set ::auto_noexec 1 + } else { + #puts "auto_noexec false" + unset -nocomplain ::auto_noexec + } + } + + } else { + error "no config named '$config' found" + } + return "apply done" + } + Apply startup + #todo - consider how to divide up settings, categories, 'devices', decks etc proc get_running_global {varname} { variable running @@ -256,7 +327,8 @@ tcl::namespace::eval punk::config { set argd [punk::args::get_dict { whichconfig -type string -choices {startup running} - }] + } $args] + } proc show {whichconfig} { @@ -279,11 +351,58 @@ tcl::namespace::eval punk::config { # copy running-config startup-config # copy startup-config test-config.cfg # copy backup-config.cfg running-config - #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite ? - proc copy {fromconfig toconfig} { - error "sorry - unimplemented" - switch -- $toconfig { + #review - consider the merge vs overwrite feature of some routers.. where copy to running-config does a merge rather than an overwrite + #This is to allow partial configs to be loaded to running, whereas a save of running to any target is always a complete configuration + proc copy {args} { + set argd [punk::args::get_dict { + *proc -name punk::config::copy -help "Copy a partial or full configuration from one config to another + If a target config has additional settings, then the source config can be considered to be partial with regards to the target. + " + -type -default "" -choices {replace merge} -help "Defaults to merge when target is running-config + Defaults to replace when source is running-config" + *values -min 2 -max 2 + fromconfig -help "running or startup or file name (not fully implemented)" + toconfig -help "running or startup or file name (not fully implemented)" + } $args] + set fromconfig [dict get $argd values fromconfig] + set toconfig [dict get $argd values toconfig] + set fromconfig [string map {-config ""} $fromconfig] + set toconfig [string map {-config ""} $toconfig] + + set copytype [dict get $argd opts -type] + + + #todo - warn & prompt if doing merge copy to startup + switch -exact -- $fromconfig-$toconfig { + running-startup { + if {$copytype eq ""} { + set copytype replace ;#full configuration + } + if {$copytype eq "replace"} { + error "punk::config::copy error. full configuration copy from running to startup config not yet supported" + } else { + error "punk::config::copy error. merge configuration copy from running to startup config not yet supported" + } + } + startup-running { + #default type merge - even though it's not always what is desired + if {$copytype eq ""} { + set copytype merge ;#load in a partial configuration + } + #warn/prompt either way + if {$copytype eq "replace"} { + #some routers require use of a separate command for this branch. + #presumably to ensure the user doesn't accidentally load partials onto a running system + # + error "punk::config::copy error. full configuration copy from startup to overwrite running config not supported" + } else { + error "punk::config::copy error. merge copy from possibly partial configuration: startup to running config not currently supported" + } + } + default { + error "punk::config::copy error. copy must from running to startup or startup to running. File sources/targets not yet supported" + } } } diff --git a/src/modules/punk/console-999999.0a1.0.tm b/src/modules/punk/console-999999.0a1.0.tm index d1a6d399..bf2e2460 100644 --- a/src/modules/punk/console-999999.0a1.0.tm +++ b/src/modules/punk/console-999999.0a1.0.tm @@ -51,7 +51,7 @@ namespace eval punk::console { variable ansi_available -1 ;#default -1 for unknown. Leave it this way so test for ansi support is run. #-1 still evaluates to true - as the modern assumption for ansi availability is true #only false if ansi_available has been set 0 by test_can_ansi - #support stripansi for legacy windows terminals + #support ansistrip for legacy windows terminals # -- variable ansi_wanted 2 ;#2 for default assumed yes, will be set to -1 for automatically unwanted when ansi unavailable values of 0 or 1 won't be autoset @@ -780,7 +780,7 @@ namespace eval punk::console { #stdout variable ansi_wanted if {$ansi_wanted <= 0} { - puts -nonewline [punk::ansi::stripansiraw [::punk::ansi::a?]] + puts -nonewline [punk::ansi::ansistripraw [::punk::ansi::a?]] } else { tailcall ansi::a? {*}$args } @@ -806,7 +806,7 @@ namespace eval punk::console { proc code_a? {args} { variable ansi_wanted if {$ansi_wanted <= 0} { - return [punk::ansi::stripansi [::punk::ansi::a? {*}$args]] + return [punk::ansi::ansistripraw [::punk::ansi::a? {*}$args]] } else { tailcall ::punk::ansi::a? {*}$args } @@ -833,7 +833,7 @@ namespace eval punk::console { false - no { set ansi_wanted 0 - punk::ansi::sgr_cache clear + punk::ansi::sgr_cache -action clear } default { set ansi_wanted 2 @@ -859,7 +859,7 @@ namespace eval punk::console { if {$on} { if {$colour_disabled} { #change of state - punk::ansi::sgr_cache clear + punk::ansi::sgr_cache -action clear catch {punk::repl::reset_prompt} set colour_disabled 0 } @@ -867,7 +867,7 @@ namespace eval punk::console { #we don't disable a/a+ entirely - they must still emit underlines/bold/reverse if {!$colour_disabled} { #change of state - punk::ansi::sgr_cache clear + punk::ansi::sgr_cache -action clear catch {punk::repl::reset_prompt} set colour_disabled 1 } diff --git a/src/modules/punk/fileline-999999.0a1.0.tm b/src/modules/punk/fileline-999999.0a1.0.tm index 90fb97b4..254cea84 100644 --- a/src/modules/punk/fileline-999999.0a1.0.tm +++ b/src/modules/punk/fileline-999999.0a1.0.tm @@ -318,7 +318,7 @@ namespace eval punk::fileline::class { package require overtype # will require punk::char and punk::ansi - if {"::punk::fileline::ansi::stripansi" ne [info commands ::punk::fileline::ansi::stripansi]} { + if {"::punk::fileline::ansi::ansistrip" ne [info commands ::punk::fileline::ansi::ansistrip]} { namespace eval ::punk::fileline::ansi { namespace import ::punk::ansi::* } @@ -334,7 +334,7 @@ namespace eval punk::fileline::class { } else { set ::punk::fileline::ansi::enabled 0 } - if {"::punk::fileline::stripansi" ne [info commands ::punk::fileline::stripansi]} { + if {"::punk::fileline::ansistrip" ne [info commands ::punk::fileline::ansistrip]} { proc ::punk::fileline::a {args} { if {$::punk::fileline::ansi::enabled} { tailcall ::punk::fileline::ansi::a {*}$args @@ -349,9 +349,9 @@ namespace eval punk::fileline::class { return "" } } - proc ::punk::fileline::stripansi {str} { + proc ::punk::fileline::ansistrip {str} { if {$::punk::fileline::ansi::enabled} { - tailcall ::punk::fileline::ansi::stripansi $str + tailcall ::punk::fileline::ansi::ansistrip $str } else { return $str } @@ -560,7 +560,7 @@ namespace eval punk::fileline::class { set title_line "Line" #todo - use punk::char for unicode support of wide chars etc? set widest_linenum [tcl::mathfunc::max {*}[lmap v [concat [list $title_linenum] $linenums] {string length $v}]] - set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [stripansi $v]}]] + set widest_marker [tcl::mathfunc::max {*}[lmap v [concat [list $title_marker] $markers] {string length [ansistrip $v]}]] set widest_status [expr {max([string length $opt_cmark], [string length $opt_tmark])}] set widest_line [tcl::mathfunc::max {*}[lmap v [concat [list $title_line] $lines] {string length $v}]] foreach row $result_list { @@ -1711,7 +1711,7 @@ namespace eval punk::fileline::ansi { #*** !doctools #[call [fun ansi::a]] #[call [fun ansi::a+]] - #[call [fun ansi::stripansi]] + #[call [fun ansi::ansistrip]] #*** !doctools #[list_end] [comment {--- end definitions namespace punk::fileline::ansi ---}] diff --git a/src/modules/punk/lib-999999.0a1.0.tm b/src/modules/punk/lib-999999.0a1.0.tm index 4a8a3738..b59b5fee 100644 --- a/src/modules/punk/lib-999999.0a1.0.tm +++ b/src/modules/punk/lib-999999.0a1.0.tm @@ -66,34 +66,34 @@ package require Tcl 8.6- # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ -tcl::namespace::eval punk::lib::class { - #*** !doctools - #[subsection {Namespace punk::lib::class}] - #[para] class definitions - if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { - #*** !doctools - #[list_begin enumerated] - - # oo::class create interface_sample1 { - # #*** !doctools - # #[enum] CLASS [class interface_sample1] - # #[list_begin definitions] - - # method test {arg1} { - # #*** !doctools - # #[call class::interface_sample1 [method test] [arg arg1]] - # #[para] test method - # puts "test: $arg1" - # } - - # #*** !doctools - # #[list_end] [comment {-- end definitions interface_sample1}] - # } - - #*** !doctools - #[list_end] [comment {--- end class enumeration ---}] - } -} +#tcl::namespace::eval punk::lib::class { +# #*** !doctools +# #[subsection {Namespace punk::lib::class}] +# #[para] class definitions +# if {[info commands [tcl::namespace::current]::interface_sample1] eq ""} { +# #*** !doctools +# #[list_begin enumerated] +# +# # oo::class create interface_sample1 { +# # #*** !doctools +# # #[enum] CLASS [class interface_sample1] +# # #[list_begin definitions] +# +# # method test {arg1} { +# # #*** !doctools +# # #[call class::interface_sample1 [method test] [arg arg1]] +# # #[para] test method +# # puts "test: $arg1" +# # } +# +# # #*** !doctools +# # #[list_end] [comment {-- end definitions interface_sample1}] +# # } +# +# #*** !doctools +# #[list_end] [comment {--- end class enumeration ---}] +# } +#} # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ tcl::namespace::eval punk::lib::ensemble { @@ -579,19 +579,53 @@ namespace eval punk::lib { proc pdict {args} { - set sep " [a+ Web-seagreen]=[a] " + if {[catch {package require punk::ansi} errM]} { + set sep " = " + } else { + #set sep " [a+ Web-seagreen]=[a] " + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " + } set argspec [string map [list %sep% $sep] { *proc -name pdict -help {Print dict keys,values to channel (see also showdict)} + *opts -any 1 + #default separator to provide similarity to tcl's parray function -separator -default "%sep%" -roottype -default "dict" -substructure -default {} -channel -default stdout -help "existing channel - or 'none' to return as string" + *values -min 1 -max -1 - dictvar -type string -help "name of dict variable" - patterns -type string -default "*" -multiple 1 + + dictvar -type string -help "name of variable. Can be a dict, list or array" + + patterns -type string -default "*" -multiple 1 -help {Multiple patterns can be specified as separate arguments. + Each pattern consists of 1 or more segments separated by the hierarchy separator (forward slash) + The system uses similar patterns to the punk pipeline pattern-matching system. + The default assumed type is dict - but an array will automatically be extracted into key value pairs so will also work. + Segments are classified into list,dict and string operations. + Leading % indicates a string operation - e.g %# gives string length + A segment with a single @ is a list operation e.g @0 gives first list element, @1-3 gives the lrange from 1 to 3 + A segment containing 2 @ symbols is a dict operation. e.g @@k1 retrieves the value for dict key 'k1' + The operation type indicator is not always necessary if lower segments in the hierarchy are of the same type as the previous one. + e.g1 pdict env */%# + the pattern starts with default type dict, so * retrieves all keys & values, + the next hierarchy switches to a string operation to get the length of each value. + e.g2 pdict env W* S* + Here we supply 2 patterns, each in default dict mode - to display keys and values where the keys match the glob patterns + e.g3 pdict punk_testd */* + This displays 2 levels of the dict hierarchy. + Note that if the sublevel can't actually be interpreted as a dictionary (odd number of elements or not a list at all) + - then the normal = separator will be replaced with a coloured (or underlined if colour off) 'mismatch' indicator. + e.g4 set list {{k1 v1 k2 v2} {k1 vv1 k2 vv2}}; pdict list @0-end/@@k2 @*/@@k1 + Here we supply 2 separate pattern hierarchies, where @0-end and @* are list operations and are equivalent + The second level segement in each pattern switches to a dict operation to retrieve the value by key. + When a list operation such as @* is used - integer list indexes are displayed on the left side of the = for that hierarchy level. + + The pdict function operates on variable names - passing the value to the showdict function which operates on values + } }] #puts stderr "$argspec" set argd [punk::args::get_dict $argspec $args] @@ -621,20 +655,33 @@ namespace eval punk::lib { # - The current version is incomplete but passably usable. # - Copy proc and attempt rework so we can get back to this as a baseline for functionality proc showdict {args} { ;# analogous to parray (except that it takes the dict as a value) - set sep " [a+ Web-seagreen]=[a] " - set argd [punk::args::get_dict [string map [list %sep% $sep] { - *id punk::lib::pdict - *proc -name punk::lib::pdict -help "display dictionary keys and values" + #set sep " [a+ Web-seagreen]=[a] " + if {[catch {package require punk::ansi} errM]} { + set sep " = " + set RST "" + set sep_mismatch " mismatch " + } else { + set sep " [punk::ansi::a+ Green]=[punk::ansi::a] " ;#stick to basic default colours for wider terminal support + set RST [punk::ansi::a] + set sep_mismatch " [punk::ansi::a+ Brightred undercurly underline undt-white]mismatch[punk::ansi::a] " + } + package require punk ;#we need pipeline pattern matching features + package require textblock + + set argd [punk::args::get_dict [string map [list %sep% $sep %sep_mismatch% $sep_mismatch] { + *id punk::lib::showdict + *proc -name punk::lib::showdict -help "display dictionary keys and values" #todo - table tableobject -return -default "tailtohead" -choices {tailtohead sidebyside} -channel -default none -trimright -default 1 -type boolean -help "Trim whitespace off rhs of each line. This can help prevent a single long line that wraps in terminal from making every line wrap due to long rhs padding " - -separator -default "%sep%" -help "Separator column between keys and values" + -separator -default {%sep%} -help "Separator column between keys and values" + -separator_mismatch -default {%sep_mismatch%} -help "Separator to use when patterns mismatch" -roottype -default "dict" -help "list,dict,string" - -substructure -default {} -ansibase_keys -default "" -help "ansi list for each level in -substructure. e.g \[list \[a+ red\] \[a+ web-green\]\]" + -substructure -default {} -ansibase_values -default "" -keytemplates -default {${$key}} -type list -help "list of templates for keys at each level" -keysorttype -default "none" -choices {none dictionary ascii integer real} @@ -644,6 +691,7 @@ namespace eval punk::lib { patterns -default "*" -type string -multiple 1 -help "key or key glob pattern" }] $args] set opt_sep [dict get $argd opts -separator] + set opt_mismatch_sep [dict get $argd opts -separator_mismatch] set opt_keysorttype [dict get $argd opts -keysorttype] set opt_keysortdirection [dict get $argd opts -keysortdirection] set opt_trimright [dict get $argd opts -trimright] @@ -659,10 +707,40 @@ namespace eval punk::lib { set result "" + #pattern hierarchy + # */@1/@0,%#,%str @0/@1 - patterns each one is a pattern or pattern_nest + # * @1 @0,%#,%str - segments + # a b 1 0 %# %str - keys + set pattern_key_index [list] ;#list of pattern_nests, same length as number of keys generated set pattern_next_substructure [dict create] set pattern_this_structure [dict create] + # -- --- --- --- + #REVIEW + #as much as possible we should pass the indices along as a query to the pipeline pattern matching system so we're not duplicating the work and introducing inconsistencies. + #The main difference here is that sometimes we are treating the result as key-val pairs with the key being the query, other times the key is part of the query, or from the result itself (list/dict indices/keys). + #todo - determine if there is a more consistent rule-based way to do this rather than adhoc + #e.g pdict something * + #we want the keys from the result as individual lines on lhs + #e.g pdict something @@ + #we want on lhs result on rhs + # = v0 + #e.g pdict something @0-2,@4 + #we currently return: + #0 = v0 + #1 = v1 + #2 = v2 + #4 = v4 + #This means we've effectively auto-expanded the first list - elements 0-2. (or equivalently stated: we've flattened the 3 element and 1 element lists into one list of 4 elements) + #ie pdict is doing 'magic' compared to the normal pattern matching syntax, to make useage more convenient. + #this is a tradeoff that could create surprises and make things messy and/or inconsistent. + #todo - see if we can find a balance that gives consistency and logicality to the results whilst allowing still simplified matching syntax that is somewhat intuitive. + #It may be a matter of documenting what type of indexes are used directly as keys, and which return sets of further keys + #The solution for more consistency/predictability may involve being able to bracket some parts of the segment so for example we can apply an @join or %join within a segment + #that involves more complex pattern syntax & parsing (to be added to the main pipeline pattern syntax) + # -- --- --- --- + set filtered_keys [list] if {$opt_roottype in {dict list string}} { #puts "getting keys for roottype:$opt_roottype" @@ -671,176 +749,221 @@ namespace eval punk::lib { set re_idxdashidx {^([-+]{0,1}\d+|end[-+]{1}\d+|end)-([-+]{0,1}\d+|end[-+]{1}\d+|end)$} foreach pattern_nest $patterns { set keyset [list] - set pattern_nest_list [split $pattern_nest /] - set p [lindex $pattern_nest_list 0] - switch -exact -- $p { - * - "" { - if {$opt_roottype eq "list"} { - lappend keyset {*}[punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality - dict set pattern_this_structure $pattern_nest list - } elseif {$opt_roottype eq "dict"} { - lappend keyset {*}[dict keys $dval] - dict set pattern_this_structure $pattern_nest dict - } else { - lappend keyset %string - dict set pattern_this_structure $pattern_nest string - } - } - %# { - dict set pattern_this_structure $pattern_nest string - lappend keyset %# - } - # { - dict set pattern_this_structure $pattern_nest list - lappend keyset # - } - ## { - dict set pattern_this_structure $pattern_nest dict - lappend keyset [list ## query] - } - @* { - dict set pattern_this_structure $pattern_nest list - lappend keyset {*}[punk::lib::range 0 [llength $dval]-1] - } - @@ { - #get first k v from dict - dict set pattern_this_structure $pattern_nest dict - lappend keyset [list @@ query] - } - @*k@* - @*K@* { - #returns keys only - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict - } - @*.@* { - lappend keyset {*}[dict keys $dval] - dict set pattern_this_structure $pattern_nest dict - } - default { - #puts stderr "===p:$p" - switch -glob -- $p { - {@k\*@*} - {@K\*@*} { - #value glob return keys - #set search [string range $p 4 end] - #dict for {k v} $dval { - # if {[string match $search $v]} { - # lappend keyset $k - # } - #} - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict + set keyset_structure [list] + + set segments [split $pattern_nest /] + set levelpatterns [lindex $segments 0] ;#possibly comma separated patterns + #we need to use _split_patterns to separate (e.g to protext commas that appear within quotes) + set patterninfo [punk::_split_patterns $levelpatterns] + #puts stderr "showdict-->_split_patterns: $patterninfo" + foreach v_idx $patterninfo { + lassign $v_idx v idx + #we don't support vars on lhs of index in this context - (because we support simplified glob patterns such as x* and literal dict keys such as kv which would otherwise be interpreted as vars with no index) + set p $v$idx ;#_split_patterns has split too far in this context - the entire pattern is the index pattern + switch -exact -- $p { + * - "" { + if {$opt_roottype eq "list"} { + set keys [punk::lib::range 0 [llength $dval]-1] ;#compat wrapper around subset of lseq functionality + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + dict set pattern_this_structure $p list + } elseif {$opt_roottype eq "dict"} { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } else { + lappend keyset %string + lappend keyset_structure string + dict set pattern_this_structure $p string } - @@* { - #exact match key - review - should raise error to match punk pipe behaviour? - set k [string range $p 2 end] - if {[dict exists $dval $k]} { - lappend keyset $k + } + %# { + dict set pattern_this_structure $p string + lappend keyset %# + lappend keyset_structure string + } + # { + dict set pattern_this_structure $p list + lappend keyset # + lappend keyset_structure list + } + ## { + dict set pattern_this_structure $p dict + lappend keyset [list ## query] + lappend keyset_structure dict + } + @* { + puts ---->HERE<---- + dict set pattern_this_structure $p list + set keys [punk::lib::range 0 [llength $dval]-1] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } + @@ { + #get first k v from dict + dict set pattern_this_structure $p dict + lappend keyset [list @@ query] + lappend keyset_structure dict + } + @*k@* - @*K@* { + #returns keys only + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @*.@* { + set keys [dict keys $dval] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + default { + #puts stderr "===p:$p" + #the basic scheme also doesn't allow commas in dict keys access via the convenience @@key - which isn't great, especially for arrays where it is common practice! + #we've already sacrificed whitespace in keys - so extra limitations should be reduced if it's to be passably useful + #@@"key,etc" should allow any non-whitespace key + switch -glob -- $p { + {@k\*@*} - {@K\*@*} { + #value glob return keys + #set search [string range $p 4 end] + #dict for {k v} $dval { + # if {[string match $search $v]} { + # lappend keyset $k + # } + #} + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict } - dict set pattern_this_structure $pattern_nest dict - } - @k@* - @K@* { - set k [string range $p 3 end] - if {[dict exists $dval $k]} { - lappend keyset $k + @@* { + #exact match key - review - should raise error to match punk pipe behaviour? + set k [string range $p 2 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict } - dict set pattern_this_structure $pattern_nest dict - } - {@\*@*} { - #return list of values - #set k [string range $p 3 end] - #lappend keyset {*}[dict keys $dval $k] - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict - } - {@\*.@*} { - set k [string range $p 4 end] - lappend keyset {*}[dict keys $dval $k] - dict set pattern_this_structure $pattern_nest dict - } - {@v\*@*} - {@V\*@*} { - #value-glob return value - #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict - } - {@\*v@*} - {@\*V@*} { - #key-glob return value - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict - } - {@\*@*} - {@\*v@*} - {@\*V@} { - #key glob return val - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict - } - @??@* { - #exact key match - no error - lappend keyset [list $p query] - dict set pattern_this_structure $pattern_nest dict - } - default { - set this_type $opt_roottype - if {[string match @* $p]} { - #list mode - trim optional list specifier @ - set p [string range $p 1 end] - dict set pattern_this_structure $pattern_nest list - set this_type list - } elseif {[string match %* $p]} { - dict set pattern_this_structure $pattern_nest string - lappend keyset $p - set this_type string + @k@* - @K@* { + set k [string range $p 3 end] + if {[dict exists $dval $k]} { + lappend keyset $k + lappend keyset_structure dict + } + dict set pattern_this_structure $p dict } - if {$this_type eq "list"} { - dict set pattern_this_structure $pattern_nest list - if {[string is integer -strict $p]} { + {@\*@*} { + #return list of values + #set k [string range $p 3 end] + #lappend keyset {*}[dict keys $dval $k] + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*.@*} { + set k [string range $p 4 end] + set keys [dict keys $dval $k] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] + dict set pattern_this_structure $p dict + } + {@v\*@*} - {@V\*@*} { + #value-glob return value + #error "dict value-glob value-return only not supported here - bad pattern '$p' in '$pattern_nest'" + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*v@*} - {@\*V@*} { + #key-glob return value + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + {@\*@*} - {@\*v@*} - {@\*V@} { + #key glob return val + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + @??@* { + #exact key match - no error + lappend keyset [list $p query] + lappend keyset_structure dict + dict set pattern_this_structure $p dict + } + default { + set this_type $opt_roottype + if {[string match @* $p]} { + #list mode - trim optional list specifier @ + set p [string range $p 1 end] + dict set pattern_this_structure $p list + set this_type list + } elseif {[string match %* $p]} { + dict set pattern_this_structure $p string lappend keyset $p - } elseif {[string match "?*-?*" $p]} { - #could be either - don't change type - #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers - #now we should map _ to "" first - set p [string map {_ {}} $p] - #lassign [textutil::split::splitx $p {\.\.}] a b - if {![regexp $re_idxdashidx $p _match a b]} { - error "unrecognised pattern $p" - } - set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high - #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds - if {${lower_resolve} == -1} { - #lower bound is above upper list range - #match with decreasing indices is still possible - set lower [expr {[llength $dval]-1}] ;#set to max - } elseif {$lower_resolve == -2} { - set lower 0 - } else { - set lower $lower_resolve - } - set upper [punk::lib::lindex_resolve $dval $b] - if {$upper == -2} { - #upper bound is below list range - - if {$lower_resolve >=-1} { - set upper 0 + lappend keyset_structure string + set this_type string + } + if {$this_type eq "list"} { + dict set pattern_this_structure $p list + if {[string is integer -strict $p]} { + lappend keyset $p + lappend keyset_structure list + } elseif {[string match "?*-?*" $p]} { + #could be either - don't change type + #list indices with tcl8.7 underscores? be careful. Before 8.7 we could have used regexp \d on integers + #now we should map _ to "" first + set p [string map {_ {}} $p] + #lassign [textutil::split::splitx $p {\.\.}] a b + if {![regexp $re_idxdashidx $p _match a b]} { + error "unrecognised pattern $p" + } + set lower_resolve [punk::lib::lindex_resolve $dval $a] ;#-2 for too low, -1 for too high + #keep lower_resolve as separate var to lower for further checks based on which side out-of-bounds + if {${lower_resolve} == -1} { + #lower bound is above upper list range + #match with decreasing indices is still possible + set lower [expr {[llength $dval]-1}] ;#set to max + } elseif {$lower_resolve == -2} { + set lower 0 } else { - continue + set lower $lower_resolve + } + set upper [punk::lib::lindex_resolve $dval $b] + if {$upper == -2} { + #upper bound is below list range - + if {$lower_resolve >=-1} { + set upper 0 + } else { + continue + } + } elseif {$upper == -1} { + #use max + set upper [expr {[llength $dval]-1}] + #assert - upper >=0 because we have ruled out empty lists } - } elseif {$upper == -1} { - #use max - set upper [expr {[llength $dval]-1}] - #assert - upper >=0 because we have ruled out empty lists - } - #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order - lappend keyset {*}[punk::lib::range $lower $upper] + #note lower can legitimately be higher than upper - lib::range, like lseq can produce sequence in reverse order + set keys [punk::lib::range $lower $upper] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] list] + } else { + lappend keyset [list @$p query] + lappend keyset_structure list + } + } elseif {$this_type eq "string"} { + dict set pattern_this_structure $p string + } elseif {$this_type eq "dict"} { + #default equivalent to @\*@* + dict set pattern_this_structure $p dict + #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" + set keys [dict keys $dval $p] + lappend keyset {*}$keys + lappend keyset_structure {*}[lrepeat [llength $keys] dict] } else { - lappend keyset [list @$p query] - } - } elseif {$this_type eq "string"} { - dict set pattern_this_structure $pattern_nest string - } elseif {$this_type eq "dict"} { - #default equivalent to @\*@* - dict set pattern_this_structure $pattern_nest dict - #puts "dict: appending keys from index '$p' keys: [dict keys $dval $p]" - lappend keyset {*}[dict keys $dval $p] - } else { - puts stderr "list: unrecognised pattern $p" + puts stderr "list: unrecognised pattern $p" + } } } } @@ -848,48 +971,61 @@ namespace eval punk::lib { } # -- --- --- --- - #check next pattern for substructure type to use + #check next pattern-segment for substructure type to use # -- --- --- --- set substructure "" - set pnext [lindex $pattern_nest_list 1] - switch -exact $pnext { - "" { - set substructure string - } - @*k@* - @*K@* - @*.@* - ## { - set substructure dict - } - # { - set substructure list - } - ## { - set substructure dict - } - %# { - set substructure string - } - * { - #set substructure $opt_roottype - set substructure [dict get $pattern_this_structure $pattern_nest] - } - default { - switch -glob -- $pnext { - @??@* - @?@* - @@* { - #all 4 or 3 len prefixes bounded by @ are dict - set substructure dict - } - default { - if {[string match @* $pnext]} { - set substructure list - } elseif {[string match %* $pnext]} { - set substructure string - } else { - #set substructure $opt_roottype - set substructure [dict get $pattern_this_structure $pattern_nest] + set pnext [lindex $segments 1] + set patterninfo [punk::_split_patterns $levelpatterns] + if {[llength $patterninfo] == 0} { + # // ? -review - what does this mean? for xpath this would mean at any level + set substructure [lindex $pattern_this_structure end] + } elseif {[llength $patterninfo] == 1} { + # single type in segment e.g /@@something/ + switch -exact $pnext { + "" { + set substructure string + } + @*k@* - @*K@* - @*.@* - ## { + set substructure dict + } + # { + set substructure list + } + ## { + set substructure dict + } + %# { + set substructure string + } + * { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } + default { + switch -glob -- $pnext { + @??@* - @?@* - @@* { + #all 4 or 3 len prefixes bounded by @ are dict + set substructure dict + } + default { + if {[string match @* $pnext]} { + set substructure list + } elseif {[string match %* $pnext]} { + set substructure string + } else { + #set substructure $opt_roottype + #set substructure [dict get $pattern_this_structure $pattern_nest] + set substructure [lindex $pattern_this_structure end] + } } } } } + } else { + #e.g /@0,%str,.../ + #doesn't matter what the individual types are - we have a list result + set substructure list } #puts "--pattern_nest: $pattern_nest substructure: $substructure" dict set pattern_next_substructure $pattern_nest $substructure @@ -904,10 +1040,14 @@ namespace eval punk::lib { } } if {$int_keyset} { - set keyset [lsort -integer $keyset] + set sortindices [lsort -indices -integer $keyset] + #set keyset [lsort -integer $keyset] } else { - set keyset [lsort -$opt_keysorttype $keyset] + #set keyset [lsort -$opt_keysorttype $keyset] + set sortindices [lsort -indices -$opt_keysorttype $keyset] } + set keyset [lmap i $sortindices {lindex $keyset $i}] + set keyset_structure [lmap i $sortindices {lindex $keyset_structure $i}] } foreach k $keyset { @@ -915,6 +1055,7 @@ namespace eval punk::lib { } lappend filtered_keys {*}$keyset + lappend all_keyset_structure {*}$keyset_structure #puts stderr "--->pattern_nest:$pattern_nest keyset:$keyset" } @@ -929,7 +1070,6 @@ namespace eval punk::lib { #both keys and values could have newline characters. #simple use of 'format' won't cut it for more complex dict keys/values #use block::width or our columns won't align in some cases - set RST [a] switch -- $opt_return { "tailtohead" { #last line of key is side by side (possibly with separator) with first line of value @@ -945,12 +1085,16 @@ namespace eval punk::lib { set maxl [::tcl::mathfunc::max {*}[lmap v $display_keys {textblock::width $v}]] set kidx 0 + set last_hidekey 0 foreach keydisplay $display_keys key $filtered_keys { + set thisval "?" set hidekey 0 set pattern_nest [lindex $pattern_key_index $kidx] set pattern_nest_list [split $pattern_nest /] - #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest" - set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $pattern_nest] + #set this_type [dict get $pattern_this_structure $key] + set this_type [lindex $all_keyset_structure $kidx] + #puts stderr "---> kidx:$kidx key:$key - pattern_nest:$pattern_nest this_type:$this_type" set is_match 1 ;#whether to display the normal separator or bad-match separator switch -- $this_type { @@ -1030,7 +1174,7 @@ namespace eval punk::lib { } } string { - set hidekey 0 + set hidekey 1 if {$key eq "%string"} { set hidekey 1 set thisval $dval @@ -1043,11 +1187,21 @@ namespace eval punk::lib { lassign [split $key -] _ extra set width [expr {[textblock::width $dval] + $extra}] set thisval [textblock::pad $dval -which left -width $width] + } elseif {[string match *lpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which left -width $width -padchar $extra] } elseif {[string match *rpad-* $key]} { set hidekey 1 lassign [split $key -] _ extra set width [expr {[textblock::width $dval] + $extra}] set thisval [textblock::pad $dval -which right -width $width] + } elseif {[string match *rpadstr-* $key]} { + set hidekey 1 + lassign [split $key -] _ extra + set width [expr {[textblock::width $dval] + [tcl::string::length $extra]}] + set thisval [textblock::pad $dval -which right -width $width -padchar $extra] } else { if {[lindex $key 1] eq "query"} { set qry [lindex $key 0] @@ -1082,7 +1236,9 @@ namespace eval punk::lib { lassign [textblock::size $thisval] _vw vwidth _vh vheight #set blanks_above [string repeat \n [expr {$kheight -1}]] set vblock $opt_ansibase_values$thisval$RST - append result [textblock::join_basic -- $vblock] \n + #append result [textblock::join_basic -- $vblock] + #review - we wouldn't need this space if we had a literal %sp %sp-x ?? + append result " $vblock" } else { set ansibase_key [lindex $opt_ansibase_keys 0] @@ -1096,7 +1252,7 @@ namespace eval punk::lib { if {$is_match} { set use_sep $opt_sep } else { - set use_sep " [a+ Web-red undercurly underline undert-white]mismatch[a] " + set use_sep $opt_mismatch_sep } @@ -1105,8 +1261,12 @@ namespace eval punk::lib { set sblock [textblock::pad $blanks_above$use_sep$blanks_below -width $sepwidth] set vblock $blanks_above$opt_ansibase_values$thisval$RST #only vblock is ragged - we can do a basic join because we don't care about rhs whitespace + if {$last_hidekey} { + append result \n + } append result [textblock::join_basic -- $kblock $sblock $vblock] \n } + set last_hidekey $hidekey incr kidx } } diff --git a/src/modules/punk/mix/base-0.1.tm b/src/modules/punk/mix/base-0.1.tm index 6eec4d8d..8a4456d1 100644 --- a/src/modules/punk/mix/base-0.1.tm +++ b/src/modules/punk/mix/base-0.1.tm @@ -351,8 +351,14 @@ namespace eval punk::mix::base { continue } set testfolder [file join $candidate src $sub] - set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] - if {[llength $tmfiles]} { + #ensure that if src/modules exists - it is always included even if empty + if {[string tolower $sub] eq "modules"} { + lappend tm_folders $testfolder + continue + } + #set tmfiles [glob -nocomplain -dir $testfolder -type f -tail *.tm] + #set podfolders [glob -nocomplain -dir $testfolder -type d -tail #modpod-*] + if {[llength [glob -nocomplain -dir $testfolder -type f -tail *.tm]] || [llength [glob -nocomplain -dir $testfolder -type d -tail #modpod-*]]} { lappend tm_folders $testfolder } } @@ -428,9 +434,10 @@ namespace eval punk::mix::base { } #crc::cksum is extremely slow in tcllib as at 2023 e.g 20x slower (no c implementation?) + # - try builtin zlib crc instead? #sha1 is performant - and this is not being used in a cryptographic or adversarial context - so performance and practical unlikelihood of accidental collisions should be the main consideration. #adler32 is fastest for some larger files of a few MB but slower on small files (possibly due to Tcl-based file load?) - #sha1 as at 2023 seems a good default + #sha1 as at 2023 seems a reasonable default proc cksum_algorithms {} { variable sha3_implementation #sha2 is an alias for sha256 @@ -459,10 +466,16 @@ namespace eval punk::mix::base { #adler32 via file-slurp proc cksum_adler32_file {filename} { package require zlib; #should be builtin anyway - set data [punk::mix::util::fcat -translation binary $filename] + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] #set data [fileutil::cat -translation binary $filename] ;#no significant performance diff on windows - and doesn't handle win-illegal names zlib adler32 $data } + #zlib crc vie file-slurp + proc cksum_crc_file {filename} { + package require zlib + set data [punk::mix::util::fcat -translation binary -encoding iso8859-1 $filename] + zlib crc $data + } #required to be able to accept relative paths @@ -614,6 +627,9 @@ namespace eval punk::mix::base { package require cksum ;#tcllib set cksum_command [list crc::cksum -format 0x%X -file] } + crc { + set cksum_command [list cksum_crc_file] + } adler32 { set cksum_command [list cksum_adler32_file] } diff --git a/src/modules/punk/mix/cli-999999.0a1.0.tm b/src/modules/punk/mix/cli-999999.0a1.0.tm new file mode 100644 index 00000000..949de9cb --- /dev/null +++ b/src/modules/punk/mix/cli-999999.0a1.0.tm @@ -0,0 +1,1119 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use 'deck 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::mix::cli 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +##e.g package require frobz +package require punk::repo +package require punk::ansi +package require punkcheck ;#checksum and/or timestamp records + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#review +#deck - rename to dev +namespace eval punk::mix::cli { + namespace eval temp_import { + } + namespace ensemble create + + package require punk::overlay + catch { + punk::overlay::import_commandset module . ::punk::mix::commandset::module + } + punk::overlay::import_commandset debug . ::punk::mix::commandset::debug + punk::overlay::import_commandset repo . ::punk::mix::commandset::repo + punk::overlay::import_commandset lib . ::punk::mix::commandset::loadedlib + + catch { + package require punk::mix::commandset::project + punk::overlay::import_commandset project . ::punk::mix::commandset::project + punk::overlay::import_commandset projects . ::punk::mix::commandset::project::collection + } + if {[catch { + package require punk::mix::commandset::layout + punk::overlay::import_commandset project.layout . ::punk::mix::commandset::layout + punk::overlay::import_commandset project.layouts . ::punk::mix::commandset::layout::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::layout" + puts stderr $errM + } + if {[catch { + package require punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuite . ::punk::mix::commandset::buildsuite + punk::overlay::import_commandset buildsuites . ::punk::mix::commandset::buildsuite::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::buildsuite" + puts stderr $errM + } + punk::overlay::import_commandset scriptwrap . ::punk::mix::commandset::scriptwrap + if {[catch { + package require punk::mix::commandset::doc + punk::overlay::import_commandset doc . ::punk::mix::commandset::doc + punk::overlay::import_commandset "" "" ::punk::mix::commandset::doc::collection + } errM]} { + puts stderr "error loading punk::mix::commandset::doc" + puts stderr $errM + } + + + proc help {args} { + #set basehelp [punk::mix::base::help -extension [namespace current] {*}$args] + set basehelp [punk::mix::base help {*}$args] + #puts stdout "punk::mix help" + return $basehelp + } + + proc stat {{workingdir ""} args} { + dict set args -v 0 + punk::mix::cli::lib::get_status $workingdir {*}$args + } + proc status {{workingdir ""} args} { + dict set args -v 1 + punk::mix::cli::lib::get_status $workingdir {*}$args + } + + + + + + + +} + + +namespace eval punk::mix::cli { + + + #interp alias {} ::punk::mix::cli::project.new {} ::punk::mix::cli::new + + + proc make {args} { + set startdir [pwd] + set project_base "" ;#empty for unknown + if {[punk::repo::is_git $startdir]} { + set project_base [punk::repo::find_git] + set sourcefolder $project_base/src + } elseif {[punk::repo::is_fossil $startdir]} { + set project_base [punk::repo::find_fossil] + set sourcefolder $project_base/src + } else { + if {[punk::repo::is_candidate $startdir]} { + set project_base [punk::repo::find_candidate] + set sourcefolder $project_base/src + puts stderr "WARNING - project not under git or fossil control" + puts stderr "Using base folder $project_base" + } else { + set sourcefolder $startdir + } + } + + #review - why can't we be anywhere in the project? + #also - if no make.tcl - can we use the running shell's make.tcl ? (after prompting user?) + if {([file tail $sourcefolder] ne "src") || (![file exists $sourcefolder/make.tcl])} { + puts stderr "dev make must be run from src folder containing make.tcl - unable to proceed (cwd: [pwd])" + if {[string length $project_base]} { + if {[file exists $project_base/src] && [string tolower [pwd]] ne [string tolower $project_base/src]} { + puts stderr "Try cd to $project_base/src" + } + } else { + if {[file exists $startdir/Makefile]} { + puts stdout "A Makefile exists at $startdir/Makefile." + if {"windows" eq $::tcl_platform(platform)} { + puts stdout "Try running: msys2 -ucrt64 -here -c \"make build\" or bash -c \"make build\"" + } else { + puts stdout "Try runing: make build" + } + } + } + return false + } + + if {![string length $project_base]} { + puts stderr "WARNING no git or fossil repository detected." + puts stderr "Using base folder $startdir" + set project_base $startdir + } + + set lc_this_exe [string tolower [info nameofexecutable]] + set lc_proj_bin [string tolower $project_base/bin] + set lc_build_bin [string tolower $project_base/src/_build] + + if {"project" in $args} { + set is_own_exe 0 + if {[string match "${lc_proj_bin}*" $lc_this_exe] || [string match "${lc_build_bin}" $lc_this_exe]} { + set is_own_exe 1 + puts stderr "WARNING - running make using executable that may be created by the project being built" + set answer [util::askuser "Do you want to proceed using this executable? (build will probably stop when it is unable to update the executable) Y|N"] + if {[string tolower $answer] ne "y"} { + puts stderr "mix new aborting due to user response '$answer' (required Y|y to proceed) use -confirm 0 to avoid prompts." + return + } + } + } + cd $sourcefolder + #use run so that stdout visible as it goes + if {![catch {run --timeout=55000 -debug [info nameofexecutable] $sourcefolder/make.tcl {*}$args} exitinfo]} { + #todo - notify if exit because of timeout! + puts stderr "exitinfo: $exitinfo" + set exitcode [dict get $exitinfo exitcode] + } else { + puts stderr "Error unable to determine exitcode. err: $exitinfo" + cd $startdir + return false + } + + cd $startdir + if {$exitcode != 0} { + puts stderr "FAILED with exitcode $exitcode" + return false + } else { + puts stdout "OK make finished " + return true + } + } + + proc Kettle {args} { + tailcall lib::kettle_call lib {*}$args + } + proc KettleShell {args} { + tailcall lib::kettle_call shell {*}$args + } + + + + namespace eval lib { + namespace path ::punk::mix::util + + + proc module_types {} { + #first in list is default for unspecified -type when creating new module + #return [list plain tarjar zipkit] + return [list plain tarjar zip] + } + + proc validate_modulename {modulename args} { + set opts [list\ + -errorprefix validate_modulename\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_modulename error: unknown option '$k'. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + + validate_name_not_empty_or_spaced $modulename -errorprefix $opt_errorprefix + set testname [string map {:: {}} $modulename] + if {[string first : $testname] >=0} { + error "$opt_errorprefix '$modulename' can only contain paired colons" + } + set badchars [list - "$" "?" "*"] + foreach bc $badchars { + if {[string first $bc $modulename] >= 0} { + error "$opt_errorprefix '$modulename' can not contain character '$bc'" + } + } + return $modulename + } + + proc validate_projectname {projectname args} { + set defaults [list\ + -errorprefix projectname\ + ] + if {[llength $args] %2 != 0} {error "validate_modulename args must be name-value pairs: received '$args'"} + set known_opts [dict keys $defaults] + foreach k [dict keys $args] { + if {$k ni $known_opts} { + error "validate_modulename error: unknown option $k. known options: $known_opts" + } + } + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + validate_name_not_empty_or_spaced $projectname -errorprefix $opt_errorprefix + set reserved_words [list etc lib bin modules src doc vendorlib vendormodules embedded runtime _aside _build] + if {$projectname in $reserved_words } { + error "$opt_errorprefix '$projectname' cannot be one of reserved_words: $reserved_words" + } + if {[string first "::" $projectname] >= 0} { + error "$opt_errorprefix '$projectname' cannot contain namespace separator '::'" + } + return $projectname + } + proc validate_name_not_empty_or_spaced {name args} { + set opts [list\ + -errorprefix projectname\ + ] + if {[llength $args] %2 != 0} {error "validate_name_not_empty_or_spaced args must be name-value pairs: received '$args'"} + foreach {k v} $args { + switch -- $k { + -errorprefix { + dict set opts $k $v + } + default { + error "validate_name_not_empty_or_spaced error: unknown option $k. known options: [dict keys $opts]" + } + } + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_errorprefix [dict get $opts -errorprefix] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- + if {![string length $name]} { + error "$opt_errorprefix cannot be empty" + } + if {[string length [string map [list " " "" \n "" \r "" \t ""] $name]] != [string length $name]} { + error "$opt_errorprefix cannot contain whitespace" + } + return $name + } + + #split modulename (as present in a filename or namespaced name) into name/version ignoring leading namespace path + #ignore trailing .tm .TM if present + #if version doesn't pass validation - treat it as part of the modulename and return empty version string without error + #Up to caller to validate. + proc split_modulename_version {modulename} { + set lastpart [namespace tail $modulename] + set lastpart [file tail $lastpart] ;# should be ok to use file tail now that we've ensured no namespace components + if {[string equal -nocase [file extension $modulename] ".tm"]} { + set fileparts [split [file rootname $lastpart] -] + } else { + set fileparts [split $lastpart -] + } + if {[punk::mix::util::is_valid_tm_version [lindex $fileparts end]]} { + set versionsegment [lindex $fileparts end] + set namesegment [join [lrange $fileparts 0 end-1] -];#re-stitch + } else { + # + set namesegment [join $fileparts -] + set versionsegment "" + } + return [list $namesegment $versionsegment] + } + + proc get_status {{workingdir ""} args} { + set result "" + if {$workingdir ne ""} { + if {[file pathtype $workingdir] ne "absolute"} { + set workingdir [file normalize $workingdir] + } + set active_dir $workingdir + } else { + set active_dir [pwd] + } + set defaults [dict create\ + -v 1\ + ] + set opts [dict merge $defaults $args] + # -- --- --- --- --- --- --- --- --- + set opt_v [dict get $opts -v] + # -- --- --- --- --- --- --- --- --- + + + set repopaths [punk::repo::find_repos [pwd]] + set repos [dict get $repopaths repos] + if {![llength $repos]} { + append result [dict get $repopaths warnings] + } else { + append result [dict get $repopaths warnings] + lassign [lindex $repos 0] repopath repotypes + if {"fossil" in $repotypes} { + #review - multiple process launches to fossil a bit slow on windows.. + #could we query global db in one go instead? + # + set fossil_prog [auto_execok fossil] + append result "FOSSIL project based at $repopath with revision: [punk::repo::fossil_revision $repopath]" \n + set fosinfo [exec {*}$fossil_prog info] + append result [join [punk::repo::grep {repository:*} $fosinfo] \n] \n + + set fosrem [exec {*}$fossil_prog remote ls] + if {[string length $fosrem]} { + append result "Remotes:\n" + append result " " $fosrem \n + } + + + append result [join [punk::repo::grep {tags:*} $fosinfo] \n] \n + + set dbinfo [exec {*}$fossil_prog dbstat] + append result [join [punk::repo::grep {project-name:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {tickets:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {project-age:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {latest-change:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {files:*} $dbinfo] \n] \n + append result [join [punk::repo::grep {check-ins:*} $dbinfo] \n] \n + if {"project" in $repotypes} { + #punk project + if {![catch {package require textblock; package require patternpunk}]} { + set result [textblock::join -- [>punk . logo] " " $result] + append result \n + } + } + + set timeline [exec fossil timeline -n 5 -t ci] + set timeline [string map {\r\n \n} $timeline] + append result $timeline + if {$opt_v} { + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes fossil] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + + } + #repotypes *could* be both git and fossil - so report both if so + if {"git" in $repotypes} { + append result "GIT project based at $repopath with revision: [punk::repo::git_revision $repopath]" \n + if {[string length [set git_prog [auto_execok git]]]} { + set git_remotes [exec {*}$git_prog remote -v] + append result $git_remotes + if {$opt_v} { + set repostate [punk::repo::workingdir_state $repopath -repopaths $repopaths -repotypes git] + append result \n [punk::repo::workingdir_state_summary $repostate] + } + } + } + + } + + return $result + } + + + proc build_modules_from_source_to_base {srcdir basedir args} { + set antidir [list "#*" "_build" "_aside" ".git" ".fossil*"] ;#exact or glob patterns for folders (at any level) we don't want to search in or copy. + set defaults [list\ + -installer punk::mix::cli::build_modules_from_source_to_base\ + -call-depth-internal 0\ + -max_depth 1000\ + -subdirlist {}\ + -punkcheck_eventobj "\uFFFF"\ + -glob *.tm\ + -podglob #modpod-*\ + ] + set opts [dict merge $defaults $args] + + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set installername [dict get $opts -installer] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set CALLDEPTH [dict get $opts -call-depth-internal] + set max_depth [dict get $opts -max_depth] + set subdirlist [dict get $opts -subdirlist] + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set fileglob [dict get $opts -glob] + set podglob [dict get $opts -podglob] + if {![string match "*.tm" $fileglob]} { + error "build_modules_from_source_to_base -glob '$fileglob' doesn't seem to target tcl modules." + } + # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- + set opt_punkcheck_eventobj [dict get $opts -punkcheck_eventobj] + + set magicversion [punk::mix::util::magic_tm_version] ;#deliberately large so given load-preference when testing + set module_list [list] + + if {[file tail [file dirname $srcdir]] ne "src"} { + puts stderr "ERROR build_modules_from_source_to_base can only be called with a srcdir that is a subfolder of your 'src' directory" + puts stderr "The .tm modules are namespaced based on their directory depth - so we need to start at the root" + puts stderr "To build a subtree of your modules - use an appropriate src/modules folder and pass in the -subdirlist." + puts stderr "e.g if your modules are based at /x/src/modules2 and you wish to build only the .tm files at /x/src/modules2/skunkworks/lib" + puts stderr "Use: >build_modules_from_source_to_base /x/src/modules2 /x/modules2 -subdirlist {skunkworks lib}" + exit 2 + } + set srcdirname [file tail $srcdir] + + set build [file dirname $srcdir]/_build/$srcdirname ;#relative to *original* srcdir - not current_source_dir + if {[llength $subdirlist] == 0} { + set target_module_dir $basedir + set current_source_dir $srcdir + } else { + set target_module_dir $basedir/[file join {*}$subdirlist] + set current_source_dir $srcdir/[file join {*}$subdirlist] + } + if {![file exists $target_module_dir]} { + error "build_modules_from_source_to_base from current source dir: '$current_source_dir'. Basedir:'$current_module_dir' doesn't exist or is empty" + } + if {![file exists $current_source_dir]} { + error "build_modules_from_source_to_base from current source dir:'$current_source_dir' doesn't exist or is empty" + } + + #---------------------------------------- + set punkcheck_file [file join $basedir/.punkcheck] + if {$CALLDEPTH == 0} { + + set config [dict create\ + -glob $fileglob\ + -max_depth 0\ + ] + #lassign [punkcheck::start_installer_event $punkcheck_file $installername $srcdir $basedir $config] _eventid punkcheck_eventid _recordset record_list + # -- --- + set installer [punkcheck::installtrack new $installername $punkcheck_file] + $installer set_source_target $srcdir $basedir + set event [$installer start_event $config] + # -- --- + + } else { + set event $opt_punkcheck_eventobj + } + #---------------------------------------- + + + set process_modules [dict create] + #put pods first in processing order + set src_pods [glob -nocomplain -dir $current_source_dir -type d -tail $podglob] + foreach podpath $src_pods { + dict set process_modules $podpath [dict create -type pod] + } + set src_modules [glob -nocomplain -dir $current_source_dir -type f -tail $fileglob] + foreach modulepath $src_modules { + dict set process_modules $modulepath [dict create -type file] + } + + set did_skip 0 ;#flag for stdout/stderr formatting only + dict for {modpath modinfo} $process_modules { + set modtype [dict get $modinfo -type] + + set is_interesting 0 + if {[string match "foobar" $current_source_dir]} { + set is_interesting 1 + } + if {$is_interesting} { + puts "build_modules_from_source_to_base >>> module $current_source_dir/$modpath" + } + set fileparts [split [file rootname $modpath] -] + #set tmfile_versionsegment [lindex $fileparts end] + lassign [split_modulename_version $modpath] basename tmfile_versionsegment + if {$tmfile_versionsegment eq ""} { + #split_modulename_version version part will be empty if not valid tcl version + #last segment doesn't look even slightly versiony - fail. + puts stderr "ERROR: Unable to confirm file $current_source_dir/$modpath is a reasonably versioned .tm module - ABORTING." + exit 1 + } + switch -- $modtype { + pod { + #basename still contains leading #modpod- + if {[string match #modpod-* $basename]} { + set basename [string range $basename 8 end] + } else { + error "build_modules_from_source_to_base, pod, unexpected basename $basename" ;#shouldn't be possible with default podglob - review - why is podglob configurable? + } + set versionfile $current_source_dir/$basename-buildversion.txt ;#needs to be added in targetset_addsource to trigger rebuild if changed (only when magicversion in use) + if {$tmfile_versionsegment eq $magicversion} { + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + } else { + set module_build_version $tmfile_versionsegment + } + + set buildfolder $current_source_dir/_build + file mkdir $buildfolder + # -- --- + set config [dict create\ + -glob *\ + -max_depth 100\ + ] + # -max_depth -1 for no limit + set build_installername pods_in_$current_source_dir + set build_installer [punkcheck::installtrack new $build_installername $buildfolder/.punkcheck] + $build_installer set_source_target $current_source_dir/$modpath $buildfolder + set build_event [$build_installer start_event $config] + # -- --- + set podtree_copy $buildfolder/#modpod-$basename-$module_build_version + set modulefile $buildfolder/$basename-$module_build_version.tm + + + $build_event targetset_init INSTALL $podtree_copy + $build_event targetset_addsource $current_source_dir/$modpath + if {$tmfile_versionsegment eq $magicversion} { + $build_event targetset_addsource $versionfile + } + if {\ + [llength [dict get [$build_event targetset_source_changes] changed]]\ + || [llength [$build_event get_targets_exist]] < [llength [$build_event get_targets]]\ + } { + $build_event targetset_started + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + + set delete_failed 0 + if {[file exists $buildfolder/]} { + puts stderr "deleting existing _build copy at $podtree_copy" + if {[catch { + file delete -force $podtree_copy + } errMsg]} { + puts stderr "[punk::ansi::a+ red]deletion of _build copy at $podtree_copy failed: $errMsg[punk::ansi::a]" + set delete_failed 1 + } + } + if {!$delete_failed} { + puts stdout "copying.." + puts stdout "$current_source_dir/$modpath" + puts stdout "to:" + puts stdout "$podtree_copy" + file copy $current_source_dir/$modpath $podtree_copy + if {$tmfile_versionsegment eq $magicversion} { + set tmfile $buildfolder/#modpod-$basename-$module_build_version/$basename-$magicversion.tm + if {[file exists $tmfile]} { + set newname $buildfolder/#modpod-$basename-$module_build_version/$basename-$module_build_version.tm + file rename $tmfile $newname + set tmfile $newname + } + set fd [open $tmfile r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $tmfile w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + } + #delete and regenerate zip and modpod stubbed zip + set had_error 0 + set notes [list] + if {[catch { + file delete $buildfolder/$basename-$module_build_version.zip + } err] } { + set had_error 1 + lappend notes "zip_delete_failed" + } + if {[catch { + file delete $buildfolder/$basename-$module_build_version.tm + } err]} { + set had_error 1 + lappend notes "tm_delete_failed" + } + #create ordinary zip file without using external executable + package require punk::zip + set zipfile $buildfolder/$basename-$module_build_version.zip ;#ordinary zip file (deflate) + + if 0 { + #use -base $buildfolder so that -directory is included in the archive - the modpod stub relies on this - and extraction would be potentially messy otherwise + punk::zip::mkzip -base $buildfolder -directory $buildfolder/#modpod-$basename-$module_build_version -- $zipfile * + #punk::zip::mkzip stores permissions - (unix style) which confuses zipfs when reading - it misidentifies dirs as files + } + #zipfs mkzip does exactly what we need anyway in this case + set wd [pwd] + cd $buildfolder + puts "zipfs mkzip $zipfile #modpod-$basename-$module_build_version" + zipfs mkzip $zipfile #modpod-$basename-$module_build_version + cd $wd + + package require modpod + modpod::lib::make_zip_modpod $zipfile $modulefile + + + if {$had_error} { + $build_event targetset_end FAILED -note [join $notes ,] + } else { + # -- ---------- + $build_event targetset_end OK + # -- ---------- + } + } else { + $build_event targetset_end FAILED -note "could not delete $podtree_copy" + } + + } else { + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $build_event targetset_end SKIPPED + } + $build_event destroy + $build_installer destroy + + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $modulefile + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $modulefile + file copy -force $modulefile $target_module_dir + puts stderr "Copied zip modpod module $modulefile to $target_module_dir" + # -- --- --- --- --- --- + $event targetset_end OK -note "zip modpod" + } else { + puts -nonewline stderr "." + set did_skip 1 + if {$is_interesting} { + puts stderr "$modulefile [$event targetset_source_changes]" + } + $event targetset_end SKIPPED + } + } + tarjar { + #basename may still contain #tarjar- + #to be obsoleted - update modpod to (optionally) use vfs::tar + } + file { + set m $modpath + if {$tmfile_versionsegment eq $magicversion} { + #set basename [join [lrange $fileparts 0 end-1] -] + set versionfile $current_source_dir/$basename-buildversion.txt + set versionfiledata "" + if {![file exists $versionfile]} { + puts stderr "\nWARNING: Missing buildversion text file: $versionfile" + puts stderr "Using version 0.1 - create $versionfile containing the desired version number as the top line to avoid this warning\n" + set module_build_version "0.1" + } else { + set fd [open $versionfile r] + set versionfiledata [read $fd]; close $fd + set ln0 [lindex [split $versionfiledata \n] 0] + set ln0 [string trim $ln0]; set ln0 [string trim $ln0 \r] + if {![util::is_valid_tm_version $ln0]} { + puts stderr "ERROR: build version '$ln0' specified in $versionfile is not suitable. Please ensure a proper version number is at first line of file" + exit 3 + } + set module_build_version $ln0 + } + + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion]} { + #rebuild the .tm from the #tarjar + + if {[file exists $current_source_dir/#tarjar-$basename-$magicversion/DESCRIPTION.txt]} { + + } else { + + } + #REVIEW - should be in same structure/depth as $target_module_dir in _build? + + #TODO + set buildfolder $current_sourcedir/_build + file mkdir $buildfolder + + set tmfile $buildfolder/$basename-$module_build_version.tm + file delete -force $buildfolder/#tarjar-$basename-$module_build_version + file delete -force $tmfile + + + file copy -force $current_source_dir/#tarjar-$basename-$magicversion $buildfolder/#tarjar-$basename-$module_build_version + # + #bsdtar doesn't seem to work.. or I haven't worked out the right options? + #exec tar -cvf $buildfolder/$basename-$module_build_version.tm $buildfolder/#tarjar-$basename-$module_build_version + package require tar + tar::create $tmfile $buildfolder/#tarjar-$basename-$module_build_version + if {![file exists $tmfile]} { + puts stdout "ERROR: failed to build tarjar file $tmfile" + exit 4 + } + #copy the file? + #set target $target_module_dir/$basename-$module_build_version.tm + #file copy -force $tmfile $target + + lappend module_list $tmfile + } else { + #assume that either the .tm is not a tarjar - or the tarjar dir is capped (trailing #) and the .tm has been manually tarred. + if {[file exists $current_source_dir/#tarjar-$basename-${magicversion}#]} { + puts stderr "\nWarning: found 'capped' folder #tarjar-$basename-${magicversion}# - No attempt being made to update version in description.txt" + } + + #------------------------------ + # + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$basename-$module_build_version.tm] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + $event targetset_init INSTALL $target_module_dir/$basename-$module_build_version.tm + $event targetset_addsource $versionfile + $event targetset_addsource $current_source_dir/$m + + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $versionfile] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + + + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + set target $target_module_dir/$basename-$module_build_version.tm + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + puts stdout "copying module $current_source_dir/$m to $target as version: $module_build_version ([file tail $target])" + set fd [open $current_source_dir/$m r]; fconfigure $fd -translation binary; set data [read $fd]; close $fd + set data [string map [list $magicversion $module_build_version] $data] + set fdout [open $target w] + fconfigure $fdout -translation binary + puts -nonewline $fdout $data + close $fdout + #file copy -force $srcdir/$m $target + lappend module_list $target + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK + } else { + if {$is_interesting} { + puts stdout "skipping module $current_source_dir/$m - no change in sources detected" + } + puts -nonewline stderr "." + set did_skip 1 + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + + #------------------------------ + + } + + continue + } + ##------------------------------ + ## + #set target_relpath [punkcheck::lib::path_relative $basedir $target_module_dir/$m] + #set file_record [punkcheck::installfile_begin $basedir $target_relpath $installername -eventid $punkcheck_eventid] + #set changed_list [list] + ## -- --- --- --- --- --- + #set source_relpath [punkcheck::lib::path_relative $basedir $current_source_dir/$m] + #set file_record [punkcheck::installfile_add_source_and_fetch_metadata $basedir $source_relpath $file_record] + ## -- --- --- --- --- --- + #set changed_unchanged [punkcheck::recordlist::file_install_record_source_changes [lindex [dict get $file_record body] end]] + #set changed_list [dict get $changed_unchanged changed] + #---------- + $event targetset_init INSTALL $target_module_dir/$m + $event targetset_addsource $current_source_dir/$m + if {\ + [llength [dict get [$event targetset_source_changes] changed]]\ + || [llength [$event get_targets_exist]] < [llength [$event get_targets]]\ + } { + + #set file_record [punkcheck::installfile_started_install $basedir $file_record] + $event targetset_started + # -- --- --- --- --- --- + if {$did_skip} {set did_skip 0; puts -nonewline stdout \n} + lappend module_list $current_source_dir/$m + file copy -force $current_source_dir/$m $target_module_dir + puts stderr "Copied already versioned module $current_source_dir/$m to $target_module_dir" + # -- --- --- --- --- --- + #set file_record [punkcheck::installfile_finished_install $basedir $file_record] + $event targetset_end OK -note "already versioned module" + } else { + puts -nonewline stderr "." + set did_skip 1 + if {$is_interesting} { + puts stderr "$current_source_dir/$m [$event targetset_source_changes]" + } + #set file_record [punkcheck::installfile_skipped_install $basedir $file_record] + $event targetset_end SKIPPED + } + } + } + } ;#end dict for {modpath modinfo} $process_modules + + + if {$CALLDEPTH >= $max_depth} { + set subdirs [list] + } else { + set subdirs [glob -nocomplain -dir $current_source_dir -type d -tail *] + } + #puts stderr "subdirs: $subdirs" + foreach d $subdirs { + set skipdir 0 + foreach dg $antidir { + if {[string match $dg $d]} { + set skipdir 1 + continue + } + } + if {$skipdir} { + continue + } + if {![file exists $target_module_dir/$d]} { + file mkdir $target_module_dir/$d + } + lappend module_list {*}[build_modules_from_source_to_base $srcdir $basedir\ + -call-depth-internal [expr {$CALLDEPTH +1}]\ + -subdirlist [list {*}$subdirlist $d]\ + -punkcheck_eventobj $event\ + -glob $fileglob\ + -podglob $podglob\ + ] + } + if {$did_skip} { + puts -nonewline stdout \n + } + if {$CALLDEPTH == 0} { + $event destroy + $installer destroy + } + return $module_list + } + + variable kettle_reset_bodies [dict create] + variable kettle_reset_args [dict create] + #We are abusing kettle to run in-process. + # when we change to another project we need recipes to be reloaded. + # Kettle rewrites some of it's own procs - stopping reloading of recipes when we change folders + #kettle_init stores the original proc bodies & args + proc kettle_init {} { + variable kettle_reset_bodies ;#dict + variable kettle_reset_args + set reset_procs [list\ + ::kettle::benchmarks\ + ::kettle::doc\ + ::kettle::figures\ + ::kettle::meta::scan\ + ::kettle::testsuite\ + ] + foreach p $reset_procs { + set b [info body $p] + if {[string match "*Overwrite self*" $b]} { + dict set kettle_reset_bodies $p $b + set argnames [info args $p] + set arglist [list] + foreach a $argnames { + if {[info default $p $a dval]} { + lappend arglist [list $a $dval] + } else { + lappend arglist $a + } + } + dict set kettle_reset_args $p $arglist + } + } + + } + #call kettle_reinit to ensure recipes point to current project + proc kettle_reinit {} { + variable kettle_reset_bodies + variable kettle_reset_args + dict for {p b} $kettle_reset_bodies { + #set b [dict get $kettle_reset_bodies $p] + set argl [dict get $kettle_reset_args $p] + uplevel 1 [list ::proc $p $argl $b] + } + #todo - determine standard recipes by examining standard.tcl instead of hard coding? + set standard_recipes [list\ + null\ + forever\ + list-recipes\ + help-recipes\ + help-dump\ + help-recipes\ + help\ + list\ + list-options\ + help-options\ + show-configuration\ + show-state\ + show\ + meta-status\ + gui\ + ] + #set ::kettle::recipe::recipe [dict create] + dict for {r -} $::kettle::recipe::recipe { + if {$r ni $standard_recipes} { + dict unset ::kettle::recipe::recipe $r + } + } + } + proc kettle_call {calltype args} { + variable kettle_reset_bodies + switch -- $calltype { + lib {} + shell { + set kettleappfile [file dirname [info nameofexecutable]]/kettle + set kettlebatfile [file dirname [info nameofexecutable]]/kettle.bat + + if {(![file exists $kettleappfile]) && (![file exists $kettlebatfile])} { + error "deck kettle_call unable to find installed kettle application file '$kettleappfile' (or '$kettlebatfile' if on windows)" + } + if {[file exists $kettleappfile]} { + set kettlescript $kettleappfile + } + if {$::tcl_platform(platform) eq "windows"} { + if {[file exists $kettlebatfile]} { + set kettlescript $kettlebatfile + } + } + } + default { + error "deck kettle_call 1st argument must be one of: 'lib' for direct use of kettle module or 'shell' to call as separate process" + } + } + set startdir [pwd] + if {![file exists $startdir/build.tcl]} { + error "deck kettle must be run from a folder containing build.tcl (cwd: [pwd])" + } + if {[package provide kettle] eq ""} { + puts stdout "Loading kettle package - may be delay on first load ..." + package require kettle + kettle_init ;#store original procs for those kettle procs that rewrite themselves + } else { + if {[dict size $kettle_reset_bodies] == 0} { + #presumably package require kettle was called without calling our kettle_init hack. + kettle_init + } else { + #undo proc rewrites + kettle_reinit + } + } + set first [lindex $args 0] + if {[string match @* $first]} { + error "deck kettle doesn't support special operations - try calling tclsh kettle directly" + } + if {$first eq "-f"} { + set args [lassign $args __ path] + } else { + set path $startdir/build.tcl + } + set opts [list] + + if {[lindex $args 0] eq "-trace"} { + set args [lrange $args 1 end] + lappend opts --verbose on + } + set goals [list] + + if {$calltype eq "lib"} { + file mkdir ~/.kettle + set dotfile ~/.kettle/config + if {[file exists $dotfile] && + [file isfile $dotfile] && + [file readable $dotfile]} { + ::kettle io trace {Loading dotfile $dotfile ...} + set args [list {*}[::kettle path cat $dotfile] {*}$args] + } + } + + #hardcoded kettle option names (::kettle option names) - retrieved using kettle::option names + #This is done so we don't have to load kettle lib for shell call (both loading as module and running shell are annoyingly SLOW) + #REVIEW - needs to be updated to keep in sync with kettle. + set knownopts [list\ + --exec-prefix --bin-dir --lib-dir --prefix --man-dir --html-dir --markdown-dir --include-dir \ + --ignore-glob --dry --verbose --machine --color --state --config --with-shell --log \ + --log-append --log-mode --with-dia --constraints --file --limitconstraints --tmatch --notfile --single --valgrind --tskip --repeats \ + --iters --collate --match --rmatch --with-doc-destination --with-git --target --test-include \ + ] + + while {[llength $args]} { + set o [lindex $args 0] + switch -glob -- $o { + --* { + #instead of using: kettle option known + if {$o ni $knownopts} { + error "Unable to process unknown option $o." {} [list KETTLE (deck)] + } + lappend opts $o [lindex $args 1] + #::kettle::option set $o [lindex $args 1] + set args [lrange $args 2 end] + } + default { + lappend goals $o + set args [lrange $args 1 end] + } + } + } + + if {![llength $goals]} { + lappend goals help + } + if {"--prefix" ni [dict keys $opts]} { + dict set opts --prefix [file dirname $startdir] + } + if {$calltype eq "lib"} { + ::kettle status clear + ::kettle::option::set @kettle $startdir + foreach {o v} $opts { + ::kettle option set $o $v + } + ::kettle option set @srcscript $path + ::kettle option set @srcdir [file dirname $path] + ::kettle option set @goals $goals + #load standard recipes as listed in build.tcl + ::source $path + puts stderr "recipes: [::kettle recipe names]" + ::kettle recipe run {*}[::kettle option get @goals] + + set state [::kettle option get --state] + if {$state ne {}} { + puts stderr "saving kettle state: $state" + ::kettle status save $state + } + + } else { + #shell + puts stdout "Running external kettle process with args: $opts $goals" + run -n tclsh $kettlescript -f $path {*}$opts {*}$goals + } + + } + proc kettle_punk_recipes {} { + set txtdst ... + } + + } +} + + +namespace eval punk::mix::cli { + proc _cli {args} { + #don't use tailcall - base uses info level to determine caller + ::punk::mix::base::_cli {*}$args + } + variable default_command help + package require punk::mix::base + package require punk::overlay + if {[catch { + punk::overlay::custom_from_base [namespace current] ::punk::mix::base + } errM]} { + puts stderr "punk::mix::cli load error: Failed to overlay punk::mix::base $errM" + error "punk::mix::cli error: $errM" + } +} + + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::mix::cli [namespace eval punk::mix::cli { + variable version + set version 999999.0a1.0 +}] +return diff --git a/src/modules/punk/mix/cli-buildversion.txt b/src/modules/punk/mix/cli-buildversion.txt new file mode 100644 index 00000000..8a16d4cb --- /dev/null +++ b/src/modules/punk/mix/cli-buildversion.txt @@ -0,0 +1,3 @@ +0.3.1 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm index 7bdce9ac..09ca2d70 100644 --- a/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/loadedlib-999999.0a1.0.tm @@ -247,7 +247,8 @@ namespace eval punk::mix::commandset::loadedlib { set projectdir [dict get $pathinfo closest] if {$projectdir ne ""} { set modulefolders [punk::mix::cli::lib::find_source_module_paths $projectdir] - foreach k [list modules vendormodules] { + set majorv [lindex [split [info tclversion] .] 0] + foreach k [list modules modules_tcl$majorv vendormodules vendormodules_tcl$majorv] { set knownfolder [file join $projectdir src $k] if {$knownfolder ni $modulefolders} { lappend modulefolders $knownfolder @@ -261,7 +262,7 @@ namespace eval punk::mix::commandset::loadedlib { #special case bootsupport/modules so it can be referred to as just bootsupport or bootsupport/modules lappend modulefolders [file join $projectdir src bootsupport/modules] - if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules"} { + if {$modulefoldername ni $mtails && $modulefoldername ni "bootsupport bootsupport/modules bootsupport/modules_tcl$majorv"} { set msg "Suplied modulefoldername '$modulefoldername' doesn't appear to be a known module folder within the project at $projectdir\n" append msg "Known module folders: [lsort $mtails]\n" append msg "Use a name from the above list, or a fully qualified path\n" diff --git a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm index 7382c688..f4dfc714 100644 --- a/src/modules/punk/mix/commandset/module-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/module-999999.0a1.0.tm @@ -159,7 +159,7 @@ namespace eval punk::mix::commandset::module { #set opts [dict merge $defaults $args] #todo - review compatibility between -template and -type - #-type is the wrapping technology e.g 'plain' for none or tarjar/zipkit etc (consider also snappy/snappy-tcl) + #-type is the wrapping technology e.g 'plain' for none or tarjar or zip (modpod) etc (consider also snappy/snappy-tcl) #-template may be a folder - but only if the selected -type suports it @@ -293,6 +293,7 @@ namespace eval punk::mix::commandset::module { } # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- set opt_quiet [dict get $opts -quiet] + set opt_force [dict get $opts -force] # -- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- --- @@ -378,13 +379,39 @@ namespace eval punk::mix::commandset::module { } set template_filedata [string map $strmap $template_filedata] - set modulefile $modulefolder/${moduletail}-$infile_version.tm - if {[file exists $modulefile]} { - set errmsg "module.new error: module file $modulefile already exists - aborting" - if {[string match "*$magicversion*" $modulefile]} { - append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" + set tmfile $modulefolder/${moduletail}-$infile_version.tm + set podfile $modulefolder/#modpod-$moduletail-$infile_version/$moduletail-$infile_version.tm + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + if {$has_tm && $has_pos} { + #invalid configuration - bomb out + error "module.new error: Invalid target configuration found. module folder has both a .tm file $tmfile and a modpod file $podfile. Please delete one of them before trying again." + } + if {$opt_type eq "plain"} { + set modulefile $tmfile + } else { + set modulefile $podfile + } + if {$has_tm || $has_pod} { + if {!$opt_force} { + if {$has_tm} { + set errmsg "module.new error: module file $tmfile already exists - aborting" + } else { + set errmsg "module.new error: module file $podfile already exists - aborting" + } + if {[string match "*$magicversion*" $tmfile]} { + append errmsg \n "If you are attempting to create a module file with a specific version in the source-file name - you will need to use a template that doesn't contain the string '$magicversion' e.g the provided template moduleexactversion-0.0.1.tm" + } + error $errmsg + } else { + #review - prompt here vs caller? + #we are committed to overwriting/replacing if there was a pre-existing module of same version + if {$has_pod} { + file delete -force [file dirname $podfile] + } elseif {$has_tm} { + file delete -force $tmfile + } } - error $errmsg } @@ -407,13 +434,20 @@ namespace eval punk::mix::commandset::module { } } - set existing_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] + set existing_tm_versions [glob -nocomplain -dir $modulefolder -tails ${moduletail}-*.tm] #it shouldn't be possible to overmatch with the glob - because '-' is not valid in a Tcl module name + set existing_pod_versions [glob -nocomplain -dir $modulefolder -tails #modpod-$moduletail-*] + set existing_versions [concat $existing_tm_versions $existing_pod_versions] + if {[llength $existing_versions]} { set name_version_pairs [list] lappend name_version_pairs [list $moduletail $infile_version] foreach existing $existing_versions { - lappend name_version_pairs [punk::mix::cli::lib::split_modulename_version $existing] ;# .tm is stripped and ignored + lassign [punk::mix::cli::lib::split_modulename_version $existing] namepart version ;# .tm is stripped and ignored + if {[string match #modpod-* $namepart]} { + set namepart [string range $namepart 8 end] + } + lappend name_version_pairs [list $namepart $version] } set name_version_pairs [lsort -command {package vcompare} -index 1 $name_version_pairs] ;#while plain lsort will often work with versions - it can get order wrong with some - so use package vcompare if {[lindex $name_version_pairs end] ne [list $moduletail $infile_version]} { @@ -436,6 +470,8 @@ namespace eval punk::mix::commandset::module { if {!$opt_quiet} { puts stdout "Creating $modulefile from template $moduletemplate" } + file mkdir [file dirname $modulefile] + set fd [open $modulefile w] fconfigure $fd -translation binary puts -nonewline $fd $template_filedata diff --git a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm index 430149cc..d119126d 100644 --- a/src/modules/punk/mix/commandset/project-999999.0a1.0.tm +++ b/src/modules/punk/mix/commandset/project-999999.0a1.0.tm @@ -320,6 +320,8 @@ namespace eval punk::mix::commandset::project { puts stderr "-force 1 or -update 1 not specified - aborting" return } + #review + set fossil_repo_file $repodb_folder/$projectname.fossil } if {$fossil_repo_file eq ""} { @@ -415,12 +417,30 @@ namespace eval punk::mix::commandset::project { if {[file exists $projectdir/src/modules]} { foreach m $opt_modules { - if {![file exists $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm]} { + #check if mod-ver.tm file or #modpod-mod-ver folder exist + set tmfile $projectdir/src/modules/$m-[punk::mix::util::magic_tm_version].tm + set podfile $projectdir/src/modules/#modpod-$m-[punk::mix::util::magic_tm_version]/$m-[punk::mix::util::magic_tm_version].tm + + set has_tm [file exists $tmfile] + set has_pod [file exists $podfile] + #puts stderr "=====> has_tm: $has_tm has_pod: $has_pod" + if {!$has_tm && !$has_pod} { #todo - option for -module_template - and check existence at top? or change opt_modules to be a list of dicts with configuration info -template -type etc - punk::mix::commandset::module::new $m -project $projectname -type $opt_type + punk::mix::commandset::module::new -project $projectname -type $opt_type $m } else { + #we should rarely if ever want to force any src/modules to be overwritten if {$opt_force} { - punk::mix::commandset::module::new $m -project $projectname -type $opt_type -force 1 + if {$has_pod} { + set answer [util::askuser "OVERWRITE the src/modules file $podfile ?? (generally not desirable) Y|N"] + set overwrite_type zip + } else { + set answer [util::askuser "OVERWRITE the src/modules file $tmfile ?? (generally not desirable) Y|N"] + set overwrite_type $opt_type + } + if {[string tolower $answer] eq "y"} { + #REVIEW - all pods zip - for now + punk::mix::commandset::module::new -project $projectname -type $overwrite_type -force 1 $m + } } } } diff --git a/src/modules/punk/mix/templates/layouts/project/src/make.tcl b/src/modules/punk/mix/templates/layouts/project/src/make.tcl index c53315e9..20b0c29f 100644 --- a/src/modules/punk/mix/templates/layouts/project/src/make.tcl +++ b/src/modules/punk/mix/templates/layouts/project/src/make.tcl @@ -13,7 +13,7 @@ namespace eval ::punkmake { variable pkg_requirements [list]; variable pkg_missing [list];variable pkg_loaded [list] variable non_help_flags [list -k] variable help_flags [list -help --help /?] - variable known_commands [list project get-project-info shell bootsupport] + variable known_commands [list project get-project-info shell vendor bootsupport] } if {"::try" ni [info commands ::try]} { puts stderr "Tcl interpreter possibly too old - 'try' command not found - aborting" @@ -134,6 +134,8 @@ proc punkmake_gethelp {args} { append h " - the optional -k flag will terminate processes running as the executable being built (if applicable)" \n \n append h " $scriptname bootsupport" \n append h " - update the src/bootsupport modules as well as the mixtemplates/layouts//src/bootsupport modules if the folder exists" \n \n + append h " $scriptname vendor" \n + append h " - update the src/vendormodules based on src/vendormodules/include_modules.config" \n \n append h " $scriptname get-project-info" \n append h " - show the name and base folder of the project to be built" \n append h "" \n @@ -251,6 +253,100 @@ if {$::punkmake::command eq "shell"} { exit 1 } +if {$::punkmake::command eq "vendor"} { + puts "projectroot: $projectroot" + puts "script: [info script]" + #puts "-- [tcl::tm::list] --" + puts stdout "Updating vendor modules" + proc vendor_localupdate {projectroot} { + set local_modules [list] + set git_modules [list] + set fossil_modules [list] + #todo vendor/lib ? + set vendor_config $projectroot/src/vendormodules/include_modules.config + if {[file exists $vendor_config]} { + set targetroot $projectroot/src/vendormodules/modules + source $vendor_config ;#populate $local_modules $git_modules $fossil_modules with project-specific list + if {![llength $local_modules]} { + puts stderr "No local vendor modules configured for updating (config file: $vendor_config)" + } else { + if {[catch { + #---------- + set vendor_installer [punkcheck::installtrack new make.tcl $projectroot/src/vendormodules/.punkcheck] + $vendor_installer set_source_target $projectroot $projectroot/src/vendormodules + set installation_event [$vendor_installer start_event {-make_step vendor}] + #---------- + } errM]} { + puts stderr "Unable to use punkcheck for vendor update. Error: $errM" + set installation_event "" + } + foreach {relpath module} $local_modules { + set module [string trim $module :] + set module_subpath [string map {:: /} [namespace qualifiers $module]] + set srclocation [file join $projectroot $relpath $module_subpath] + #puts stdout "$relpath $module $module_subpath $srclocation" + set pkgmatches [glob -nocomplain -dir $srclocation -tail [namespace tail $module]-*] + #lsort won't sort version numbers properly e.g with -dictionary 0.1.1 comes before 0.1 + if {![llength $pkgmatches]} { + puts stderr "Missing source for vendor module $module - not found in $srclocation" + continue + } + set latestfile [lindex $pkgmatches 0] + set latestver [lindex [split [file rootname $latestfile] -] 1] + foreach m $pkgmatches { + lassign [split [file rootname $m] -] _pkg ver + #puts "comparing $ver vs $latestver" + if {[package vcompare $ver $latestver] == 1} { + set latestver $ver + set latestfile $m + } + } + set srcfile [file join $srclocation $latestfile] + set tgtfile [file join $targetroot $module_subpath $latestfile] + if {$installation_event ne ""} { + #---------- + $installation_event targetset_init INSTALL $tgtfile + $installation_event targetset_addsource $srcfile + #---------- + if {\ + [llength [dict get [$installation_event targetset_source_changes] changed]]\ + || [llength [$installation_event get_targets_exist]] < [llength [$installation_event get_targets]]\ + } { + file mkdir [file dirname $tgtfile] ;#ensure containing folder for target exists + $installation_event targetset_started + # -- --- --- --- --- --- + puts "VENDOR update: $srcfile -> $tgtfile" + if {[catch { + file copy -force $srcfile $tgtfile + } errM]} { + $installation_event targetset_end FAILED + } else { + $installation_event targetset_end OK + } + # -- --- --- --- --- --- + } else { + puts -nonewline stderr "." + $installation_event targetset_end SKIPPED + } + $installation_event end + } else { + file copy -force $srcfile $tgtfile + } + } + + } + } else { + puts stderr "No config at $vendor_config - nothing configured to update" + } + } + + + puts stdout " vendor package update done " + flush stderr + flush stdout + ::exit 0 +} + if {$::punkmake::command eq "bootsupport"} { puts "projectroot: $projectroot" puts "script: [info script]" @@ -275,7 +371,7 @@ if {$::punkmake::command eq "bootsupport"} { set boot_event [$boot_installer start_event {-make_step bootsupport}] #---------- } errM]} { - puts stderr "Unable to use punkcheck for bootsupport error: $errM" + puts stderr "Unable to use punkcheck for bootsupport. Error: $errM" set boot_event "" } @@ -441,7 +537,7 @@ if {[file exists $sourcefolder/vendorlib]} { if {[file exists $sourcefolder/vendormodules]} { #install .tm *and other files* puts stdout "VENDORMODULES: copying from $sourcefolder/vendormodules to $target_modules_base (if source file changed)" - set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md}] + set resultdict [punkcheck::install $sourcefolder/vendormodules $target_modules_base -installer make.tcl -overwrite installedsourcechanged-targets -antiglob_paths {README.md include_modules.config}] puts stdout [punkcheck::summarize_install_resultdict $resultdict] } else { puts stderr "VENDORMODULES: No src/vendormodules folder found." diff --git a/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl b/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl new file mode 100644 index 00000000..9487b6e6 --- /dev/null +++ b/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/modpod-loadscript.tcl @@ -0,0 +1,53 @@ +apply {code { + set scriptpath [file normalize [info script]] + if {[string match "#modpod-loadscript*.tcl" [file tail $scriptpath]]} { + #jump up an extra dir level if we are within a #modpod-loadscript file. + set mypath [file dirname [file dirname $scriptpath]] + #expect to be in folder #modpod-- + #Now we need to test if we are in a mounted folder vs an extracted folder + set container [file dirname $mypath] + if {[string match "#mounted-modpod-*" $container]} { + set mypath [file dirname $container] + } + set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #modpod-- + } else { + set mypath [file dirname $scriptpath] + set modver [file root [file tail [info script]]] + } + set mysegs [file split $mypath] + set overhang [list] + foreach libpath [tcl::tm::list] { + set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & / + if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} { + #mypath is below libpath + set overhang [lrange $mysegs [llength $libsegs]+1 end] + break + } + } + lassign [split $modver -] moduletail version + set ns [join [concat $overhang $moduletail] ::] + #if {![catch {package require modpod}]} { + # ::modpod::disconnect [info script] + #} + package provide $ns $version + namespace eval $ns $code +} ::} { + # + # Module procs here, where current namespace is that of the module. + # Package version can, if needed, be accessed as [uplevel 1 {set version}] + # Last element of module name: [uplevel 1 {set moduletail}] + # Full module name: [uplevel 1 {set ns}] + + # + # + # + + # + # + # + + # + # + # + +} diff --git a/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z b/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z new file mode 100644 index 00000000..a8f7b05a --- /dev/null +++ b/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/modpod-module-version/z @@ -0,0 +1,2 @@ +#Do not remove the trailing ctrl-z character from this file + \ No newline at end of file diff --git a/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip b/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip new file mode 100644 index 00000000..665234de Binary files /dev/null and b/src/modules/punk/mix/templates/modpod/template_modpod-0.0.1/test.zip differ diff --git a/src/modules/punk/path-999999.0a1.0.tm b/src/modules/punk/path-999999.0a1.0.tm index f2f52f56..4cb4fc69 100644 --- a/src/modules/punk/path-999999.0a1.0.tm +++ b/src/modules/punk/path-999999.0a1.0.tm @@ -217,7 +217,8 @@ namespace eval punk::path { -directory -default "\uFFFF" -call-depth-internal -default 0 -type integer -antiglob_paths -default {} - *values -min 0 -max -1 -type string + *values -min 0 -max -1 -optional 1 -type string + tailglobs -multiple 1 } $args] lassign [dict values $argd] opts values set tailglobs [dict values $values] diff --git a/src/modules/punk/repl-0.1.tm b/src/modules/punk/repl-0.1.tm index 98d0058a..ff034510 100644 --- a/src/modules/punk/repl-0.1.tm +++ b/src/modules/punk/repl-0.1.tm @@ -685,7 +685,7 @@ proc repl::rputs {args} { set last_char_info_width 60 #review - string shouldn't be truncated prior to stripcodes - could chop ansi codes! #set summary "[::shellfilter::ansi::stripcodes [string range $out 0 $last_char_info_width]]" - set out_plain_text [punk::ansi::stripansi $out] + set out_plain_text [punk::ansi::ansistrip $out] set summary [string range $out_plain_text 0 $last_char_info_width] if {[string length $summary] > $last_char_info_width} { append summary " ..." @@ -842,7 +842,7 @@ namespace eval punk::repl::class { #append combined \n append new0 \n } - set underlay [punk::ansi::stripansi $activeline] + set underlay [punk::ansi::ansistrip $activeline] set line_nextchar_col [expr {[punk::char::string_width $underlay] + 1}] if {$o_cursor_col > $line_nextchar_col} { set o_cursor_col $line_nextchar_col @@ -1103,7 +1103,7 @@ namespace eval punk::repl::class { set suffix [string repeat " " [expr {$linecols -$col1}]] #capitalised INDEX - for grapheme/control-char index e.g a with diacritic a\u0300 has a single index set char_at_cursor [ansistring INDEX $cursorline $charindex_at_cursor] ;#this is the char with appropriate ansireset codes - set rawchar [punk::ansi::stripansi $char_at_cursor] + set rawchar [punk::ansi::ansistrip $char_at_cursor] if {$rawchar eq " "} { set charhighlight "[punk::ansi::a+ White]_[a]" } else { @@ -1865,7 +1865,7 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config } if {[string match "\x1b*" $line]} { rputs stderr "${debugprompt}esc - '[punk::ansi::ansistring::VIEW $line]'" - #set commandstr [punk::ansi::stripansi $commandstr] + #set commandstr [punk::ansi::ansistrip $commandstr] } } @@ -2069,8 +2069,8 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config #screen_last_char_add [string index $lastoutchar_codethread$lasterrchar_codethread end] "stdout/stderr" - #set lastoutchar [string index [punk::ansi::stripansi $::repl::output_stdout] end] - #set lasterrchar [string index [punk::ansi::stripansi $::repl::output_stderr] end] + #set lastoutchar [string index [punk::ansi::ansistrip $::repl::output_stdout] end] + #set lasterrchar [string index [punk::ansi::ansistrip $::repl::output_stderr] end] #to determine whether cursor is back at col0 of newline #screen_last_char_add [string index $lastoutchar$lasterrchar end] "stdout/stderr" diff --git a/src/modules/punk/repl/codethread-999999.0a1.0.tm b/src/modules/punk/repl/codethread-999999.0a1.0.tm index 1c73b3a4..bfbe976c 100644 --- a/src/modules/punk/repl/codethread-999999.0a1.0.tm +++ b/src/modules/punk/repl/codethread-999999.0a1.0.tm @@ -177,8 +177,8 @@ tcl::namespace::eval punk::repl::codethread { #interp transfer code $errhandle "" #flush $errhandle - set lastoutchar [string index [punk::ansi::stripansi $output_stdout] end] - set lasterrchar [string index [punk::ansi::stripansi $output_stderr] end] + set lastoutchar [string index [punk::ansi::ansistrip $output_stdout] end] + set lasterrchar [string index [punk::ansi::ansistrip $output_stderr] end] #puts stderr "-->[ansistring VIEW -lf 1 $lastoutchar$lasterrchar]" set tid [thread::id] diff --git a/src/modules/punk/repo-999999.0a1.0.tm b/src/modules/punk/repo-999999.0a1.0.tm index dcd37719..436dcdc4 100644 --- a/src/modules/punk/repo-999999.0a1.0.tm +++ b/src/modules/punk/repo-999999.0a1.0.tm @@ -1447,6 +1447,7 @@ namespace eval punk::repo { #Must accept empty prefix - which is effectively noop. #MUCH faster version for absolute path prefix (pre-normalized) + #review - will error on file join if lrange returns empty list ie if prefix longer than path proc path_strip_alreadynormalized_prefixdepth {path prefix} { if {$prefix eq ""} { return $path @@ -1488,11 +1489,11 @@ namespace eval punk::repo { interp alias {} git_revision {} ::punk::repo::git_revision - interp alias {} gs {} git status -sb - interp alias {} gr {} ::punk::repo::git_revision - interp alias {} gl {} git log --oneline --decorate ;#decorate so stdout consistent with what we see on console - interp alias {} glast {} git log -1 HEAD --stat - interp alias {} gconf {} git config --global -l + interp alias {} gs {} shellrun::runconsole git status -sb + interp alias {} gr {} ::punk::repo::git_revision + interp alias {} gl {} shellrun::runconsole git log --oneline --decorate ;#decorate so stdout consistent with what we see on console + interp alias {} glast {} shellrun::runconsole git log -1 HEAD --stat + interp alias {} gconf {} shellrun::runconsole git config --global -l } namespace eval punk::repo::lib { diff --git a/src/modules/punk/zip-999999.0a1.0.tm b/src/modules/punk/zip-999999.0a1.0.tm new file mode 100644 index 00000000..d9573d2b --- /dev/null +++ b/src/modules/punk/zip-999999.0a1.0.tm @@ -0,0 +1,632 @@ +# -*- tcl -*- +# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt +# module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.3.tm +# +# 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) 2024 JMN +# (C) 2009 Path Thoyts +# +# @@ Meta Begin +# Application punk::zip 999999.0a1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin shellspy_module_punk::zip 0 999999.0a1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require punk::zip] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of punk::zip +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by punk::zip +#[list_begin itemized] + +package require Tcl 8.6- +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6}] +#[item] [package {punk::args}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#tcl::namespace::eval punk::zip::class { + #*** !doctools + #[subsection {Namespace punk::zip::class}] + #[para] class definitions + #if {[tcl::info::commands [tcl::namespace::current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + #} +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + #variable xyz + + #*** !doctools + #[subsection {Namespace punk::zip}] + #[para] Core API functions for punk::zip + #[list_begin definitions] + + proc Path_a_atorbelow_b {path_a path_b} { + return [expr {[StripPath $path_b $path_a] ne $path_a}] + } + proc Path_a_at_b {path_a path_b} { + return [expr {[StripPath $path_a $path_b] eq "." }] + } + + proc Path_strip_alreadynormalized_prefixdepth {path prefix} { + if {$prefix eq ""} { + return $path + } + set pathparts [file split $path] + set prefixparts [file split $prefix] + if {[llength $prefixparts] >= [llength $pathparts]} { + return "" + } + return [file join \ + {*}[lrange \ + $pathparts \ + [llength $prefixparts] \ + end]] + } + + #StripPath - borrowed from tcllib fileutil + # ::fileutil::stripPath -- + # + # If the specified path references/is a path in prefix (or prefix itself) it + # is made relative to prefix. Otherwise it is left unchanged. + # In the case of it being prefix itself the result is the string '.'. + # + # Arguments: + # prefix prefix to strip from the path. + # path path to modify + # + # Results: + # path The (possibly) modified path. + + if {[string equal $tcl_platform(platform) windows]} { + # Windows. While paths are stored with letter-case preserved al + # comparisons have to be done case-insensitive. For reference see + # SF Tcllib Bug 2499641. + + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal -nocase $prefix $npath]} { + return "." + } + + if {[string match -nocase "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } else { + proc StripPath {prefix path} { + # [file split] is used to generate a canonical form for both + # paths, for easy comparison, and also one which is easy to modify + # using list commands. + + set prefix [file split $prefix] + set npath [file split $path] + + if {[string equal $prefix $npath]} { + return "." + } + + if {[string match "${prefix} *" $npath]} { + set path [eval [linsert [lrange $npath [llength $prefix] end] 0 file join ]] + } + return $path + } + } + + proc Timet_to_dos {time_t} { + #*** !doctools + #[call] [fun Timet_to_dos] [arg time_t] + #[para] convert a unix timestamp into a DOS timestamp for ZIP times. + #[example { + # DOS timestamps are 32 bits split into bit regions as follows: + # 24 16 8 0 + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + # |Y|Y|Y|Y|Y|Y|Y|m| |m|m|m|d|d|d|d|d| |h|h|h|h|h|m|m|m| |m|m|m|s|s|s|s|s| + # +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ +-+-+-+-+-+-+-+-+ + #}] + set s [clock format $time_t -format {%Y %m %e %k %M %S}] + scan $s {%d %d %d %d %d %d} year month day hour min sec + expr {(($year-1980) << 25) | ($month << 21) | ($day << 16) + | ($hour << 11) | ($min << 5) | ($sec >> 1)} + } + + proc walk {args} { + #*** !doctools + #[call] [fun walk] [arg ?options?] [arg base] + #[para] Walk a directory tree rooted at base + #[para] the -excludes list can be a set of glob expressions to match against files and avoid + #[para] e.g + #[example { + # punk::zip::walk -exclude {CVS/* *~.#*} library + #}] + + set argd [punk::args::get_dict { + *proc -name punk::zip::walk + -excludes -default "" -help "list of glob expressions to match against files and exclude" + -subpath -default "" + *values -min 1 -max -1 + base + fileglobs -default {*} -multiple 1 + } $args] + set base [dict get $argd values base] + set fileglobs [dict get $argd values fileglobs] + set subpath [dict get $argd opts -subpath] + set excludes [dict get $argd opts -excludes] + + + set imatch [list] + foreach fg $fileglobs { + lappend imatch [file join $subpath $fg] + } + + set result {} + #set imatch [file join $subpath $match] + set files [glob -nocomplain -tails -types f -directory $base -- {*}$imatch] + foreach file $files { + set excluded 0 + foreach glob $excludes { + if {[string match $glob $file]} { + set excluded 1 + break + } + } + if {!$excluded} {lappend result $file} + } + foreach dir [glob -nocomplain -tails -types d -directory $base -- [file join $subpath *]] { + set subdir [walk -subpath $dir -excludes $excludes $base {*}$fileglobs] + if {[llength $subdir]>0} { + set result [concat $result $dir $subdir] + } + } + return $result + } + + # Mkzipfile -- + # + # FIX ME: should handle the current offset for non-seekable channels + # + proc Mkzipfile {zipchan base path {comment ""}} { + #*** !doctools + #[call] [fun Mkzipfile] [arg zipchan] [arg base] [arg path] [arg ?comment?] + #[para] Add a single file to a zip archive + #[para] The zipchan channel should already be open and binary. + #[para] You can provide a -comment for the file. + #[para] The return value is the central directory record that will need to be used when finalizing the zip archive. + + set fullpath [file join $base $path] + set mtime [Timet_to_dos [file mtime $fullpath]] + set utfpath [encoding convertto utf-8 $path] + set utfcomment [encoding convertto utf-8 $comment] + set flags [expr {(1<<11)}] ;# utf-8 comment and path + set method 0 ;# store 0, deflate 8 + set attr 0 ;# text or binary (default binary) + set version 20 ;# minumum version req'd to extract + set extra "" + set crc 0 + set size 0 + set csize 0 + set data "" + set seekable [expr {[tell $zipchan] != -1}] + if {[file isdirectory $fullpath]} { + set attrex 0x41ff0010 ;# 0o040777 (drwxrwxrwx) + #set attrex 0x40000010 + } elseif {[file executable $fullpath]} { + set attrex 0x81ff0080 ;# 0o100777 (-rwxrwxrwx) + } else { + set attrex 0x81b60020 ;# 0o100666 (-rw-rw-rw-) + if {[file extension $fullpath] in {".tcl" ".txt" ".c"}} { + set attr 1 ;# text + } + } + + if {[file isfile $fullpath]} { + set size [file size $fullpath] + if {!$seekable} {set flags [expr {$flags | (1 << 3)}]} + } + + + set offset [tell $zipchan] + set local [binary format a4sssiiiiss PK\03\04 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]] + append local $utfpath $extra + puts -nonewline $zipchan $local + + if {[file isfile $fullpath]} { + # If the file is under 2MB then zip in one chunk, otherwize we use + # streaming to avoid requiring excess memory. This helps to prevent + # storing re-compressed data that may be larger than the source when + # handling PNG or JPEG or nested ZIP files. + if {$size < 0x00200000} { + set fin [open $fullpath rb] + set data [read $fin] + set crc [zlib crc32 $data] + set cdata [zlib deflate $data] + if {[string length $cdata] < $size} { + set method 8 + set data $cdata + } + close $fin + set csize [string length $data] + puts -nonewline $zipchan $data + } else { + set method 8 + set fin [open $fullpath rb] + set zlib [zlib stream deflate] + while {![eof $fin]} { + set data [read $fin 4096] + set crc [zlib crc32 $data $crc] + $zlib put $data + if {[string length [set zdata [$zlib get]]]} { + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + } + } + close $fin + $zlib finalize + set zdata [$zlib get] + incr csize [string length $zdata] + puts -nonewline $zipchan $zdata + $zlib close + } + + if {$seekable} { + # update the header if the output is seekable + set local [binary format a4sssiiii PK\03\04 \ + $version $flags $method $mtime $crc $csize $size] + set current [tell $zipchan] + seek $zipchan $offset + puts -nonewline $zipchan $local + seek $zipchan $current + } else { + # Write a data descriptor record + set ddesc [binary format a4iii PK\7\8 $crc $csize $size] + puts -nonewline $zipchan $ddesc + } + } + + #PK\x01\x02 Cdentral directory file header + #set v1 0x0317 ;#upper byte 03 -> UNIX lower byte 23 -> 2.3 + set v1 0x0017 ;#upper byte 00 -> MS_DOS and OS/2 (FAT/VFAT/FAT32 file systems) + + set hdr [binary format a4ssssiiiisssssii PK\01\02 $v1 \ + $version $flags $method $mtime $crc $csize $size \ + [string length $utfpath] [string length $extra]\ + [string length $utfcomment] 0 $attr $attrex $offset] + append hdr $utfpath $extra $utfcomment + return $hdr + } + # zip::mkzip -- + # + # eg: zip my.zip -directory Subdir -runtime unzipsfx.exe *.txt + # + proc mkzip {args} { + #*** !doctools + #[call] [fun mkzip] [arg ?options?] [arg filename] + #[para] Create a zip archive in 'filename' + #[para] If a file already exists, an error will be raised. + set argd [punk::args::get_dict { + *proc -name punk::zip::mkzip -help "Create a zip archive in 'filename'" + *opts + -return -default "pretty" -choices {pretty list none} -help "mkzip can return a list of the files and folders added to the archive + the option -return pretty is the default and uses the punk::lib pdict/plist system + to return a formatted list for the terminal + " + -zipkit -default 0 -type none -help "" + -runtime -default "" -help "specify a prefix file + e.g punk::zip::mkzip -runtime unzipsfx.exe -directory subdir output.zip + will create a self-extracting zip archive from the subdir/ folder. + " + -comment -default "" -help "An optional comment for the archive" + -directory -default "" -help "The new zip archive will scan for contents within this folder or current directory if not provided" + -base -default "" -help "The new zip archive will be rooted in this directory if provided + it must be a parent of -directory" + -exclude -default {CVS/* */CVS/* *~ ".#*" "*/.#*"} + *values -min 1 -max -1 + filename -default "" -help "name of zipfile to create" + globs -default {*} -multiple 1 -help "list of glob patterns to match. + Only directories with matching files will be included in the archive" + } $args] + + set filename [dict get $argd values filename] + if {$filename eq ""} { + error "mkzip filename cannot be empty string" + } + if {[regexp {[?*]} $filename]} { + #catch a likely error where filename is omitted and first glob pattern is misinterpreted as zipfile name + error "mkzip filename should not contain glob characters ? *" + } + if {[file exists $filename]} { + error "mkzip filename:$filename already exists" + } + dict for {k v} [dict get $argd opts] { + switch -- $k { + -comment { + dict set argd opts $k [encoding convertto utf-8 $v] + } + -directory - -base { + dict set argd opts $k [file normalize $v] + } + } + } + + array set opts [dict get $argd opts] + + + if {$opts(-directory) ne ""} { + if {$opts(-base) ne ""} { + #-base and -directory have been normalized already + if {![Path_a_atorbelow_b $opts(-directory) $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above -directory $opts(-directory)" + } + set base $opts(-base) + set relpath [Path_strip_alreadynormalized_prefixdepth $opts(-directory) $opts(-base)] + } else { + set base $opts(-directory) + set relpath "" + } + set paths [walk -exclude $opts(-exclude) -subpath $relpath -- $base {*}[dict get $argd values globs]] + + set norm_filename [file normalize $filename] + set norm_dir [file normalize $opts(-directory)] ;#we only care if filename below -directory (which is where we start scanning) + if {[Path_a_atorbelow_b $norm_filename $norm_dir]} { + #check that we aren't adding the zipfile to itself + #REVIEW - now that we open zipfile after scanning - this isn't really a concern! + #keep for now in case we can add an -update or a -force facility (or in case we modify to add to zip as we scan for members?) + #In the case of -force - we may want to delay replacement of original until scan is done? + + #try to avoid looping on all paths and performing (somewhat) expensive file normalizations on each + #1st step is to check the patterns and see if our zipfile is already excluded - in which case we need not check the paths + set self_globs_match 0 + foreach g [dict get $argd values globs] { + if {[string match $g [file tail $filename]]} { + set self_globs_match 1 + break + } + } + if {$self_globs_match} { + #still dangerous + set self_excluded 0 + foreach e $opts(-exclude) { + if {[string match $e [file tail $filename]]} { + set self_excluded 1 + break + } + } + if {!$self_excluded} { + #still dangerous - likely to be in resultset - check each path + #puts stderr "zip file $filename is below directory $opts(-directory)" + set self_is_matched 0 + set i 0 + foreach p $paths { + set norm_p [file normalize [file join $opts(-directory) $p]] + if {[Path_a_at_b $norm_filename $norm_p]} { + set self_is_matched 1 + break + } + incr i + } + if {$self_is_matched} { + puts stderr "WARNING - zipfile being created '$filename' was matched. Excluding this file. Relocate the zip, or use -exclude patterns to avoid this message" + set paths [lremove $paths $i] + } + } + } + } + } else { + set paths [list] + set dir [pwd] + if {$opts(-base) ne ""} { + if {![Path_a_atorbelow_b $dir $opts(-base)]} { + error "punk::zip::mkzip -base $opts(-base) must be above current directory" + } + set relpath [Path_strip_alreadynormalized_prefixdepth [file normalize $dir] [file normalize $opts(-base)]] + } else { + set relpath "" + } + set base $opts(-base) + + set matches [glob -nocomplain -type f -- {*}[dict get $argd values globs]] + foreach m $matches { + if {$m eq $filename} { + #puts stderr "--> excluding $filename" + continue + } + set isok 1 + foreach e [concat $opts(-exclude) $filename] { + if {[string match $e $m]} { + set isok 0 + break + } + } + if {$isok} { + lappend paths [file join $relpath $m] + } + } + } + + if {![llength $paths]} { + return "" + } + + set zf [open $filename wb] + if {$opts(-runtime) ne ""} { + set rt [open $opts(-runtime) rb] + fcopy $rt $zf + close $rt + } elseif {$opts(-zipkit)} { + set zkd "#!/usr/bin/env tclkit\n\# This is a zip-based Tcl Module\n" + append zkd "package require vfs::zip\n" + append zkd "vfs::zip::Mount \[info script\] \[info script\]\n" + append zkd "if {\[file exists \[file join \[info script\] main.tcl\]\]} {\n" + append zkd " source \[file join \[info script\] main.tcl\]\n" + append zkd "}\n" + append zkd \x1A + puts -nonewline $zf $zkd + } + set count 0 + set cd "" + + set members [list] + foreach path $paths { + #puts $path + lappend members $path + append cd [Mkzipfile $zf $base $path] ;#path already includes relpath + incr count + } + set cdoffset [tell $zf] + set endrec [binary format a4ssssiis PK\05\06 0 0 \ + $count $count [string length $cd] $cdoffset\ + [string length $opts(-comment)]] + append endrec $opts(-comment) + puts -nonewline $zf $cd + puts -nonewline $zf $endrec + close $zf + + set result "" + switch -exact -- $opts(-return) { + list { + set result $members + } + pretty { + if {[info commands showlist] ne ""} { + set result [plist -channel none members] + } else { + set result $members + } + } + none { + set result "" + } + } + return $result + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +tcl::namespace::eval punk::zip::lib { + tcl::namespace::export {[a-z]*} ;# Convention: export all lowercase + tcl::namespace::path [tcl::namespace::parent] + #*** !doctools + #[subsection {Namespace punk::zip::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace punk::zip::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +#tcl::namespace::eval punk::zip::system { + #*** !doctools + #[subsection {Namespace punk::zip::system}] + #[para] Internal functions that are not part of the API + + + +#} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide punk::zip [tcl::namespace::eval punk::zip { + variable pkg punk::zip + variable version + set version 999999.0a1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/modules/punk/zip-buildversion.txt b/src/modules/punk/zip-buildversion.txt new file mode 100644 index 00000000..f47d01c8 --- /dev/null +++ b/src/modules/punk/zip-buildversion.txt @@ -0,0 +1,3 @@ +0.1.0 +#First line must be a semantic version number +#all other lines are ignored. diff --git a/src/modules/punkcheck-0.1.0.tm b/src/modules/punkcheck-0.1.0.tm index 56d42b23..5d4f5c27 100644 --- a/src/modules/punkcheck-0.1.0.tm +++ b/src/modules/punkcheck-0.1.0.tm @@ -37,7 +37,7 @@ namespace eval punkcheck { start_installer_event installfile_* #antiglob_dir & antiglob_file entries match the pattern at any level - should not contain path separators - variable default_antiglob_dir_core [list "#*" "_aside" ".git" ".fossil*"] + variable default_antiglob_dir_core [list "#*" "_aside" "_build" ".git" ".fossil*"] variable default_antiglob_file_core "" proc uuid {} { set has_twapi 0 @@ -1196,7 +1196,7 @@ namespace eval punkcheck { #and may be less error prone than doing slightly more opaue path manipulations at each recursion level to determine where we started #For consistency - we'll use the same mechanism in various recursive directory walking procedures such as this one. set CALLDEPTH [dict get $opts -call-depth-internal] ;#added for extra debug/sanity checking - clearer test for initial function call ie CALLDPEPTH = 0 - set max_depth [dict get $opts -max_depth] + set max_depth [dict get $opts -max_depth] ;# -1 for no limit set subdirlist [dict get $opts -subdirlist] ;# generally should be same length as CALLDEPTH - but user could prefill set fileglob [dict get $opts -glob] set createdir [dict get $opts -createdir] ;#defaults to zero to help avoid mistakes with initial target dir - required target subdirs are created regardless of this setting @@ -1598,7 +1598,7 @@ namespace eval punkcheck { } - if {$CALLDEPTH >= $max_depth} { + if {$max_depth != -1 && $CALLDEPTH >= $max_depth} { #don't process any more subdirs set subdirs [list] } else { diff --git a/src/modules/shellfilter-0.1.9.tm b/src/modules/shellfilter-0.1.9.tm index 861b66ff..e1983653 100644 --- a/src/modules/shellfilter-0.1.9.tm +++ b/src/modules/shellfilter-0.1.9.tm @@ -135,8 +135,9 @@ namespace eval shellfilter::pipe { namespace eval shellfilter::ansi { #maint warning - - #stripansi from punk::ansi is better/more comprehensive + #ansistrip from punk::ansi is better/more comprehensive proc stripcodes {text} { + #obsolete? #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic @@ -522,7 +523,7 @@ namespace eval shellfilter::chan { #review - we should probably provide a more narrow filter than only strips color - and one that strips most(?) # - but does it ever really make sense to strip things like "esc(0" and "esc(B" which flip to the G0 G1 characters? (once stripped - things like box-lines become ordinary letters - unlikely to be desired?) - #punk::ansi::stripansi converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion + #punk::ansi::ansistrip converts at least some of the box drawing G0 chars to unicode - todo - more complete conversion #assumes line-buffering. a more advanced filter required if ansicodes can arrive split across separate read or write operations! oo::class create ansistrip { variable o_trecord @@ -554,7 +555,7 @@ namespace eval shellfilter::chan { } method read {transform_handle bytes} { set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::stripansi $instring] + set outstring [punk::ansi::ansistrip $instring] return [encoding convertto $o_enc $outstring] } method flush {transform_handle} { @@ -562,7 +563,7 @@ namespace eval shellfilter::chan { } method write {transform_handle bytes} { set instring [encoding convertfrom $o_enc $bytes] - set outstring [punk::ansi::stripansi $instring] + set outstring [punk::ansi::ansistrip $instring] return [encoding convertto $o_enc $outstring] } method meta_is_redirection {} { diff --git a/src/modules/shellrun-0.1.1.tm b/src/modules/shellrun-0.1.1.tm index 3cfdcd39..ace56e9c 100644 --- a/src/modules/shellrun-0.1.1.tm +++ b/src/modules/shellrun-0.1.1.tm @@ -178,6 +178,41 @@ namespace eval shellrun { return $exitinfo } + #run in the way tcl unknown does - but without regard to auto_noexec + proc runconsole {args} { + if {![llength $args]} { + error "no commandline specified" + return + } + set name [lindex $args 0] + set new [auto_execok $name] + set repl_runid [punk::get_repl_runid] + #set ::punk::last_run_display [list] + + set redir ">&@stdout <@stdin" + uplevel 1 [list ::catch [concat exec $redir $new [lrange $args 1 end]] ::tcl::UnknownResult ::tcl::UnknownOptions] + #we can't detect stdout/stderr output from the exec + #for now emit an extra \n on stderr + #todo - there is probably no way around this but to somehow exec in the context of a completely separate console + #This is probably a tricky problem - especially to do cross-platform + # + # - use [dict get $::tcl::UnknownOptions -code] (0|1) exit + if {[dict get $::tcl::UnknownOptions -code] == 0} { + set c green + set m "ok" + } else { + set c yellow + set m "errorCode $::errorCode" + } + set chunklist [list] + lappend chunklist [list "info" "[a $c]$m[a] " ] + if {$repl_runid != 0} { + tsv::lappend repl runchunks-$repl_runid {*}$chunklist + } + + dict incr ::tcl::UnknownOptions -level + return -options $::tcl::UnknownOptions $::tcl::UnknownResult + } proc runout {args} { #set_last_run_display [list] variable runout @@ -720,6 +755,7 @@ namespace eval shellrun { interp alias {} runx {} shellrun::runx interp alias {} sh_runx {} shellrun::sh_runx + interp alias {} runc {} shellrun::runconsole interp alias {} runraw {} shellrun::runraw diff --git a/src/modules/textblock-999999.0a1.0.tm b/src/modules/textblock-999999.0a1.0.tm index 05ad5bc0..51240eb3 100644 --- a/src/modules/textblock-999999.0a1.0.tm +++ b/src/modules/textblock-999999.0a1.0.tm @@ -3840,21 +3840,24 @@ tcl::namespace::eval textblock { } set cat_reactive_nonmetal [list H C N O F P S Cl Se Br I] - set ansi [a+ {*}$fc web-black Web-lightgreen] + #set ansi [a+ {*}$fc web-black Web-lightgreen] + set ansi [a+ {*}$fc black Term-113] set val [list ansi $ansi cat reactive_nonmetal] foreach e $cat_reactive_nonmetal { tcl::dict::set ecat $e $val } set cat [list Li Na K Rb Cs Fr] - set ansi [a+ {*}$fc web-black Web-Khaki] + #set ansi [a+ {*}$fc web-black Web-Khaki] + set ansi [a+ {*}$fc black Term-lightgoldenrod2] set val [list ansi $ansi cat alkali_metals] foreach e $cat { tcl::dict::set ecat $e $val } set cat [list Sc Ti V Cr Mn Fe Co Ni Cu Zn Y Zr Nb Mo Tc Ru Rh Pd Ag Cd Hf Ta W Re Os Ir Pt Au Hg Rf Db Sg Bh Hs] - set ansi [a+ {*}$fc web-black Web-lightsalmon] + #set ansi [a+ {*}$fc web-black Web-lightsalmon] + set ansi [a+ {*}$fc black Term-orange1] set val [list ansi $ansi cat transition_metals] foreach e $cat { tcl::dict::set ecat $e $val @@ -3868,7 +3871,8 @@ tcl::namespace::eval textblock { } set cat [list B Si Ge As Sb Te At] - set ansi [a+ {*}$fc web-black Web-turquoise] + #set ansi [a+ {*}$fc web-black Web-turquoise] + set ansi [a+ {*}$fc black Brightcyan] set val [list ansi $ansi cat metalloids] foreach e $cat { tcl::dict::set ecat $e $val @@ -3889,7 +3893,8 @@ tcl::namespace::eval textblock { } set cat [list La Ce Pr Nd Pm Sm Eu Gd Tb Dy Ho Er Tm Yb Lu] - set ansi [a+ {*}$fc web-black Web-tan] + #set ansi [a+ {*}$fc web-black Web-tan] + set ansi [a+ {*}$fc black Term-tan] set val [list ansi $ansi cat lanthanoids] foreach e $cat { tcl::dict::set ecat $e $val @@ -3944,15 +3949,19 @@ tcl::namespace::eval textblock { $t configure \ -frametype_header light\ - -ansiborder_header [a+ {*}$fc web-white]\ - -ansibase_header [a+ {*}$fc Web-black]\ - -ansibase_body [a+ {*}$fc Web-black]\ - -ansiborder_body [a+ {*}$fc web-black]\ + -ansiborder_header [a+ {*}$fc brightwhite]\ + -ansibase_header [a+ {*}$fc Black]\ + -ansibase_body [a+ {*}$fc Black]\ + -ansiborder_body [a+ {*}$fc black]\ -frametype block + #-ansiborder_header [a+ {*}$fc web-white]\ + if {$opt_return eq "table"} { if {[dict get $opts -frame]} { - set output [textblock::frame -ansiborder [a+ {*}$fc Web-black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Web-black] Periodic Table " [$t print]] + #set output [textblock::frame -ansiborder [a+ {*}$fc Black web-cornflowerblue] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + #set output [textblock::frame -ansiborder [a+ {*}$fc Black term-deepskyblue2] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] + set output [textblock::frame -ansiborder [a+ {*}$fc Black cyan] -type heavy -title "[a+ {*}$fc Black] Periodic Table " [$t print]] } else { set output [$t print] } @@ -4260,8 +4269,8 @@ tcl::namespace::eval textblock { set textblock [textutil::tabify::untabify2 $textblock $tw] } if {[punk::ansi::ta::detect $textblock]} { - #stripansiraw slightly faster than stripansi - and won't affect width (avoid detect_g0/conversions) - set textblock [punk::ansi::stripansiraw $textblock] + #ansistripraw slightly faster than ansistrip - and won't affect width (avoid detect_g0/conversions) + set textblock [punk::ansi::ansistripraw $textblock] } if {[tcl::string::last \n $textblock] >= 0} { return [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] @@ -4277,7 +4286,7 @@ tcl::namespace::eval textblock { set tl $textblock } if {[punk::ansi::ta::detect $tl]} { - set tl [punk::ansi::stripansiraw $tl] + set tl [punk::ansi::ansistripraw $tl] } return [punk::char::ansifreestring_width $tl] } @@ -4312,9 +4321,9 @@ tcl::namespace::eval textblock { } set textblock [textutil::tabify::untabify2 $textblock $tw] } - #stripansiraw on entire block in one go rather than line by line - result should be the same - review - make tests + #ansistripraw on entire block in one go rather than line by line - result should be the same - review - make tests if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansiraw $textblock] + set textblock [punk::ansi::ansistripraw $textblock] } if {[tcl::string::last \n $textblock] >= 0} { #set width [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $textblock] {::punk::char::ansifreestring_width $v}]] @@ -4343,16 +4352,16 @@ tcl::namespace::eval textblock { } set block [textutil::tabify::untabify2 $block $tw] if {[tcl::string::last \n $block] >= 0} { - return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [stripansi $v]}]] + return [tcl::mathfunc::max {*}[lmap v [punk::lib::lines_as_list -- $block] {::punk::char::string_width [ansistrip $v]}]] } if {[catch {llength $block}]} { - return [::punk::char::string_width [stripansi $block]] + return [::punk::char::string_width [ansistrip $block]] } if {[llength $block] == 0} { #could be just a whitespace string return [tcl::string::length $block] } - return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [stripansi $v]}]] + return [tcl::mathfunc::max {*}[lmap v $block {::punk::char::string_width [ansistrip $v]}]] } #we shouldn't make textblock depend on the punk pipeline system @@ -4433,9 +4442,21 @@ tcl::namespace::eval textblock { set lines [list] + set padcharsize [punk::ansi::printing_length $padchar] + set pad_has_ansi [punk::ansi::ta::detect $padchar] if {$block eq ""} { #we need to treat as a line - return [tcl::string::repeat $padchar $width] + set repeats [expr {int(ceil($width / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + #TODO + #review - what happens when padchar has ansi, or the width would split a double-wide unicode char? + #we shouldn't be using string range if there is ansi - (overtype? ansistring range?) + #we should use overtype with suitable replacement char (space?) for chopped double-wides + if {!$pad_has_ansi} { + return [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $width-1] + } else { + set base [tcl::string::repeat " " $width] + return [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } } #review - tcl format can only pad with zeros or spaces? @@ -4475,6 +4496,7 @@ tcl::namespace::eval textblock { } set line_chunks [list] set line_len 0 + set pad_cache [dict create] ;#key on value of 'missing' - which is width of required pad foreach {pt ansi} $parts { if {$pt ne ""} { set has_nl [expr {[tcl::string::last \n $pt]>=0}] @@ -4489,12 +4511,26 @@ tcl::namespace::eval textblock { foreach pl $partlines { lappend line_chunks $pl #incr line_len [punk::char::ansifreestring_width $pl] - incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak + incr line_len [punk::char::grapheme_width_cached $pl] ;#memleak - REVIEW if {$p != $last} { #do padding set missing [expr {$width - $line_len}] if {$missing > 0} { - set pad [tcl::string::repeat $padchar $missing] + #commonly in a block - many lines will have the same pad - cache based on missing + + #padchar may be more than 1 wide - because of 2wide unicode and or multiple chars + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + dict set pad_cache $missing $pad + } switch -- $which-$opt_withinansi { r-0 { lappend line_chunks $pad @@ -4551,7 +4587,18 @@ tcl::namespace::eval textblock { #pad last line set missing [expr {$width - $line_len}] if {$missing > 0} { - set pad [tcl::string::repeat $padchar $missing] + if {[tcl::dict::exists $pad_cache $missing]} { + set pad [tcl::dict::get $pad_cache $missing] + } else { + set repeats [expr {int(ceil($missing / double($padcharsize)))}] ;#will overshoot by 1 whenever padcharsize not an exact divisor of width + if {!$pad_has_ansi} { + set pad [tcl::string::range [tcl::string::repeat $padchar $repeats] 0 $missing-1] + } else { + set base [tcl::string::repeat " " $missing] + set pad [overtype::block -blockalign left -overflow 0 $base [tcl::string::repeat $padchar $repeats]] + } + } + #set pad [tcl::string::repeat $padchar $missing] switch -- $which-$opt_withinansi { r-0 { lappend line_chunks $pad @@ -7156,7 +7203,7 @@ tcl::namespace::eval textblock { #return [list $b1 $b2 $result] return [ansistring VIEW $result] } - tcl::namespace::import ::punk::ansi::stripansi + tcl::namespace::import ::punk::ansi::ansistrip } diff --git a/src/punk86.vfs/boot.tcl b/src/punk86.vfs/boot.tcl new file mode 100644 index 00000000..7e22b443 --- /dev/null +++ b/src/punk86.vfs/boot.tcl @@ -0,0 +1,130 @@ +proc tclInit {} { + rename tclInit {} + + global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding + + # find the file to mount. + set noe $::tcl::kitpath + # resolve symlinks + set noe [file dirname [file normalize [file join $noe __dummy__]]] + set tcl_library [file join $noe lib tcl$tcl_version] + set tcl_libPath [list $tcl_library [file join $noe lib]] + + # get rid of a build residue + unset -nocomplain ::tclDefaultLibrary + + # The following code only gets executed if we don't have our exe + # already mounted. This should only happen once per thread. + # We could use [vfs::filesystem info], but that would require + # loading vfs into every interp. + if {![file isdirectory $noe]} { + load {} vfs + + # lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl} + if {[llength [info command mk::file]]} { + set driver mk4 + + # must use raw Metakit calls because VFS is not yet in place + set d [mk::select exe.dirs parent 0 name lib] + set d [mk::select exe.dirs parent $d -glob name vfs1*] + + foreach x {vfsUtils vfslib mk4vfs} { + set n [mk::select exe.dirs!$d.files name $x.tcl] + if {[llength $n] != 1} { error "$x: cannot find startup script"} + + set s [mk::get exe.dirs!$d.files!$n contents] + catch {set s [zlib decompress $s]} + uplevel #0 $s + } + + # use on-the-fly decompression, if mk4vfs understands that + # Note: 8.6 core zlib does not support this for mk4vfs + if {![package vsatisfies [package require Tcl] 8.6]} { + set mk4vfs::zstreamed 1 + } + } else { + set driver mkcl + + # use raw Vlerq calls if Mk4tcl is not available + # $::vlerq::starkit_root is set in the init script in kitInit.c + set rootv [vlerq get $::vlerq::starkit_root 0 dirs] + set dname [vlerq get $rootv * name] + set prows [vlerq get $rootv * parent] + foreach r [lsearch -int -all $prows 0] { + if {[lindex $dname $r] eq "lib"} break + } + + # glob for a subdir in "lib", then source the specified file inside it + foreach {d f} { + vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl + } { + foreach z [lsearch -int -all $prows $r] { + if {[string match $d [lindex $dname $z]]} break + } + + set files [vlerq get $rootv $z files] + set names [vlerq get $files * name] + + set n [lsearch $names $f] + if {$n < 0} { error "$d/$f: cannot find startup script"} + + set s [vlerq get $files $n contents] + catch {set s [zlib decompress $s]} + uplevel #0 $s + } + + # hack the mkcl info so it will know this mount point as "exe" + set vfs::mkcl::v::rootv(exe) $rootv + set vfs::mkcl::v::dname(exe) $dname + set vfs::mkcl::v::prows(exe) $prows + } + + # mount the executable, i.e. make all runtime files available + vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] + + # alter path to find encodings + if {[info tclversion] eq "8.4"} { + load {} pwb + librarypath [info library] + } else { + encoding dirs [list [file join [info library] encoding]] ;# TIP 258 + } + # if the C code passed us a system encoding, apply it here. + if {[info exists tclkit_system_encoding]} { + # It is possible the chosen encoding is unavailable in which case + # we will be left with 'identity' to be handled below. + catch {encoding system $tclkit_system_encoding} + unset tclkit_system_encoding + } + # fix system encoding, if it wasn't properly set up (200207.004 bug) + if {[encoding system] eq "identity"} { + switch $::tcl_platform(platform) { + windows { encoding system cp1252 } + macintosh { encoding system macRoman } + default { encoding system iso8859-1 } + } + } + + # now remount the executable with the correct encoding + vfs::filesystem unmount $noe + set noe $::tcl::kitpath + # resolve symlinks + set noe [file dirname [file normalize [file join $noe __dummy__]]] + + set tcl_library [file join $noe lib tcl$tcl_version] + set tcl_libPath [list $tcl_library [file join $noe lib]] + vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe] + } + + # load config settings file if present + namespace eval ::vfs { variable tclkit_version 1 } + catch { uplevel #0 [list source [file join $noe config.tcl]] } + + uplevel #0 [list source [file join $tcl_library init.tcl]] + + # reset auto_path, so that init.tcl's search outside of tclkit is cancelled + set auto_path $tcl_libPath + # Ditto for Tcl module search path + tcl::tm::path remove {*}[tcl::tm::path list] + tcl::tm::roots [list [file join $noe lib]] +} diff --git a/src/punk86.vfs/config.tcl b/src/punk86.vfs/config.tcl new file mode 100644 index 00000000..1069b037 --- /dev/null +++ b/src/punk86.vfs/config.tcl @@ -0,0 +1 @@ +set ::vfs::tclkit_version 200611.001 diff --git a/src/punk86.vfs/lib/app-punk/repl.tcl b/src/punk86.vfs/lib/app-punk/repl.tcl index 3fc2b640..6e9d5ca5 100644 --- a/src/punk86.vfs/lib/app-punk/repl.tcl +++ b/src/punk86.vfs/lib/app-punk/repl.tcl @@ -14,6 +14,8 @@ package provide app-punk 1.0 set original_tm_list [tcl::tm::list] tcl::tm::remove {*}$original_tm_list +set module_folders [list] + #tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority #(only if Tcl has scanned all paths - see below bogus package load) #1 @@ -21,6 +23,8 @@ if {[file isdirectory [pwd]/modules]} { catch {tcl::tm::add [pwd]/modules} } +set tclmajorv [lindex [split [info tclversion] .] 0] + #2) if {[string match "*.vfs/*" [file normalize [info script]]]} { #src/xxx.vfs/lib/app-punk/repl.tcl @@ -28,18 +32,24 @@ if {[string match "*.vfs/*" [file normalize [info script]]]} { #set srcmodulefolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]]/modules # - the src/modules folder doesn't contain important modules such as vendormodules - so the above probably isn't that useful set srcfolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]] - set modulefolder [file join [file dirname $srcfolder] modules] ;#modules folder at same level as src folder + lappend module_folders [file join [file dirname $srcfolder] modules] ;#modules folder at same level as src folder + lappend module_folders [file join [file dirname $srcfolder] modules_tcl$tclmajorv] } else { # .../bin/punkXX.exe look for ../modules (i.e modules folder at same level as bin folder) - set modulefolder [file dirname [file dirname [info nameofexecutable]]]/modules + lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules + lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules_tcl$tclmajorv } - -if {[file isdirectory $modulefolder]} { - tcl::tm::add $modulefolder -} else { - puts stderr "Warning unable to find module folder at: $modulefolder" +foreach modulefolder $module_folders { + if {[file isdirectory $modulefolder]} { + tcl::tm::add $modulefolder + } else { + puts stderr "Warning unable to find module folder at: $modulefolder" + } } + +#TODO! lib_tcl8 lib_tcl9 etc based on tclmajorv + #libs are appended to end - so add higher prioriy libraries last (opposite to modules) #auto_path - add exe-relative after exe-relative path if {"windows" eq $::tcl_platform(platform)} { diff --git a/src/punk86.vfs/lib/gridplus2.11/LICENSE.GRIDPLUS b/src/punk86.vfs/lib/gridplus2.11/LICENSE.GRIDPLUS deleted file mode 100644 index 668f818b..00000000 --- a/src/punk86.vfs/lib/gridplus2.11/LICENSE.GRIDPLUS +++ /dev/null @@ -1,36 +0,0 @@ -This software (GRIDPLUS) is Copyright (c) 2004-2015 by Adrian Davis (adrian@satisoft.com). - -The author hereby grants permission to use, copy, modify, distribute, -and license this software and its documentation for any purpose, provided -that existing copyright notices are retained in all copies and that -this notice is included verbatim in any distributions. No written agreement, -license, or royalty fee is required for any of the authorized uses. -Modifications to this software may be copyrighted by their authors -and need not follow the licensing terms described here, provided that -the new terms are clearly indicated on the first page of each file -where they apply. - -IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY -FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES -ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY -DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY -OF SUCH DAMAGE. - -THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE -IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE -NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, -OR MODIFICATIONS. - -GOVERNMENT USE: If you are acquiring this software on behalf of the -U.S. government, the Government shall have only "Restricted Rights" -in the software and related documentation as defined in the Federal -Acquisition Regulations (FARs) in Clause 52.227.19 (c) (2). If you -are acquiring the software on behalf of the Department of Defense, -the software shall be classified as "Commercial Computer Software" -and the Government shall have only "Restricted Rights" as defined in -Clause 252.227-7013 (c) (1) of DFARs. Notwithstanding the foregoing, -the authors grant the U.S. Government and others acting in its behalf -permission to use and distribute the software in accordance with the -terms specified in this license. \ No newline at end of file diff --git a/src/punk86.vfs/lib/gridplus2.11/gridplus.tcl b/src/punk86.vfs/lib/gridplus2.11/gridplus.tcl deleted file mode 100644 index f57ba821..00000000 --- a/src/punk86.vfs/lib/gridplus2.11/gridplus.tcl +++ /dev/null @@ -1,6871 +0,0 @@ -#========================================================================# -# SCRIPT : gridplus.tcl # -# PURPOSE: Gridplus layout manager. # -# AUTHOR : Adrian Davis # -# : Incudes code from tile "combobox.tcl" by Joe English. # -# VERSION: 2.11 # -# DATE : 27/11/2015 # -#------------------------------------------------------------------------# -# HISTORY: 2.0 07/10/2006 - First release of Tile based GRIDPLUS. # -# : 2.1 24/02/2007 - Enchanced gpmap: Array mapping. # -# : - Documents gpinsert and gpselect. # -# : - Adds Container. # -# : - Removes special main/title condition. # -# : - Adds notebook "-command" option. # -# : - Fix tablelist sort problem. # -# : - Adds text "-font" option. # -# : 2.2 22/07/2007 - Change gpmap to set dropdown value not list.# -# : - Adds "-icons" option for tree. # -# : - Fix padding problem in layout. # -# : - Fix "container". # -# : - Changes "gridplus window" for container. # -# : 2.3 15/05/2008 - Adds Find dialog to text pop-up menu. # -# : - Adds "-labelanchor" option. # -# : - Adds "-validateauto" option. # -# : - Adds "-validate" for tablelist/tree. # -# : - Adds option to specify an event to "-ecmd". # -# : - Adds option to fix maximum entry characters.# -# : - Adds "popup" validation error messages. # -# : - Adds "?!" help text set to validation text. # -# : - Adds menu "underline" option. # -# : - Adds gpfind_dialog. # -# : - Adds gpfind, gpclear, gpcut, gpcopy and # -# : gppaste. # -# : - Adds "-topmost" option to "gridplus window".# -# : - Adds "-columnformat & -cfmt". # -# : - Change menu "=" as separator. # -# : - Change menu allow "~" to indicate command. # -# : - Fix problem with date validations. # -# : - Fix Validation in contained window problem. # -# : 2.4 05/02/2009 - Adds "-columnstretch". # -# : - Adds "-basename". # -# : - Adds new syntax for embedded grids. # -# : - Adds #style" widget option. # -# : - Adds radiobutton groups. # -# : - Adds "gridplus define". # -# : - Adds resize options to layout and "pack" # -# : command mode. # -# : - Adds "-command" to text - Triggered when # -# : text is modified. # -# : - Fix validate popup for toplevel windows. # -# : - Fix for "gpEditMenu" in contained windows. # -# : - Fix problem with validation for command # -# : invoked by pressing enter in entry. If a # -# : field has both a command and a validation # -# : specified, the validation will always be # -# : done when a command specified for the entry # -# : is invoked. # -# : - Fix problem setting dropdown using gpmap. # -# : - "gpselect" modified to "see" tablelist row. # -# : - Fix date validations. # -# : - Fix validation popup in notebooks. # -# : - Fix problem displaying label text when # -# : default widget is button/link/menubutton. # -# : 2.5 25/10/2009 - Adds "calendar" gridplus command mode. # -# : - Adds "dateselector" gridplus command mode. # -# : - Adds "gpnav" command. # -# : - Adds extra pre-defined entry validations. # -# : - Adds "trim:" option for entry validations. # -# : - Adds "!+" button wigdet option. # -# : - Adds "-overrideredirect" option for window. # -# : - Adds default (".") optionset. # -# : - Change gpset and gpselect to set values for # -# : "calendar" and "dateselector". # -# : - Change button widget so that Enter key will # -# : invoke the button command. # -# : - Change entry validation behaviour to work # -# : better losing focus to toplevel windows. # -# : - Fix entry validation losing focus to a # -# : toplevel window. # -# : - Fix entry validation popup messages in # -# : notebooks. # -# : - Fix "num" validation pattern. # -# : - Fix "expected integer" font problem due to # -# : Tcl/Tk bug. # -# : 2.6 23/10/2010 - Adds "single/space" option to tree. # -# : - Adds "ISO" date format. # -# : - Fix Unix container problem. # -# : 2.7 26/02/2012 - Adds option to set locale. # -# : - Adds "gpdefault" command. # -# : - Adds "gpdate" command. # -# : - Adds "=inline" entry/date default option. # -# : - Adds "tablelist" sort options. # -# : - Adds label width option. # -# : - Adds "Gridplus.optionsetDefaultStyle". # -# : - Fix date selector problem in topmost window.# -# : - Fix problem clearing radiobutton groups. # -# : - Fix modal flag clear problem. # -# : 2.8 28/03/2012 - Adds "=inline" dropdown default option. # -# : - Adds "~command" link option. # -# : - Change "checkbutton" so that the "+" option # -# : always results in a checked button. # -# : - Fix "gpset" to make sure window is updated. # -# : - Fix problem clearing "radiobutton" groups. # -# : - Fix link indent problem. # -# : - Fix gap in "theme" style border caused by # -# : ttk::labelframe bug. # -# : 2.9 04/07/2012 - Fix problem with value of tree node # -# : containing spaces. # -# : - Fix problem with "container" frame sizing. # -# : - Fix problem with some validations in # -# : "contained" toplevels. # -# : - Fix "clear" to withdraw validation pop-up # -# : message. # -# : 2.10 01/07/2013 - Adds "spinbox" gridplus command mode. # -# : - Adds "pane" gridplus command mode. # -# : - Adds "gpoptions" command. # -# : - Adds interface (and supporting procedures) # -# : to create user defined widget types for # -# : "widget" grid. # -# : - Adds "dateselector" option to display icon # -# : instead of downarrow. # -# : - Adds "-menu" option to "text". # -# : - Adds "-seeinsert" option to "text". # -# : - Adds "-seeinsert" option to "tablelist". # -# : - Adds "-takefocus" option to "tablelist". # -# : - Adds "-selectpage" option to "tablelist". # -# : - Adds "+" (focus) button widget option. # -# : - Adds new "gpselect" syntax/options. # -# : - Adds "-title" option to "gpset". # -# : - Adds "-name" option to "gpset". # -# : - Adds "gpmap" option to map to dict. # -# : - Adds Grid/Layout and Notebook command # -# : substitution. # -# : - Adds Popup/Balloon help display duration. # -# : - Change Popup/Balloon help to display at # -# : pointer position. # -# : - Change to allow "@" embedded widgets to # -# : work in embedded grids. # -# : - Change: Support for old "&w" embedded # -# : widget grid syntax removed. # -# : - Fix problem setting tablelist sort column # -# : when first column is integer/real. # -# : - Fix problem with tablelist row selection. # -# : - Fix problem with clipboard operations when # -# : widget with focus not of suitable type. # -# : - Fix problem with "gpfind" with patterns # -# : begining with "-". # -# : - Fix problem when selecting tablelist row # -# : using (Up and Down) cursor keys. # -# : - Fix menu separator problem with cascade # -# : style menus. # -# : - Code Tidy:- # -# : gpWidget rewritten/retructured/modularised. # -# : Four namespace variables eliminated. # -# : 2.11 27/11/2015 - Adds "gpdb" command. # -# : - Adds "gpdelete" command. # -# : - Adds "gpupdate" command. # -# : - Adds "gpget" command. # -# : - Adds "-save", "-restore", # -# : "-max", "-min", # -# : "-first", "-last", # -# : "-row" and "|" options to "gpselect". # -# : - Adds "-maintainsort" to "tablelist". # -# : - Adds true/false options for "tablelist" # -# : "-insertoptions". # -# : - Adds "tablelist" proc to return column # -# : values for selected row. # -# : - Adds "tablelist" "asciinocase" and # -# : "dictionary" column sort options. # -# : - Adds new "tree" "-selectfirst" option. # -# : - Adds new "tree" "-selectmode" option. # -# : - Adds widget option subsitution in embedded # -# : widget grid. # -# : - Adds new "layout" column/row weight setting # -# : syntax. # -# : - Adds new "notebook" "-padding" and # -# : "-tabpadding" options. # -# : - Adds new "grid" row "ns" stretch option. # -# : - Adds new "grid" "-attach ns" option. # -# : - Adds "buttonWidth" and "entryWidth" option # -# : database options. # -# : - Adds "gpset" "-|" dedent option. # -# : - Change "tablelist" to automatically set # -# : default column names. # -# : - Change "-insertexpr" to allow use of column # -# : names. # -# : - Change "gpselect" to allow use of column # -# : names. # -# : - Change "gpset" so that "-sortfirst" is # -# : disabled if there is a "saved" selection. # -# : - Change "gpunset" to allow patterns. # -# : - Fix "tree" keyboard traversal selection. # -# : - Fix problem with entry validation when # -# : using right-click menu in another entry. # -# : - Fix setting "checkbutton" default selected # -# : when "-state" is "disabled". # -# : - Fix "checkbutton" command options. # -# : - Fix setting "radiobutton" default selected # -# : when "-state" is "disabled". # -# : - Fix "dropdown" to use "-state" correctly. # -# : - Fix notebook pane name problem. # -# : - Fix problem with Text find dialog with # -# : patterns begining with "-". # -# : - Fix problem with "Date" clearing when # -# : "dateIcon" specified. # -########################################################################## - -package require Tk 8.5 - -package require msgcat -namespace import msgcat::* - -catch {package require icons} -catch {package require tablelist_tile} - -package provide gridplus 2.11 - -#=======================================================================# -# Export the public interface. # -#=======================================================================# - -namespace eval ::gridplus:: { - namespace export gridplus - namespace export gpcopy - namespace export gpclear - namespace export gpcut - namespace export gpdate - namespace export gpdb - namespace export gpdefault - namespace export gpdelete - namespace export gpfind - namespace export gpfind_dialog - namespace export gpget - namespace export gpinsert - namespace export gpmap - namespace export gpnav - namespace export gpoptions - namespace export gppaste - namespace export gpselect - namespace export gpset - namespace export gpunset - namespace export gpupdate - variable gpWidgetHelp - variable gpConfig - variable gpInfo - variable gpOptionSets - variable gpTabOrder - variable gpValidate - variable gpValidateError - variable gpValidations -} - -#=======================================================================# -# PROC : ::gridplus::gridplus # -# PURPOSE: Exported command. # -#=======================================================================# - -proc ::gridplus::gridplus {args} { - variable gpConfig - variable gpInfo - - # If first call run initialisation. - if {! [info exists gpConfig]} { - gpInit - } - - # Set array of valid/default options. - array set options [list \ - -action none \ - -anchor [=< anchor s] \ - -autogroup [=< autoGroup] \ - -attach [=< attach] \ - -background [=< background] \ - -borderwidth [=< borderWidth 2] \ - -basename {} \ - -calcolor [=< calColor black/white] \ - -calrelief [=< calRelief flat] \ - -calselectcolor [=< calSelectColor black/gray] \ - -ccmd {} \ - -century $gpConfig(date:century) \ - -cfmt [=< columnFormat] \ - -checkbuttoncommand {} \ - -columnformat [=< columnFormat] \ - -columnsort [=< columnSort 1] \ - -command {} \ - -compound left \ - -date {} \ - -dateclear [=< dateClear 1] \ - -datecommand {} \ - -dateformat $gpConfig(dateformat) \ - -dcmd {} \ - -Dcmd {} \ - -dropdowncommand {} \ - -ecmd [=< entryCommand] \ - -entrycommand [=< entryCommand] \ - -errormessage $gpConfig(errormessage) \ - -fileicon [=< fileIcon file] \ - -fixed [=< fixed 999999] \ - -foldericon [=< folderIcon folder] \ - -font [=< font] \ - -foreground [=< foreground black] \ - -from [=< from] \ - -group {} \ - -height [=< height 10] \ - -icon [=< icon] \ - -iconfile $gpConfig(iconfile) \ - -iconpath $gpConfig(iconpath) \ - -icons [=< icons 1] \ - -in {} \ - -increment [=< increment 1] \ - -insertexpr {} \ - -insertoptions {} \ - -justify left \ - -labelanchor [=< labelAnchor] \ - -labelcolor [=< labelColor /] \ - -labelstyle [=< labelStyle /] \ - -linerelief [=< lineRelief sunken] \ - -linewidth [=< lineWidth 2] \ - -linkcolor [=< linkColor black/black] \ - -linkcursor [=< linkCursor arrow] \ - -linkstyle [=< linkStyle /underline] \ - -listvariable {} \ - -locale $gpConfig(locale) \ - -maintainsort [=< mantainSort 0] \ - -menu {} \ - -minx 100 \ - -miny 100 \ - -modal 0 \ - -names {} \ - -navbar [=< navBar 1] \ - -navcommand {} \ - -navselect [=< navSelect 0] \ - -open [=< open 0] \ - -optionset {} \ - -overrideredirect 0 \ - -pad [=< pad 5] \ - -padding [=< padding {5 5 5 5}] \ - -padx [=< padX [=< pad 5]] \ - -pady [=< padY [=< pad 5]] \ - -pattern {} \ - -prefix $gpConfig(prefix) \ - -proc $gpConfig(proc) \ - -radiobuttoncommand {} \ - -rcmd {} \ - -relief [=< relief flat] \ - -resize {} \ - -scroll none \ - -seeinsert [=< seeInsert 0] \ - -selectfirst 0 \ - -selectmode [=< selectMode browse] \ - -selectpage [=< selectPage 0] \ - -selecttoday [=< selectToday 0] \ - -show [=< show tree] \ - -sortfirst 0 \ - -sortorder increasing \ - -space [=< space 20] \ - -spacestretch {} \ - -spinformat [=< spinFormat] \ - -state normal \ - -sticky [=< sticky] \ - -stretch {} \ - -style {} \ - -subst [=< subst 1] \ - -tableoptions {} \ - -taborder column \ - -tabpadding [=< tabPadding] \ - -takefocus 1 \ - -tags 0 \ - -text {} \ - -title {} \ - -to [=< to] \ - -topmost [=< topmost 0] \ - -validate [=< validate 0] \ - -validateauto [=< validateAuto 1] \ - -validatepopup [=< validatePopup 0] \ - -validation {} \ - -variable {} \ - -variables 1 \ - -wcmd {} \ - -weekstart [=< weekStart 1] \ - -widget [=< widget grid] \ - -width [=< width 40] \ - -windowcommand {} \ - -wrap word \ - -wraplength 0 \ - -wtitle {} \ - ] - - # Read mode. - set mode [lindex $args 0] - - # Validate mode and set parameter template. - switch -- $mode { - add {set argTemplate [list "name 1" "options 2 end"]} - button {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< buttonWidth [=< widgetWidth 10]]} - calendar {set argTemplate [list "name 1" "options 2 end"]} - checkbutton {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - clear {set argTemplate [list "name 1" "options 2 end"]} - container {set argTemplate [list "name 1" "options 2 end"];set options(-height) [=< containerHeight 200];set options(-width) [=< containerWidth 250]} - date {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - define {set argTemplate [list "layout 1"]} - dropdown {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - entry {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< entryWidth [=< widgetWidth 10]]} - goto {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} - grid {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} - init {set argTemplate [list "options 1 end"]} - layout {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} - line {set argTemplate [list "name 1" "options 2 end"]} - link {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - menu {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} - menubutton {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - notebook {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-padding) [=< notebookPadding]} - optionset {set argTemplate [list "name 1" "options 2 end-1" "layout end"]} - pack {set argTemplate [list "name 1" "options 2 end"]} - pane {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-height) [=< paneHeight 0];set options(-width) [=< paneWidth 0]} - radiobutton {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - set {set argTemplate [list "options 1 end"]} - spinbox {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - tablelist {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< tableWidth 40];set options(-takefocus) 0} - text {set argTemplate [list "name 1" "options 2 end"];set options(-width) [=< textWidth 40]} - tree {set argTemplate [list "name 1" "options 2 end"];set options(-width) [=< treeWidth 200];set options(-selectmode) [=< treeSelectMode extended]} - widget {set argTemplate [list "name 1" "options 2 end-1" "layout end"];set options(-width) [=< widgetWidth 10]} - window {set argTemplate [list "name 1" "options 2 end"]} - default {error "GRIDPLUS ERROR: Invalid mode ($mode)."} - } - - # Check if sufficient args. - if {[llength $args] < [llength $argTemplate]} { - error "GRIDPLUS ERROR: Wrong number of Args." - } - - # Check if sufficient args remain for option/value pairs. - if {$mode ne "define" && [expr {([llength $args] - [llength $argTemplate]) % 2}] != 0} { - error "GRIDPLUS ERROR: Unmatched option/value." - } - - # Unset gpUnknown. - foreach unknownItem [array names gpInfo *] { - unset gpInfo($unknownItem) - } - - # Read/validate arguments. - foreach template $argTemplate { - set argName [lindex $template 0] - set argStart [lindex $template 1] - set argEnd [lindex $template 2] - # If argName is "options" read option/value pairs. - if {$argName eq "options"} { - foreach {option value} [lrange $args $argStart $argEnd] { - if {[info exists options($option)]} { - switch -- $option { - -pad { - set options(-padx) $value - set options(-pady) $value - } - -title { - set options(-title) $value - if {$options(-title) ne ""} { - set options(-relief) theme - } - } - default { - set options($option) $value - } - } - } else { - if {[=< unknown 1]} { - set gpInfo($option) $value - } else { - error "GRIDPLUS ERROR: Invalid option ($option)." - } - } - } - } else { - set options($argName) [lindex $args $argStart] - } - } - - # Set optionset. - gpSetOptionset - - # Remove blank lines from "layout". - if {[info exists options(layout)]} { - regsub -all -- {\n\n} $options(layout) "\n" options(layout) - regsub -all -- {(^\n)|(\n$)|(\n +$)} $options(layout) "" options(layout) - } - - # Call appropriate procedure according to specified mode. - switch -- $mode { - add {gpAdd} - button {set options(-widget) b;gpWidget} - calendar {gpCalendar} - checkbutton {set options(-widget) c;gpWidget} - clear {gpClear} - container {gpContainer} - date {set options(-widget) D;gpWidget} - define {gpDefine} - dropdown {set options(-widget) d;gpWidget} - entry {set options(-widget) e;gpWidget} - goto {gpGoto} - grid {gpGrid} - layout {gpLayout} - line {gpLine} - link {set options(-widget) l;gpWidget} - menu {gpMenu} - menubutton {set options(-widget) m;gpWidget} - notebook {gpNotebook} - optionset {gpOptionset} - pack {gpPack} - pane {gpPane} - radiobutton {set options(-widget) r;gpWidget} - set {gpSet} - spinbox {set options(-widget) s;gpWidget} - tablelist {gpTablelist} - text {gpText} - tree {gpTree} - widget {gpWidget} - window {gpWindow} - } - -} - -#=======================================================================# -# PROC : ::gridplus::gpWidget # -# PURPOSE: Create widget grid. # -#=======================================================================# - -proc ::gridplus::gpWidget {} { - upvar 1 options globaloptions - - array set options [array get globaloptions] - - global {} - - variable gpConfig - variable gpInfo - variable gpValidation - variable gpValidations - - if {$options(-fixed) eq ""} { - set defaultFixed $options(-width) - } else { - set defaultFixed $options(-fixed) - } - - if {$options(-basename) eq ""} { - set basename $options(name) - } else { - set basename $options(-basename) - } - - set defaultWidget [string range $options(-widget) 0 0] - set gridData {} - set rowCount 0 - set widgetID 1 - - if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { - set window {} - } - - foreach row [split $options(layout) "\n"] { - set columnCount 0 - foreach column $row { - set action 0 - set createWidget 0 - set errorMessage {} - set fixed $defaultFixed - set gridColumn {} - set itemFixed {} - set itemWidth {} - set state $options(-state) - set style $options(-style) - set widget $defaultWidget - set widgetHelp {} - set widgetOptions [dict create widget options] - set width $options(-width) - - if {$options(-autogroup) ne ""} {} - - set column [::gridplus::gpDefineWidget $column] - set column [::gridplus::gpParseEmbeddedGrid $column] - - foreach item $column { - switch -regexp -- $item { - - ^[&]=[a-zA-Z] { - set widget "=" - set userWidget [string range $item 2 2] - set widgetLayout [lrange $item 2 end] - regexp {^[&]=[^: ]+:([^ ]*)} $item -> style - } - ^[&] { - set widgetLayout [lrange $item 1 end] - if {! [regexp {^[&]([^: ]+):([^ ]*)} $item -> widget style]} { - set widget [lindex [string range $item 1 end] 0] - } - if {$widget eq "&" && $style eq ""} { - set style "{}" - } - if {$widget eq "d" && $options(-state) eq "normal"} { - set state readonly - } - } - ^[.] { - set createWidget 1 - if {[regexp -- {(^[.]$)|(^[.]:)} $item]} { - if {$widget eq "&"} { - regsub -- {[.]} $item $options(name)-$widgetID item - } else { - regsub -- {[.]} $item [regsub -- {([^.]+)[.]} $options(name)-$widgetID {\1_-_}] item - } - incr widgetID - } - if {! [regexp {(^[^:]+)(:[nsewc]+$)} $item -> item sticky]} {set sticky {}} - if {$widget in "g &"} { - set widgetName $item - } else { - set widgetName $basename,[string range $item 1 end] - } - if {$options(-autogroup) ne ""} {dict set widgetOptions > "::gridplus::gpAutoGroup $widgetName $options(-autogroup) normal"} - if {$options(-group) ne ""} {set gpInfo($widgetName:group) $options(-group)} - lappend gridColumn $widgetName$sticky - } - ^: { - dict set widgetOptions : [string range $item 1 end] - if {$widget in "b m"} { - if {! $createWidget} { - set createWidget 1 - set widgetName $options(name),[= $widgetOptions :] - if {$options(-group) ne ""} {set gpInfo($widgetName:group) $options(-group)} - lappend gridColumn $widgetName - } - } elseif {! $createWidget && $widget ne "l"} { - lappend gridColumn $item%% - } - } - ^[0-9]+$ { - set width $item - } - ^([0-9]*)/([0-9]*)$ { - regexp -- {^([0-9]*)/([0-9]*)$} $item -> itemWidth itemFixed - if {$itemWidth eq ""} { - set width $options(-width) - } else { - set width $itemWidth - } - if {$itemFixed eq ""} { - set fixed $width - } else { - set fixed $itemFixed - } - } - ^@ { - set gridName .[string range $item 1 end] - lappend gridColumn $gridName - } - ^% { - set gpInfo($widgetName:group) [string range $item 1 end] - } - ^[-+*~!] { - dict set widgetOptions [string range $item 0 0] [string range $item 1 end] - } - ^[?] { - set widgetHelp [mc [string range $item 1 end]] - } - ^[|]$ { - lappend gridColumn $item - } - ^[=]$ { - lappend gridColumn $item - } - ^[=].+ { - dict set widgetOptions = [string range $item 1 end] - } - ^<$ { - set state disabled - } - ^>$ { - set state normal - } - ^<.+ { - ::gridplus::gridplus set -group [string range $item 1 end] -state normal - dict set widgetOptions < "::gridplus::gpAutoGroup $widgetName [string range $item 1 end] disabled" - } - ^>.+ { - ::gridplus::gridplus set -group [string range $item 1 end] -state disabled - dict set widgetOptions > "::gridplus::gpAutoGroup $widgetName [string range $item 1 end] normal" - } - ^[#].* { - set style [string range $item 1 end] - } - default { - if {$widget in "b l m"} { - if {[llength $column] > 1} { - dict set widgetOptions text [mc $item] - } else { - lappend gridColumn $item - } - } else { - lappend gridColumn $item - } - } - } - } - - switch -glob -- $widget { - [cbdDelmrs] { - #---------------# - # Create widget # - #---------------# - if {$createWidget} { - ::gridplus::widget:$widget $widgetName $window $basename $style $width $fixed [=% $widgetName $state] $widgetOptions - } - } - [=] { - #----------------------------# - # Create user defined widget # - #----------------------------# - if {$createWidget} { - ::gridplus::widget:=$userWidget $widgetName $window $basename $style $width $fixed [=% $widgetName $state] $widgetOptions - } - } - & { - #-------------------------------# - # Create embedded "widget" grid # - #-------------------------------# - set stretch [lindex $widgetLayout 0] - set widgetWidget [lindex $widgetLayout 1] - set widgetStyle [lindex $widgetLayout 2] - set widgetLayout [lrange $widgetLayout 3 end] - if {$widgetStyle ne ""} { - if {$widgetStyle eq "%"} { - set style "{}" - } else { - set style $widgetStyle - } - } - set widgetCommand "::gridplus::gridplus widget $widgetName -basename $basename -borderwidth 0 -spacestretch [list $stretch] -pad 0 -padding {0 0 0 0} -style $style -widget $widgetWidget [list $widgetLayout]" - eval $widgetCommand - } - } - - if {$widgetHelp ne ""} { - if {$widgetHelp eq "!"} { - set widgetHelp [::gridplus::gpValidateText [= $widgetOptions !]] - } - gpWidgetHelpInit $widgetName $widgetHelp - } - - lappend gridData $gridColumn - incr columnCount - } - lappend gridData !!!! - incr rowCount - } - - regsub -all {!!!!} $gridData \n gridData - - set gridCommand "::gridplus::gridplus grid $options(name)" - - foreach option [array names options -*] { - set gridCommand "$gridCommand $option {$options($option)}" - } - - set gridCommand "$gridCommand {$gridData}" - - eval $gridCommand -} - -#=======================================================================# -# PROC : ::gridplus::widget:b # -# PURPOSE: Create button widget. # -#=======================================================================# - -proc ::gridplus::widget:b {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - variable gpInfo - - set command [= $widgetOptions ~] - set icon [= $widgetOptions :] - set text [= $widgetOptions text] - - set gpInfo($name:validationmode) force - set doValidation $options(-validate) - - if {[=? $widgetOptions !]} { - set doValidation 1 - if {[= $widgetOptions !] eq "+" } { - set gpInfo($name:validationmode) focus - } - } - - if {$command ne ""} { - set buttonCommand $command - } else { - if {[regexp -- {^([^=]*)=(.*)$} $name -> buttonCommand buttonParameter]} { - set buttonCommand "$buttonCommand $buttonParameter" - } else { - set buttonCommand "$name" - } - } - - if {$options(-proc)} { - set command "set gridplus::gpInfo() \[focus\];gpProc [::gridplus::gpCommandFormat $buttonCommand]" - } else { - set command "set gridplus::gpInfo() \[focus\];$options(-prefix)[::gridplus::gpCommandFormat $buttonCommand]" - } - - if {$icon ne ""} { - if {$text eq ""} { - ::ttk::button $name -command "::gridplus::gpCommand {$command} .$window $doValidation" -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) - } else { - ::ttk::button $name -command "::gridplus::gpCommand {$command} .$window $doValidation" -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width -compound $options(-compound) - } - } else { - ::ttk::button $name -command "::gridplus::gpCommand {$command} .$window $doValidation" -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width - } - - if {$state eq "disabled"} {$name configure -takefocus 0} - - if {[=? $widgetOptions +]} {focus $name} - - bind $name "$name invoke" -} - -#=======================================================================# -# PROC : ::gridplus::widget:c # -# PURPOSE: Create checkbutton widget. # -#=======================================================================# - -proc ::gridplus::widget:c {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - global {} - - set command [= $widgetOptions ~] - set ($name) [= $widgetOptions = [=@ $name 0]] - - set options(-checkbuttoncommand) [::gridplus::gpOptionAlias -checkbuttoncommand -ccmd] - - ::ttk::checkbutton $name -offvalue 0 -onvalue 1 -style $style -takefocus $options(-takefocus) -variable ($name) - - if {$state eq "disabled"} { - $name configure -takefocus 0 - } - - if {[=? $widgetOptions ~]} { - if {$command eq ""} { - set command $name - } - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $command]" - } else { - set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - $name configure -command $command - } elseif {$options(-checkbuttoncommand) ne ""} { - if {$options(-proc)} { - set command "gpProc $options(-checkbuttoncommand)" - } else { - set command "$options(-prefix)$options(-checkbuttoncommand)" - } - $name configure -command $command - } - - if {[=? $widgetOptions +]} { - set ($name) 0 - $name invoke - } - - $name configure -state $state -} - -#=======================================================================# -# PROC : ::gridplus::widget:d # -# PURPOSE: Create dropdown widget. # -#=======================================================================# - -proc ::gridplus::widget:d {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - global {} - - set command [= $widgetOptions ~] - set values [= $widgetOptions +] - set ($name) [= $widgetOptions = [=@ $name [lindex [= $widgetOptions +] 0]]] - - set options(-dropdowncommand) [::gridplus::gpOptionAlias -dropdowncommand -dcmd] - - ::ttk::combobox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -values $values -width $width - - if {$state eq "disabled"} { - $name configure -takefocus 0 - } - - if {[=? $widgetOptions ~]} { - if {$command eq ""} { - set command $name - } - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $command]" - } else { - set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - bind $name <> $command - } elseif {$options(-dropdowncommand) ne ""} { - if {$options(-proc)} { - set command "gpProc $options(-dropdowncommand)" - } else { - set command "$options(-prefix)$options(-dropdowncommand)" - } - bind $name <> "$command" - } -} - -#=======================================================================# -# PROC : ::gridplus::widget:D # -# PURPOSE: Create dateselector widget. # -#=======================================================================# - -proc ::gridplus::widget:D {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - variable gpInfo - - global {} - - set command [= $widgetOptions ~] - set ($name) [::gridplus::gpdate [= $widgetOptions = [=@ $name]]] - - if {$state eq "normal"} { - set state readonly - } - - set options(-datecommand) [::gridplus::gpOptionAlias -datecommand -Dcmd] - - if {[=< dateIcon] ne ""} { - if {"GridplusDate.downarrow" ni [ttk::style element names]} { - set normalIcon [=: [=< dateIcon]] - set disabledIcon [image create photo] - - ::ttk::combobox .gpComboboxHeight - set height [winfo reqheight .gpComboboxHeight] - destroy .gpComboboxHeight - - $disabledIcon copy $normalIcon - $disabledIcon configure -palette 16 -gamma 1.5 - - ::ttk::style element create GridplusDate.downarrow image [list $normalIcon disabled $disabledIcon] -height $height -sticky e - - ::ttk::style layout GridplusDate.TCombobox { - Combobox.field -sticky nswe -children { - GridplusDate.downarrow -side right -sticky ns - Combobox.padding -expand 1 -sticky nswe -children { - Combobox.textarea -sticky nswe - } - } - } - } - - set style "GridplusDate.TCombobox" - } - - ::ttk::combobox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -width $width - - bind $name "::gridplus::gpDateSelectorKeyPress $name %W post" - bind $name "::gridplus::gpDateSelectorKeyPress $name %W unpost" - bind $name "::gridplus::gpDateSelectorToggle $name %W" - bind $name "$name selection range 0 end" - bind $name "::gridplus::gpEntryEdit {} %X %Y" - - if {$options(-dateclear)} { - bind $name "::gridplus::gpDateSelectorClear $name %K" - } - - if {$state eq "disabled"} { - $name configure -takefocus 0 - } - - set gpInfo($name:datecommand) {} - - if {[=? $widgetOptions ~]} { - if {$command eq ""} { - set gpInfo($name:datecommand) $name - } - if {$options(-proc)} { - set gpInfo($name:datecommand) "gpProc [::gridplus::gpCommandFormat $command]" - } else { - set gpInfo($name:datecommand) "$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - } elseif {$options(-datecommand) ne ""} { - if {$options(-proc)} { - set gpInfo($name:datecommand) "gpProc $options(-datecommand)" - } else { - set gpInfo($name:datecommand) "$options(-prefix)$options(-datecommand)" - } - } -} - -#=======================================================================# -# PROC : ::gridplus::widget:e # -# PURPOSE: Create entry widget. # -#=======================================================================# - -proc ::gridplus::widget:e {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - variable gpInfo - variable gpValidations - - global {} - - set autoGroupCommand [= $widgetOptions > [= $widgetOptions <]] - set command [= $widgetOptions ~ $name] - set validation [= $widgetOptions !] - set ($name) [= $widgetOptions = [=@ $name]] - - set options(-entrycommand) [::gridplus::gpOptionAlias -entrycommand -ecmd] - - if {$state eq "disabled"} { - set state [=< entryDisabled readonly] - } - - if {[=? $widgetOptions !]} { - set doValidation 1 - lappend gpValidations(.$window) $name:$validation - } else { - set doValidation 0 - } - - if {$validation eq ""} { - set validation "__gpFixed__" - } else { - ::gridplus::gpValidateErrorInit $name [::gridplus::gpValidateText $validation] - } - - ::ttk::entry $name -invalidcommand "::gridplus::gpValidateFailed %W" -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -validate all -validatecommand "::gridplus::gpValidate %W \"$validation\" %V %P $fixed $options(-validateauto)" -width $width - - if {$state eq "disabled"} { - $name configure -background lightgray -takefocus 0 - } - - if {[=? $widgetOptions ~]} { - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $command]" - } else { - set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - if {[string match <*> $command]} { - bind $name "event generate $name $command" - } elseif {[string match "<*> *" $command]} { - regsub -all {:} $command "." command - bind $name "event generate [lindex $command 1] [lindex $command 0]" - } else { - bind $name "::gridplus::gpCommand {$command} .$window $doValidation" - } - } elseif {$options(-entrycommand) ne ""} { - if {$options(-proc)} { - set command "gpProc $options(-entrycommand)" - } else { - set command "$options(-prefix)$options(-entrycommand)" - } - if {[string match <*> $command]} { - bind $name "event generate $name $command" - } elseif {[string match "<*> *" $command]} { - regsub -all {:} $command "." command - bind $name "event generate [lindex $command 1] [lindex $command 0]" - } else { - bind $name "::gridplus::gpCommand {$command} .$window $doValidation" - } - } - - if {$autoGroupCommand ne ""} { - trace add variable ($name) write $autoGroupCommand - } - - if {$options(-validatepopup) && $validation ne "__gpFixed__"} { - ::gridplus::gpValidateErrorInit $name [::gridplus::gpValidateText $validation] popup - } - - if {[=? $widgetOptions *]} {$name configure -show "*"} - if {[=? $widgetOptions +]} {focus $name} - - bind $name "::gridplus::gpEntryEdit {$window} %X %Y" - -} - -#=======================================================================# -# PROC : ::gridplus::widget:l # -# PURPOSE: Create link widget. # -#=======================================================================# - -proc ::gridplus::widget:l {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - set command [= $widgetOptions ~ $name] - set icon [= $widgetOptions :] - set text [= $widgetOptions text] - - foreach {normalColor overColor} [split $options(-linkcolor) /] {} - foreach {normalStyle overStyle} [split $options(-linkstyle) /] {} - - regsub -- {[&]} $overStyle $normalStyle, overStyle - regsub -all -- {,} $normalStyle { } normalStyle - regsub -all -- {,} $overStyle { } overStyle - - if {! [string match */* $options(-linkcolor)]} {set overColor $normalColor} - - if {$normalColor eq ""} {set normalColor "black"} - if {$overColor eq ""} {set overColor "black"} - - if {[=? $widgetOptions !]} { - set doValidation 1 - } else { - set doValidation 0 - } - - if {[=? $widgetOptions -]} { - set indent " " - } elseif {[=? $widgetOptions +]} { - set indent "\u2022 " - } else { - set indent "" - } - - if {$options(-proc)} { - set linkCommand "set gridplus::gpInfo() \[focus\];gpProc [::gridplus::gpCommandFormat $command]" - } else { - set linkCommand "set gridplus::gpInfo() \[focus\];$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - - ::ttk::frame $name - ::ttk::label $name.link -background $options(-background) -foreground $options(-foreground) -text [mc $text] - - set normalFont [::gridplus::gpSetFont $normalStyle] - set overFont [::gridplus::gpSetFont $overStyle] - - $name.link configure -font $normalFont -foreground $normalColor - - bind $name.link "$name.link configure -font {$overFont} -foreground $overColor -cursor $options(-linkcursor)" - bind $name.link "$name.link configure -font {$normalFont} -foreground $normalColor -cursor {}" - bind $name.link "eval \"::gridplus::gpCommand {$linkCommand} .$window $doValidation\"" - - if {[=? $widgetOptions :]} { - if {$icon eq ""} {set icon $options(-icon)} - ::ttk::label $name.icon -image [=: $icon] - bind $name.icon "$name.icon configure -cursor $options(-linkcursor)" - bind $name.icon "$name.icon configure -cursor {}" - bind $name.icon "eval \"::gridplus::gpCommand {$linkCommand} .$window $doValidation\"" - grid $name.icon $name.link - } else { - ::ttk::label $name.indent -background $options(-background) -foreground $options(-foreground) -text $indent - grid $name.indent $name.link - } -} - -#=======================================================================# -# PROC : ::gridplus::widget:m # -# PURPOSE: Create menubutton widget. # -#=======================================================================# - -proc ::gridplus::widget:m {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - set icon [= $widgetOptions :] - set text [= $widgetOptions text] - - set menu "$name:menu" - - if {$icon ne ""} { - if {$text eq ""} { - ::ttk::menubutton $name -menu $menu -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) - } else { - ::ttk::menubutton $name -menu $menu -image [=: $icon] -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width -compound $options(-compound) - } - } else { - ::ttk::menubutton $name -menu $menu -state $state -style $style -takefocus $options(-takefocus) -text $text -width $width - } - - if {$state eq "disabled"} { - $name configure -takefocus 0 - } -} - -#=======================================================================# -# PROC : ::gridplus::widget:r # -# PURPOSE: Create radiobutton widget. # -#=======================================================================# - -proc ::gridplus::widget:r {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - variable gpInfo - - global {} - - set command [= $widgetOptions ~] - set group [= $widgetOptions *] - set value [= $widgetOptions + [= $widgetOptions -]] - - if {[=? $widgetOptions *]} { - set group ",$group" - } else { - set group {} - } - if {$basename eq ""} { - set variable "$options(name)$group" - if {$group ne ""} {set gpInfo($options(name):radiobuttonGroups) [lappend gpInfo($options(name):radiobuttonGroups) $group]} - } else { - set variable "$basename$group" - if {$group ne ""} {set gpInfo($basename:radiobuttonGroups) [lappend gpInfo($basename:radiobuttonGroups) $group]} - } - - set ($variable) {} - - set options(-radiobuttoncommand) [::gridplus::gpOptionAlias -radiobuttoncommand -rcmd] - - ::ttk::radiobutton $name -style $style -takefocus $options(-takefocus) -value $value -variable ($variable) - - if {$state eq "disabled"} { - $name configure -takefocus 0 - } - - if {[=? $widgetOptions +] || [=@ $variable] eq $value} { - after idle "$name invoke; $name configure -state $state" - } else { - $name configure -state $state - } - - if {[=? $widgetOptions ~]} { - if {$command eq ""} { - set command $name - } - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $command]" - } else { - set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - $name configure -command $command - } elseif {$options(-radiobuttoncommand) ne ""} { - if {$options(-proc)} { - set command "gpProc $options(-radiobuttoncommand)" - } else { - set command "$options(-prefix)$options(-radiobuttoncommand)" - } - $name configure -command $command - } -} - -#=======================================================================# -# PROC : ::gridplus::widget:s # -# PURPOSE: Create spinbox widget. # -#=======================================================================# - -proc ::gridplus::widget:s {name window basename style width fixed state widgetOptions} { - upvar 1 options options - - variable gpInfo - - global {} - - set value [= $widgetOptions +] - set ($name) [= $widgetOptions = [=@ $name]] - - if {$state eq "normal"} { - set state readonly - } - - set from {} - set to {} - set increment {} - set format {} - - if {[string match */* $value]} { - foreach {from to increment format} [split $value /] {} - - if {$from eq ""} { - if {$options(-from) eq ""} { - error "GRIDPLUS ERROR: 'From' value not specified for spinbox \"$name\"." - } else { - set from $options(-from) - } - } - if {$to eq ""} { - if {$options(-to) eq ""} { - error "GRIDPLUS ERROR: 'To' value not specified for spinbox \"$name\"." - } else { - set to $options(-to) - } - } - if {$increment eq ""} { - if {$options(-increment) eq ""} { - error "GRIDPLUS ERROR: 'Increment' value not specified for spinbox \"$name\"." - } else { - set increment $options(-increment) - } - } - if {$format eq ""} { - set format $options(-spinformat) - } - - if {$($name) eq ""} { - set ($name) $from - } - - ::ttk::spinbox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -from $from -to $to -increment $increment -format $format -width $width - } else { - if {$($name) eq ""} { - set ($name) [lindex $value 0] - } - - ::ttk::spinbox $name -state $state -style $style -takefocus $options(-takefocus) -textvariable ($name) -values $value -width $width - } - - if {$state eq "disabled"} { - $name configure -takefocus 0 - } - - bind $name "::gridplus::gpEntryEdit {$window} %X %Y" -} - -#=======================================================================# -# PROC : ::gridplus::gpAdd # -# PURPOSE: Add non-gridplus widget to group. # -#=======================================================================# - -proc ::gridplus::gpAdd {} { - upvar 1 options options - - variable gpInfo - - set gpInfo($options(name):group) $options(-group) -} - -#=======================================================================# -# PROC : ::gridplus::gpAutoGroup # -# PURPOSE: Set group state when entry has been updated. # -#=======================================================================# - -proc ::gridplus::gpAutoGroup {name group state args} { - - global {} - - trace remove variable ($name) write "::gridplus::gpAutoGroup $name $group $state" - - ::gridplus::gridplus set -group $group -state $state -} - -#=======================================================================# -# PROCS : ::gridplus::gpWidgetHelpInit # -# : ::gridplus::gpWidgetHelpDelay # -# : ::gridplus::gpWidgetHelpCancel # -# : ::gridplus::gpWidgetHelpShow # -# PURPOSE: Gridplus widget help. # -#=======================================================================# - -proc ::gridplus::gpWidgetHelpInit {item message} { - variable gpWidgetHelp - - if {! [winfo exists .gpWidgetHelp]} { - toplevel .gpWidgetHelp -background black -borderwidth 1 -relief flat - label .gpWidgetHelp.message -background lightyellow - pack .gpWidgetHelp.message - wm overrideredirect .gpWidgetHelp 1 - wm withdraw .gpWidgetHelp - } - - set gpWidgetHelp($item) $message - bind $item {::gridplus::gpWidgetHelpDelay %W} - bind $item {::gridplus::gpWidgetHelpCancel} -} - -proc ::gridplus::gpWidgetHelpDelay {item} { - variable gpWidgetHelp - - gpWidgetHelpCancel - set gpWidgetHelp(delay) [after 300 [list ::gridplus::gpWidgetHelpShow $item]] -} - -proc ::gridplus::gpWidgetHelpCancel {} { - variable gpWidgetHelp - - if {[info exists gpWidgetHelp(delay)]} { - after cancel $gpWidgetHelp(delay) - unset gpWidgetHelp(delay) - } - - if {[info exists gpWidgetHelp(show)]} { - after cancel $gpWidgetHelp(show) - unset gpWidgetHelp(show) - } - - if {[winfo exists .gpWidgetHelp]} { - wm withdraw .gpWidgetHelp - } -} - -proc ::gridplus::gpWidgetHelpShow {item} { - variable gpWidgetHelp - - .gpWidgetHelp.message configure -text $gpWidgetHelp($item) - - set screenWidth [lindex [wm maxsize .] 0] - set helpWidth [winfo width .gpWidgetHelp] - set helpX [winfo pointerx $item] - set helpY [expr [winfo rooty $item] + [winfo height $item]] - - if {[expr {$helpX + $helpWidth}] > $screenWidth} { - set helpX [expr {$screenWidth - $helpWidth - 8}] - } - - wm geometry .gpWidgetHelp +$helpX+$helpY - wm deiconify .gpWidgetHelp - - raise .gpWidgetHelp - - unset gpWidgetHelp(delay) - - set gpWidgetHelp(show) [after [=< helpDisplayTime 2500] ::gridplus::gpWidgetHelpCancel] -} - -#=======================================================================# -# PROC : ::gridplus::gpCalendar # -# PURPOSE: Create calendar. # -#=======================================================================# - -proc ::gridplus::gpCalendar {} { - upvar 1 options options - - global {} - - variable gpInfo - - set columnWidth 3 - - set gpInfo($options(name):fg) [lindex [split $options(-calcolor) "/"] 0] - set gpInfo($options(name):bg) [lindex [split $options(-calcolor) "/"] 1] - set gpInfo($options(name):selectfg) [lindex [split $options(-calselectcolor) "/"] 0] - set gpInfo($options(name):selectbg) [lindex [split $options(-calselectcolor) "/"] 1] - set gpInfo($options(name):command) $options(-command) - set gpInfo($options(name):navcommand) $options(-navcommand) - set gpInfo($options(name):navselect) $options(-navselect) - set gpInfo($options(name):variable) $options(-variable) - set gpInfo($options(name):selecttoday) $options(-selecttoday) - set gpInfo($options(name):weekstart) $options(-weekstart) - - if {$options(-date) eq ""} { - foreach {month day year} [clock format [clock seconds] -format "%m %d %Y"] {} - } else { - foreach {month day year} [::gridplus::gpFormatDate $options(-date) internal] {} - if {! [::gridplus::gpCalCheckDate $month $day $year]} { - error "GRIDPLUS ERROR: (gridplus calendar) \"$options(-date)\" is not a valid date." - } - } - - ::gridplus::gpLabelframe - - frame $options(name).calendar -bg $gpInfo($options(name):bg) -relief $options(-calrelief) -borderwidth 2 - frame $options(name).calendar.header -bg $gpInfo($options(name):bg) - - label $options(name).calendar.header.month -text "" -font [::gridplus::gpSetFont {+2 bold}] -bg $gpInfo($options(name):bg) -fg $gpInfo($options(name):fg) -padx 0 - label $options(name).calendar.header.year -text "" -font [::gridplus::gpSetFont {+2 bold}] -bg $gpInfo($options(name):bg) -fg $gpInfo($options(name):fg) -padx 0 - - pack $options(name).calendar.header.month -side left -anchor w - pack $options(name).calendar.header.year -side right -anchor e - - grid $options(name).calendar.header -columnspan 7 -sticky ew - - if {$options(-navbar)} { - frame $options(name).calendar.navbar -bg $gpInfo($options(name):bg) - frame $options(name).calendar.navbar.left -bg $gpInfo($options(name):bg) - frame $options(name).calendar.navbar.centre -bg $gpInfo($options(name):bg) - frame $options(name).calendar.navbar.right -bg $gpInfo($options(name):bg) - - ttk::label $options(name).calendar.navbar.left.navbackyear -image gpcal-prev-year -background $gpInfo($options(name):bg) - pack $options(name).calendar.navbar.left.navbackyear -side left - bind $options(name).calendar.navbar.left.navbackyear "::gridplus::gpCalendarNav $options(name) year -1" - - ttk::label $options(name).calendar.navbar.right.navnextyear -image gpcal-next-year -background $gpInfo($options(name):bg) - pack $options(name).calendar.navbar.right.navnextyear -side right - bind $options(name).calendar.navbar.right.navnextyear "::gridplus::gpCalendarNav $options(name) year +1" - - ttk::label $options(name).calendar.navbar.centre.current -image gpcal-today -background $gpInfo($options(name):bg) - pack $options(name).calendar.navbar.centre.current - bind $options(name).calendar.navbar.centre.current "::gridplus::gpCalendarNav $options(name) current" - - ttk::label $options(name).calendar.navbar.left.navbackmonth -image gpcal-prev-month -background $gpInfo($options(name):bg) - pack $options(name).calendar.navbar.left.navbackmonth -side left - bind $options(name).calendar.navbar.left.navbackmonth "::gridplus::gpCalendarNav $options(name) month -1" - - ttk::label $options(name).calendar.navbar.right.navnextmonth -image gpcal-next-month -background $gpInfo($options(name):bg) - pack $options(name).calendar.navbar.right.navnextmonth -side right - bind $options(name).calendar.navbar.right.navnextmonth "::gridplus::gpCalendarNav $options(name) month +1" - - pack $options(name).calendar.navbar.left -side left - pack $options(name).calendar.navbar.centre -side left -expand 1 -fill x - pack $options(name).calendar.navbar.right -side right - - grid $options(name).calendar.navbar -columnspan 7 -sticky ew - } - - set rowData "" - - foreach dayName [::gridplus::gpCalDayNames $options(-weekstart)] { - label $options(name).calendar.days:$dayName -text $dayName -borderwidth 1 -width $columnWidth -font [::gridplus::gpSetFont bold] -bg $gpInfo($options(name):bg) -fg $gpInfo($options(name):fg) - set rowData "$rowData $options(name).calendar.days:$dayName" - } - - grid {*}$rowData -sticky e - - for {set row 1} {$row < 7} {incr row} { - set rowData "" - for {set column 1} {$column < 8} {incr column} { - label $options(name).calendar.$row:$column -text "" -borderwidth 1 -width 3 -fg $gpInfo($options(name):fg) -bg $gpInfo($options(name):bg) - set rowData "$rowData $options(name).calendar.$row:$column" - } - grid {*}$rowData -sticky e - } - - grid columnconfigure $options(name) "all" -uniform allTheSame - - foreach child [winfo children $options(name).calendar] { - bind $child "::gridplus::gpCalendarSelect $options(name) %W" - } - - if {$options(-variable) ne ""} { - set ($options(-variable)) "" - } else { - set ($options(name)) "" - } - - pack $options(name).calendar - - ::gridplus::gpCalendarDisplay $options(name) $day $month $year -} - -#=======================================================================# -# PROC : ::gridplus::gpCalendarDisplay # -# PURPOSE: Display calendar for specified month. # -#=======================================================================# - -proc ::gridplus::gpCalendarDisplay {name day month year} { - - global {} - - variable gpConfig - variable gpInfo - - if {[info exists gpInfo($name:selected)] && $gpInfo($name:selected) ne ""} { - $gpInfo($name:selected) configure -bg $gpInfo($name:bg) -fg $gpInfo($name:fg) - } - - foreach {currentDay currentMonth currentYear} [clock format [clock seconds] -format "%d %m %Y"] {} - - if {$month eq $currentMonth && $year eq $currentYear} { - set current 1 - } else { - set current 0 - } - - if {[info exists gpInfo($name:selectedmonth)] && $month eq $gpInfo($name:selectedmonth) && $year eq $gpInfo($name:selectedyear)} { - set selected 1 - } else { - set selected 0 - } - - foreach {monthName startDay} [clock format [clock scan 01/$month/$year -format %d/%m/%Y] -format "%B %u" -locale $gpConfig(locale)] {} - - if {$gpInfo($name:weekstart) == 0} { - set startColumn [expr {$startDay + 1}] - if {$startColumn == 8} { - set startColumn 1 - } - } else { - set startColumn $startDay - } - - $name.calendar.header.month configure -text $monthName - $name.calendar.header.year configure -text $year - - set output 0 - set outputDay 1 - - set gpInfo($name:displaymonth) $month - set gpInfo($name:displayyear) $year - - for {set row 1} {$row < 7} {incr row} { - set rowData "" - for {set column 1} {$column < 8} {incr column} { - if {$row == 1} { - if {$column == $startColumn} { - set output 1 - } - } - - if {$outputDay > [::gridplus::gpCalMonthDays $month $year]} { - set output 0 - } - - if {$output} { - $name.calendar.$row:$column configure -text $outputDay -relief flat - - if {$current && [format %02d $outputDay] eq $currentDay} { - $name.calendar.$row:$column configure -relief solid - } - - if {$gpInfo($name:selecttoday) && [format %02d $outputDay] eq $day} { - ::gridplus::gpCalendarSelect $name $name.calendar.$row:$column -displayonly - } - - if {$selected && [format %02d $outputDay] eq $gpInfo($name:selectedday)} { - $name.calendar.$row:$column configure -bg $gpInfo($name:selectbg) -fg $gpInfo($name:selectfg) - } - incr outputDay - } else { - $name.calendar.$row:$column configure -text "" -relief flat - } - } - } - - set gpInfo($name:selecttoday) 0 -} - -#=======================================================================# -# PROC : ::gridplus::gpCalendarNav # -# PURPOSE: Calendar navigation. # -#=======================================================================# - -proc ::gridplus::gpCalendarNav {name unit {increment {}}} { - - global {} - - variable gpInfo - - if {$unit eq "current"} { - if {$increment eq ""} { - foreach {month year} [clock format [clock seconds] -format "%m %Y"] {} - } else { - foreach {month year} [clock format [clock add [clock seconds] $increment month] -format "%m %Y"] {} - } - } else { - set month $gpInfo($name:displaymonth) - set year $gpInfo($name:displayyear) - foreach {month year} [clock format [clock add [clock scan 01/$gpInfo($name:displaymonth)/$gpInfo($name:displayyear) -format "%d/%m/%Y"] $increment $unit] -format "%m %Y"] {} - } - - ::gridplus::gpCalendarDisplay $name {} $month $year - - if {$gpInfo($name:navselect)} { - if {$gpInfo($name:variable) ne ""} { - set variable $gpInfo($name:variable) - } else { - set variable $name - } - - if {$($variable) ne ""} { - foreach {varMonth varDay varYear} [::gridplus::gpFormatDate $($variable) internal] {} - if {$month eq $varMonth && $year eq $varYear} { - ::gridplus::gpselect $name $($variable) - } - } - } - - if {$gpInfo($name:navcommand) ne ""} { - eval "$gpInfo($name:navcommand) $name $unit $increment" - } -} - - -#=======================================================================# -# PROC : ::gridplus::gpCalendarSelect # -# PURPOSE: Sets value for calendar selection. # -#=======================================================================# - -proc ::gridplus::gpCalendarSelect {name window {mode {}}} { - - global {} - - variable gpConfig - variable gpInfo - - if {[winfo class $window] ne "Label" || ! [string is integer -strict [$window cget -text]]} {return} - - if {$gpInfo($name:variable) ne ""} { - set variable $gpInfo($name:variable) - } else { - set variable $name - } - - if {[info exists gpInfo($name:selected)] && $gpInfo($name:selected) ne ""} { - $gpInfo($name:selected) configure -bg $gpInfo($name:bg) -fg $gpInfo($name:fg) - } - - $window configure -bg $gpInfo($name:selectbg) -fg $gpInfo($name:selectfg) - - set gpInfo($name:selected) $window - set gpInfo($name:selectedday) [format %02d [$window cget -text]] - set gpInfo($name:selectedmonth) $gpInfo($name:displaymonth) - set gpInfo($name:selectedyear) $gpInfo($name:displayyear) - - switch -- $gpConfig(dateformat) { - eu {set ($variable) "$gpInfo($name:selectedday).$gpInfo($name:selectedmonth).$gpInfo($name:selectedyear)"} - iso {set ($variable) "$gpInfo($name:selectedyear)-$gpInfo($name:selectedmonth)-$gpInfo($name:selectedday)"} - uk {set ($variable) "$gpInfo($name:selectedday)/$gpInfo($name:selectedmonth)/$gpInfo($name:selectedyear)"} - us {set ($variable) "$gpInfo($name:selectedmonth)/$gpInfo($name:selectedday)/$gpInfo($name:selectedyear)"} - } - - if {$mode ne "-displayonly" && $gpInfo($name:command) ne ""} { - eval $gpInfo($name:command) - } -} - -#=======================================================================# -# PROC : ::gridplus::gpClear # -# PURPOSE: Clear window and unset associated variables. # -#=======================================================================# - -proc ::gridplus::gpClear {} { - upvar 1 options options - - global {} - - variable gpWidgetHelp - variable gpInfo - variable gpTabOrder - variable gpValidateError - variable gpValidations - - if {$options(name) ne "."} { - unset -nocomplain gpInfo($options(name):toplevel) - unset -nocomplain gpInfo($options(name):modal) - } - - if {[winfo exists $options(name).container]} { - eval $gpInfo($options(name):wcmd) - unset -nocomplain gpInfo($options(name):in) - set gpInfo($options(name):wcmd) {} - return - } - - $options(name) configure -menu {} - - unset -nocomplain gpInfo(validation:failed) - unset -nocomplain gpValidations($options(name)) - - if {[winfo exists .gpValidateError]} { - wm withdraw .gpValidateError - } - - foreach item [winfo child $options(name)] { - if {! [winfo exists $item]} {continue} - - set class [winfo class $item] - - if {[regexp -- {^[.]_} $item]} { - continue - } - - if {[string match *.gpEditMenu $item]} { - continue - } - - if {$class ne "Toplevel"} { - if {$options(-variables) && [info exists ($item)]} { - if {$class eq "Entry"} { - $item configure -textvariable {} - } - unset ($item) - } - if {$options(-variables) && [info exists gpInfo($item:radiobuttonGroups)]} { - foreach radiobuttonGroup $gpInfo($item:radiobuttonGroups) { - if {[info exists ($item$radiobuttonGroup)]} { - unset ($item$radiobuttonGroup) - } - } - unset gpInfo($item:radiobuttonGroups) - } - if {[info exists gpWidgetHelp($item)]} { - unset gpWidgetHelp($item) - } - if {[info exists gpInfo($item:wcmd)]} { - eval $gpInfo($item:wcmd) - } - foreach infoItem [array names gpInfo $item:*] { - unset gpInfo($infoItem) - } - foreach tabOrderItem [array names gpTabOrder $item:*] { - unset gpTabOrder($tabOrderItem) - } - foreach validateErrorItem [array names gpValidateError $item:*] { - unset gpValidateError($validateErrorItem) - } - if {$gpInfo() eq "$item.text"} { - if {[winfo exists .gpTextFind]} { - ::gridplus::gpTextFind:action,cancel - } - } - if {$class eq "Menu"} { - foreach infoItem [array names gpInfo $item.*:group] { - unset gpInfo($infoItem) - } - } - - destroy $item - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpCommand # -# PURPOSE: Evals command, performing validations if required. # -#=======================================================================# - -proc ::gridplus::gpCommand {command window validate} { - - global {} - - variable gpValidations - variable gpInfo - - if {$window eq "."} { - set containers [array names gpInfo -regexp {^[.][^.]+:in$}] - } else { - set containers [array names gpInfo -regexp "^$window\[.\]\[^.\]+:in$"] - } - - set containedWindows {} - - foreach container $containers { - set containedWindows "$containedWindows $gpInfo($container)" - } - - if {[info exists gpValidations($window)]} { - set validations $gpValidations($window) - } else { - set validations {} - } - - foreach containedWindow $containedWindows { - if {[info exists gpValidations($containedWindow)]} { - set validations "$validations $gpValidations($containedWindow)" - } - } - - if {$validate && $validations ne ""} { - foreach validationInfo $validations { - set entry [lindex [split $validationInfo :] 0] - regexp -- {:(.+)$} $validationInfo -> validation - if {! [::gridplus::gpValidate $entry $validation focusout - - 1]} { - ::gridplus::gpValidateFailed $entry - return - } - } - } - - eval $command -} - -#=======================================================================# -# PROC : ::gridplus::gpCommandFormat # -# PURPOSE: Makes sure "command" is in the correct format. # -#=======================================================================# - -proc ::gridplus::gpCommandFormat {command} { - - set commandProc [lindex $command 0] - set commandParameters [lrange $command 1 end] - - regsub -all {[.]} $commandProc ":" commandProc - regsub {;:} $commandProc ";" commandProc - regsub {^:} $commandProc {} commandProc - - if {[llength $command] eq 1} { - return $commandProc - } else { - return [list $commandProc {*}$commandParameters] - } -} - -#=======================================================================# -# PROC : ::gridplus::gpContainer # -# PURPOSE: Create container for toplevel windows. # -#=======================================================================# - -proc ::gridplus::gpContainer {} { - upvar 1 options options - - variable gpInfo - - if {[regexp -- {(^[.][^.]+)[.]} $options(name) -> window]} { - if {! $gpInfo($window:toplevel)} { - error "GRIDPLUS ERROR: (gridplus container) \"$window\" is a contained toplevel." - } - } - - if {$options(-relief) eq "theme"} { - if {$options(-title) eq ""} { - ::ttk::labelframe $options(name) -height $options(-height) -width $options(-width) -padding $options(-padding) - ::ttk::separator $options(name).separator -orient horizontal - $options(name) configure -labelwidget $options(name).separator -labelanchor s - } else { - if {$options(-labelanchor) eq ""} { - ::ttk::labelframe $options(name) -height $options(-height) -width $options(-width) -padding $options(-padding) -text [mc $options(-title)] - } else { - ::ttk::labelframe $options(name) -height $options(-height) -width $options(-width) -labelanchor $options(-labelanchor) -padding $options(-padding) -text [mc $options(-title)] - } - } - } else { - ::ttk::frame $options(name) -height $options(-height) -width $options(-width) -padding $options(-padding) -relief $options(-relief) - } - - grid propagate $options(name) 0 - pack propagate $options(name) 0 - - set gpInfo($options(name):sticky) $options(-sticky) - set gpInfo($options(name):wcmd) {} - -} - -#=======================================================================# -# PROC : ::gridplus::gpCreateIcons # -# PURPOSE: Creates default icons for GRIDPLUS Tree. # -#=======================================================================# - -proc ::gridplus::gpCreateIcons {} { - - image create photo ::icon::file -data { - R0lGODlhEAAQAIIAAPwCBFxaXISChPz+/MTCxKSipAAAAAAAACH5BAEAAAAA - LAAAAAAQABAAAANCCLrcGzBC4UAYOE8XiCdYF1BMJ5ye1HTfNxTBSpy0QMBy - ++HlXNu8h24X6/2AReHwllRcMtCgs0CtVpsWiRZbqfgTACH+aENyZWF0ZWQg - YnkgQk1QVG9HSUYgUHJvIHZlcnNpb24gMi41DQqpIERldmVsQ29yIDE5OTcs - MTk5OC4gQWxsIHJpZ2h0cyByZXNlcnZlZC4NCmh0dHA6Ly93d3cuZGV2ZWxj - b3IuY29tADs= - } - - image create photo ::icon::folder -data { - R0lGODlhEAAQAIIAAPwCBFxaXMTCxPz+/KSipAAAAAAAAAAAACH5BAEAAAAA - LAAAAAAQABAAAAM3CLrc/i/IAFcQWFAos56TNYxkOWhKcHossals+64x5qZ0 - fQNwbc++Hy4o2F0IyKTSCGqCKhB/AgAh/mhDcmVhdGVkIGJ5IEJNUFRvR0lG - IFBybyB2ZXJzaW9uIDIuNQ0KqSBEZXZlbENvciAxOTk3LDE5OTguIEFsbCBy - aWdodHMgcmVzZXJ2ZWQuDQpodHRwOi8vd3d3LmRldmVsY29yLmNvbQA7 - } - - image create photo gpcal-prev-year -data { - R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA - AAACvAAAAAEbhAzQICcB0AoanwTx9Akz2QTx9Akz5wEbhATyEAkz/gzQIATyjAk/ogAAAAAA - AQTyZNUOlwEbhATyECNGkAEbhAAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w - xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQNAQANAQk6/gQNAQAAGgTzWATzCCNGmgTy2NhvHgUK - PgAABxQIQAAAAAAAAQk+Qwk+ggggwQAABAT1fAlRCwggwQAABAk+Qwk+ggggwQAABAT1nAlR - CwggwQAABAT1nAAAAAggwQUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz - bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k - kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc - 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEgwYUADwAAAFa0 - WAEgwQAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA - ALwCAAAAAIQbASDQDNABJ58aCvTxBNkzCfTxBOczCYQbARDyBP4zCSDQDIzyBKI/CQAAAAEA - AGTyBJcO1YQbARDyBJBGI4QbAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw - /QDg/QAAALU4CZQ4CUzzBCx/QAAAAAENBAENAP46CQENBBoAAFjzBAjzBJpGI9jyBB5v2D4K - BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgg - wQAAAAABAAT1hAAAAgla9AlNzwlaxAggwQAAAAABAAT1pAAAAgla9Ala5QgXAAMIBABgYEGD - CBMSFMhwYQCHDQ8uDAgAOw== - } - - image create photo gpcal-prev-month -data { - R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA - AAACvAAAAAEbhAzQIB4MsAoanwTx9Akz2QTx9Akz5wEbhATyEAkz/gzQIATyjAk/ogAAAAAA - AQTyZNUOlwEbhATyECNGkAEbhAAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w - xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQfowAfowk6/gQfowAAGgTzWATzCCNGmgTy2NhvHgUK - PgAABxQIQAAAAAAAAQk+Qwk+gggdPQAABAT1fAlRCwgdPQAABAk+Qwk+gggdPQAABAT1nAlR - CwgdPQAABAT1nAAAAAgdPQUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz - bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k - kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc - 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEdPYUADwAAAFa0 - WAEdPQAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA - ALwCAAAAAIQbASDQDLAMHp8aCvTxBNkzCfTxBOczCYQbARDyBP4zCSDQDIzyBKI/CQAAAAEA - AGTyBJcO1YQbARDyBJBGI4QbAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw - /QDg/QAAALU4CZQ4CUzzBCx/QAAAAKMfBKMfAP46CaMfBBoAAFjzBAjzBJpGI9jyBB5v2D4K - BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgd - PQAAAAABAAT1hAAAAgla9AlNzwlaxAgdPQAAAAABAAT1pAAAAgla9Ala5QgXAAMIFAgAwMCD - BQ8OTKhwocGGBB8GCAgAOw== - } - - image create photo gpcal-today -data { - R0lGODlhZAAFAHcAACH5BAEAAAEALAAAAABkAAUAhwAAAP//8AAAAATzyPqI8PU4cP////lE - qPV9cPWKOgv/6AAAI/WKPpgu3dSYsgTxvNZvbTcLzgTyGNZvjgAAAQABEQAABgYLNjcLznPZ - uAAAgjcLziMlONRNoHPQAATx+ATx+DcLznPZuATyiNa44jcLzgAAggAAAAAAAAAAANcbETcL - zgAAggAAAAAAAATznAT5yAAAADcLzgAAggAAAAAAAAAABAAEsNa4nATzSAAAAPlEyww46PWL - zQUHePWQNww5EAw48Ak+Qwk+gggSoQAABAT1fAlRCwgSoQAABAk+Qwk+gggSoQAABAT1nAlR - CwgSoQAABAT1nAAAAAgSodQa2P///9TFCdRHqjcLzgAAggAAAAAAAATzKNgFm9gDDAAAggAA - ACMBeHPZuHP9gHP9iCMBeAHzVAUAAATyjAAAggTzdHPZsAAAAAAAAAAAAPaUVgAAUgAAAI0k - kAAAAAw48HPeAP3gAAHzXCMAAATy0PqI8ATzxPqI8AAAAgcJiP///wAARwcJiCMlONRNoNTL - oATzlACpGAT0dNjWEAT0JNhvHgcJiAAARwAAAAT4kAAAAdcbEQk67Qk2DwESoYUADwAAAFa3 - oAESoQAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAHA49f///6hE - +XB99TqK9ej/CyMAAD6K9d0umLKY1LzxBG1v1s4LNxjyBI5v1gEAABEBAAYAADYLBs4LN7jZ - c4IAAM4LNzglI6BN1ADQc/jxBPjxBM4LN7jZc4jyBOK41s4LN4IAAAAAAAAAAAAAABEb184L - N4IAAAAAAAAAAJzzBMj5BAAAAM4LN4IAAAAAAAAAAAQAALAEAJy41kjzBAAAAMtE+eg4DM2L - 9XgHBTeQ9RA5DPA4DADec7DZc7jyBOU6+LABADDecwAAI7DZcwAAAIzzBMqM9QlNzwlaxAgS - oQAAAAABAAT1hAAAAgla9AlNzwlaxAgSoQAAAAABAAT1pAAAAgla9Ala5Qg/AAMIHEiwoMGD - CBMOBMAQgMKHECNKnEiRIEOBFytqfNiwo8ePIEOK/GhxpMmTKB1uXHkwY0aWMGPKXNhwZsyA - ADs= - } - - image create photo gpcal-next-year -data { - R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA - AAACvAAAAAEbhAzQICcB0AoanwTx9Akz2QTx9Akz5wEbhATyEAkz/gzQIATyjAk/ogAAAAAA - AQTyZNUOlwEbhATyECNGkAEbhAAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w - xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQQGgAQGgk6/gQQGgAAGgTzWATzCCNGmgTy2NhvHgUK - PgAABxQIQAAAAAAAAQk+Qwk+gggb1gAABAT1fAlRCwgb1gAABAk+Qwk+gggb1gAABAT1nAlR - Cwgb1gAABAT1nAAAAAgb1gUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz - bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k - kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc - 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEb1oUADwAAAFa0 - WAEb1gAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA - ALwCAAAAAIQbASDQDNABJ58aCvTxBNkzCfTxBOczCYQbARDyBP4zCSDQDIzyBKI/CQAAAAEA - AGTyBJcO1YQbARDyBJBGI4QbAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw - /QDg/QAAALU4CZQ4CUzzBCx/QAAAABoQBBoQAP46CRoQBBoAAFjzBAjzBJpGI9jyBB5v2D4K - BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgb - 1gAAAAABAAT1hAAAAgla9AlNzwlaxAgb1gAAAAABAAT1pAAAAgla9Ala5QgZAAMAABBAIMGC - BQcmPIhQocGGBx0+nBggIAA7 - } - - image create photo gpcal-next-month -data { - R0lGODlhCgAFAHcAACH5BAEAAAEALAAAAAAKAAUAhwAAAP//8AAAEQAAEf//9QAAAAAAAAAA - AAACvAAAAAEP/gzQIAcAAAoanwTx9Akz2QTx9Akz5wEP/gTyEAkz/gzQIATyjAk/ogAAAAAA - AQTyZNUOlwEP/gTyECNGkAEP/gAAAAAAEgAADgAABAAABQAAAAAABgAAEAACvAAAAAkfDf3w - xP3gAAAAAAk4tQk4lATzTEB/LAAAAAQa7AAa7Ak6/gQa7AAAGgTzWATzCCNGmgTy2NhvHgUK - PgAABxQIQAAAAAAAAQk+Qwk+gggKNgAABAT1fAlRCwgKNgAABAk+Qwk+gggKNgAABAT1nAlR - CwgKNgAABAT1nAAAAAgKNgUKPgAABxQIQAAAAEB/LLqrzQAAAATzTEB/LATzbNbM1P3gAATz - bNbM9ATzONbMmgAAB0B/LAT1kAAAAAAAAAAAAQAAFAAAAQAAAAAAAAAAEAAAAAAAUgAAAI0k - kAAAANjWENQkAP///9bMmtRc1gAAAEB/LAUKPgAABxQIQAAAAAAAAAAAAAAAB1bhsATzvNRc - 9UB/LAUKPgAABxQIQAAAAAT0uEB/LAAAAAT1kFvsVlvsXgT2FAk67Qk2DwEKNoUADwAAAFa0 - WAEKNgAAAQAAAAAAUgAAAI0bkAAAAEL8iAT0EAADAAAAAAAAUgAAAI0bkAAAAAAAAAAAAAAA - ALwCAAAAAP4PASDQDAAAB58aCvTxBNkzCfTxBOczCf4PARDyBP4zCSDQDIzyBKI/CQAAAAEA - AGTyBJcO1f4PARDyBJBGI/4PAQAAABIAAA4AAAQAAAUAAAAAAAYAABAAALwCAAAAAA0fCcTw - /QDg/QAAALU4CZQ4CUzzBCx/QAAAAOwaBOwaAP46CewaBBoAAFjzBAjzBJpGI9jyBB5v2D4K - BQcAAEAIFAAAAAEAAD1G1DnJ1nxa2V9G1FFG1EzzBCx/QAAAAAAAACx/QAEAAAlNzwlaxAgK - NgAAAAABAAT1hAAAAgla9AlNzwlaxAgKNgAAAAABAAT1pAAAAgla9Ala5QgWAAMIBABAoMGD - BA8qTKgwAMOFBQ8GBAA7 - } - -} - -#=======================================================================# -# PROC : ::gridplus::gpDateSelectorClear # -# PURPOSE: Clear Date Selector field for "Delete" key. # -#=======================================================================# - -proc ::gridplus::gpDateSelectorClear {name key} { - - if {$key eq "Delete"} { - gpset $name {} - } -} - -#=======================================================================# -# PROC : ::gridplus::gpDateSelectorKeyPress # -# PURPOSE: Date Selector key press post/unpost # -#=======================================================================# - -proc ::gridplus::gpDateSelectorKeyPress {name widget action} { - - if {$action eq "post" && ! [$name instate pressed]} { - ::gridplus::gpDateSelectorPost $name - return -code break - } elseif {$action eq "unpost" && [$name instate pressed]} { - if {! [string match .gpDateSelector.calendar.* $widget]} { - ::gridplus::gpDateSelectorUnpost - } - } else { - return -code break - } -} - -#=======================================================================# -# PROC : ::gridplus::gpDateSelectorPost # -# PURPOSE: Post Date Selector dropdown/popup. # -#=======================================================================# - -proc ::gridplus::gpDateSelectorPost {name} { - - global {} - - variable gpInfo - - $name instate disabled {return} - - $name state pressed - - set widgetX [winfo rootx $name] - set widgetY [winfo rooty $name] - set widgetWidth [winfo width $name] - set widgetHeight [winfo height $name] - - gridplus window .gpDateSelector -overrideredirect 1 -topmost 1 - - wm transient .gpDateSelector [winfo toplevel $name] - - bind .gpDateSelector "::gridplus::gpDateSelectorToggle $name %W" - - gridplus calendar .gpDateSelector.calendar \ - -command "::gridplus::gpDateSelectorUnpost;$gpInfo($name:datecommand)" \ - -date $($name) \ - -padding 2 \ - -relief solid \ - -selecttoday 1 \ - -variable $name - - pack .gpDateSelector.calendar - - update idletasks - - set calendarWidth [winfo reqwidth .gpDateSelector] - - if {[tk windowingsystem] eq "aqua"} { - # Adjust for platform-specific bordering to ensure the box is - # directly under actual 'entry square' - set xOffset 3 - set yOffset 2 - incr widgetX $xOffset - set widgetWidth [expr {$widgetWidth - $xOffset*2}] - } else { - set yOffset 0 - } - - set calendarHeight [winfo reqheight .gpDateSelector] - - # Added "+ 40" to take into account windows task bar. - if {$widgetY + $widgetHeight + $calendarHeight + 40 > [winfo screenheight .gpDateSelector]} { - set Y [expr {$widgetY - $calendarHeight - $yOffset}] - } else { - set Y [expr {$widgetY + $widgetHeight - $yOffset}] - } - - set X [expr {$widgetX - ($calendarWidth - $widgetWidth)}] - - if {$X < 0} { - set X $widgetX - } - - wm geometry .gpDateSelector +${X}+${Y} - wm deiconify .gpDateSelector - raise .gpDateSelector - - ttk::globalGrab .gpDateSelector - - focus .gpDateSelector.calendar - bind .gpDateSelector.calendar "::gridplus::gpDateSelectorKeyPress $name %W unpost" -} - -#=======================================================================# -# PROC : ::gridplus::gpDateSelectorToggle # -# PURPOSE: Toggle Date Selector dropdown/popup. # -#=======================================================================# - -proc ::gridplus::gpDateSelectorToggle {name widget} { - - if {[$name instate pressed]} { - if {! [string match .gpDateSelector.calendar.* $widget]} { - ::gridplus::gpDateSelectorUnpost - } - } else { - ::gridplus::gpDateSelectorPost $name - return -code break - } -} - -#=======================================================================# -# PROC : ::gridplus::gpDateSelectorUnpost # -# PURPOSE: Unpost Date Selector dropdown/popup. # -#=======================================================================# - -proc ::gridplus::gpDateSelectorUnpost {{testWindow {}}} { - - variable gpInfo - - if {[winfo exists .gpDateSelector.calendar] && $testWindow ne ".gpDateSelector"} { - foreach dateSelector [array names gpInfo *:datecommand] { - set name [lindex [split $dateSelector :] 0] - if {[$name instate pressed]} { - $name state !pressed - - ttk::releaseGrab .gpDateSelector - - gridplus clear .gpDateSelector - destroy .gpDateSelector - - update idletasks - ttk::combobox::Unpost $name - - focus $name - } - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpDefine # -# PURPOSE: Creates GRIDPLUS widget definitions. # -#=======================================================================# - -proc ::gridplus::gpDefine {} { - upvar 1 options options - - variable gpInfo - - foreach {id widget} $options(layout) { - set gpInfo(:$id) $widget - } -} - -#=======================================================================# -# PROC : ::gridplus::gpDefineWidget # -# PURPOSE: Process "defined" widget. # -#=======================================================================# - -proc ::gridplus::gpDefineWidget {column} { - - variable gpInfo - - if {[string match @* $column]} { - if {[winfo exists .[string range [lindex $column 0] 1 end]]} { - return $column - } - set defineID [string range [lindex $column 0] 1 end] - if {[info exists gpInfo(:$defineID)]} { - set defineWidget $gpInfo(:$defineID) - set replacementID 1 - - foreach replacement [lrange $column 1 end] { - regsub -- "%$replacementID" $defineWidget $replacement defineWidget - incr replacementID - } - } - return [::gridplus::gpDefineWidget $defineWidget] - } else { - return $column - } -} - -#=======================================================================# -# PROC : ::gridplus::gpEditMenu # -# PURPOSE: Pop-up menu for entry widgets. # -#=======================================================================# - -proc ::gridplus::gpEditMenu {mode} { - - set widget [focus] - - switch -- $mode { - cut { - clipboard clear - clipboard append [selection get] - $widget delete sel.first sel.last - } - copy { - clipboard clear - clipboard append [selection get] - } - paste { - $widget selection clear - $widget insert insert [clipboard get] - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpEditMenuCreate # -# PURPOSE: Create pop-up menu for entry widgets. # -#=======================================================================# - -proc ::gridplus::gpEditMenuCreate {window} { - - menu $window.gpEditMenu - - $window.gpEditMenu configure -tearoff 0 - - $window.gpEditMenu add command -label [mc "Cut"] -command "::gridplus::gpEditMenu cut" - $window.gpEditMenu add command -label [mc "Copy"] -command "::gridplus::gpEditMenu copy" - $window.gpEditMenu add command -label [mc "Paste"] -command "::gridplus::gpEditMenu paste" -} - -#=======================================================================# -# PROC : ::gridplus::gpEntryEdit # -# PURPOSE: Pop-up menu for entry widgets. # -#=======================================================================# - -proc ::gridplus::gpEntryEdit {editWindow X Y {variable {}}} { - - focus [winfo containing $X $Y] - - after 1 "::gridplus::gpEntryEditPost \{$editWindow\} $X $Y \{$variable\}" -} - -#=======================================================================# -# PROC : ::gridplus::gpEntryEditPost # -# PURPOSE: Post Pop-up menu for entry widgets. # -#=======================================================================# - -proc ::gridplus::gpEntryEditPost {editWindow X Y {variable {}}} { - - global {} - - variable gpInfo - - set widget [winfo containing $X $Y] - - if {[info exists gpInfo(validation:failed)] && $gpInfo(validation:failed) ne $widget} { - return - } - - if {$variable eq ""} { - set variable $widget - } - - if {$editWindow eq ""} { - set window {} - } else { - set window .$editWindow - } - - if {! [$widget selection present]} { - $widget selection range 0 end - } - - if {[$widget cget -state] ne "normal"} { - $window.gpEditMenu entryconfigure 0 -state disabled - $window.gpEditMenu entryconfigure 1 -state normal - $window.gpEditMenu entryconfigure 2 -state disabled - } else { - $window.gpEditMenu entryconfigure 0 -state normal - $window.gpEditMenu entryconfigure 1 -state normal - $window.gpEditMenu entryconfigure 2 -state normal - } - - if {$($variable) eq ""} { - $window.gpEditMenu entryconfigure 0 -state disabled - $window.gpEditMenu entryconfigure 1 -state disabled - } - - if {[$widget cget -state] ne "disabled"} { - $window.gpEditMenu post $X $Y - } -} - -#=======================================================================# -# PROC : ::gridplus::gpGetFontOption # -# PURPOSE: Get font option for specified font. # -#=======================================================================# - -proc ::gridplus::gpGetFontOption {font option} { - - foreach {fontOption value} [font configure $font] { - if {$fontOption eq $option} { - return $value - } - } - - return {} -} - -#=======================================================================# -# PROC : ::gridplus::gpGetFontSize # -# PURPOSE: Get font size for specified font. # -#=======================================================================# - -proc ::gridplus::gpGetFontSize {font} { - - if {[llength $font] == 1} { - return [::gridplus::gpGetFontOption $font -size] - } else { - return [lindex $font 1] - } -} - -#=======================================================================# -# PROC : ::gridplus::gpGoto # -# PURPOSE: Move text widget display to specified label. # -#=======================================================================# - -proc ::gridplus::gpGoto {} { - upvar 1 options options - - global {} - - $options(name).text yview $options(layout) - - set ($options(name)) $options(layout) -} - -#=======================================================================# -# PROC : ::gridplus::gpGrid # -# PURPOSE: Create grid. # -#=======================================================================# - -proc ::gridplus::gpGrid {} { - upvar 1 options options - - global {} - - variable gpInfo - variable gpTabOrder - - set options(-columnformat) [::gridplus::gpOptionAlias -columnformat -cfmt] - - set labelColor(1) [lindex [split $options(-labelcolor) /] 0] - set labelColor(2) [lindex [split $options(-labelcolor) /] 1] - set labelStyle(1) [lindex [split $options(-labelstyle) /] 0] - set labelStyle(2) [lindex [split $options(-labelstyle) /] 1] - - regsub -all -- {,} $labelStyle(1) { } labelStyle(1) - regsub -all -- {,} $labelStyle(2) { } labelStyle(2) - - if {[string match *w* $options(-attach)]} { - set leftStretch 0 - set rightStretch 1 - set defaultStretch 0 - } else { - set leftStretch 0 - set rightStretch 0 - set defaultStretch 1 - } - - if {[llength $options(-spacestretch)] == 1} { - set options(-spacestretch) [lrepeat 100 $options(-spacestretch)] - } - - set attachNS 0 - - if {[string match *n* $options(-attach)]} { - set weightY 0 - if {[string match *s* $options(-attach)]} { - set attachNS 1 - } - } else { - set weightY 1 - } - - ::gridplus::gpLabelframe - - grid anchor $options(name) $options(-anchor) - - set rowID 0 - set rowTotal [llength [split $options(layout) "\n"]] - set rowCount 1 - - if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { - set window {} - } - - if {$options(-subst)} { - if {[=< substCommandGrid [=< substCommand 0]]} { - set options(layout) [subst -nobackslashes $options(layout)] - } else { - set options(layout) [subst -nobackslashes -nocommands $options(layout)] - } - } - - foreach row [split $options(layout) "\n"] { - set columnID 0 - set columnTotal [llength $row] - set columnCount 1 - set rowWeight1 0 - - if {$options(-spacestretch) eq ""} { - if {$columnTotal > 1} { - set stretch "$leftStretch [lrepeat [expr {$columnTotal - 1}] $defaultStretch] $rightStretch" - } else { - set stretch "$leftStretch $rightStretch" - } - } else { - set stretch $options(-spacestretch) - } - - ::ttk::frame $options(name).space:$rowID:$columnID -width 0 - grid $options(name).space:$rowID:$columnID -column $columnID -row $rowID -sticky ew - grid columnconfigure $options(name) $columnID -weight [lindex $stretch 0] - incr columnID - - foreach column $row { - switch -- [llength $column] { - 0 { - set columnSpan 2 - set column "{}" - } - 1 { - set columnSpan 2 - } - 2 { - set columnSpan 1 - } - default { - error "GRIDPLUS ERROR: Too many items in column." - } - } - - set columnItem 1 - set formatWidth(1) 0 - set formatWidth(2) 0 - - if {[set columnFormat [lindex $options(-columnformat) [expr {$columnCount - 1}]]] ne ""} { - if {[lindex [split $columnFormat "/"] 0] ne ""} { - set formatWidth(1) [lindex [split $columnFormat "/"] 0] - set formatWidth(2) [lindex [split $columnFormat "/"] 1] - } - if {$formatWidth(1) eq ""} {set formatWidth(1) 0} - if {$formatWidth(2) eq ""} {set formatWidth(2) 0} - } - - foreach item $column { - set bold 0 - set command {} - set labelFont $labelStyle($columnItem) - set labelIcon {} - set labelWidth 0 - set sticky {} - set validate 0 - - if {! [string match "*: " $item]} { - regexp {(^[^:]+)(:(([nsewc]+)?([0-9]+)?$)?)} $item -> item - - sticky labelWidth - } - - if {$labelWidth eq ""} {set labelWidth 0} - - switch -- $sticky { - c {set sticky {}} - "" {set sticky w} - } - - if {[string match "*n*" $sticky] && [string match "*s*" $sticky]} { - set rowWeight1 1 - } - - switch -glob -- $item { - .* { - set itemName $item - ::ttk::frame $options(name).widget:$rowID:$columnID - ::ttk::frame $options(name).widget:$rowID:$columnID.width -height 0 -width [expr {$formatWidth($columnItem) * $gpInfo()}] - - if {! [winfo exists $item]} { - set itemName $options(name),[string range $item 1 end] - - if {$options(-basename) ne ""} { - set textVariable $options(-basename),[string range $item 1 end] - } else { - set textVariable $itemName - } - ::ttk::label $itemName -foreground $labelColor($columnItem) -justify $options(-justify) -wraplength $options(-wraplength) -textvariable ($textVariable) - if {$labelFont ne ""} { - $itemName configure -font [::gridplus::gpSetFont $labelFont] - } - } - - grid $options(name).widget:$rowID:$columnID.width -row 0 -column 0 - grid $itemName -in $options(name).widget:$rowID:$columnID -row 1 -column 0 -sticky $sticky - grid configure $options(name).widget:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky $sticky - grid columnconfigure $options(name).widget:$rowID:$columnID 0 -weight 1 - - if {$rowWeight1} { - grid rowconfigure $options(name) $rowID -weight 1 - grid rowconfigure $options(name).widget:$rowID:$columnID 1 -weight 1 - } - - if {$options(-taborder) eq "column"} { - set gpTabOrder([format "%s:%03d%03d%03d" $options(name) $columnCount $rowCount $columnItem]) $itemName - } else { - set gpTabOrder([format "%s:%03d%03d%03d" $options(name) $rowCount $columnCount $columnItem]) $itemName - } - } - | { - ::ttk::separator $options(name).separator:$rowID:$columnID -orient vertical - grid configure $options(name).separator:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky ns - } - = { - ::ttk::separator $options(name).separator:$rowID:$columnID -orient horizontal - grid configure $options(name).separator:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky ew - } - :* { - if {! [regexp -- {^:([^:]*):([^:]*):([^:]*)$} $item -> labelIcon command validate]} { - set labelIcon [string range $item 1 end] - regsub -- {%%$} $labelIcon {} labelIcon - } - if {$labelIcon eq ""} { - set labelIcon $options(-icon) - } - ::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $labelIcon - ::ttk::label $options(name).label:$rowID:$columnID -image ::icon::$labelIcon - grid configure $options(name).label:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky $sticky - if {$command ne ""} { - if {$options(-proc)} { - set command "set gridplus::gpInfo() \[focus\];gpProc $command" - } else { - set command "set gridplus::gpInfo() \[focus\];$options(-prefix)$command" - regsub -all {[.]} $command ":" command - regsub {;:} $command ";" command - } - - bind $options(name).label:$rowID:$columnID "eval \"::gridplus::gpCommand {$command} .$window $validate\"" - } - } - default { - if {[string match ^* $item]} { - set labelFont "$labelFont bold" - set item [string range $item 1 end] - } - regsub -all -- " +\n +" $item "\n" item - regsub -all -- "" $item "\n" item - - if {$labelWidth == 0} { - set labelWidth $formatWidth($columnItem) - } - - ::ttk::frame $options(name).label:$rowID:$columnID - ::ttk::frame $options(name).label:$rowID:$columnID.width -height 0 -width [expr {$labelWidth * $gpInfo()}] - ::ttk::label $options(name).label:$rowID:$columnID.text -foreground $labelColor($columnItem) -style $options(-style) -justify $options(-justify) -wraplength $options(-wraplength) -text [mc $item] - if {$labelFont ne ""} { - $options(name).label:$rowID:$columnID.text configure -font [::gridplus::gpSetFont $labelFont] - } - grid $options(name).label:$rowID:$columnID.width -row 0 -column 0 - grid $options(name).label:$rowID:$columnID.text -in $options(name).label:$rowID:$columnID -row 1 -column 0 -sticky $sticky - grid configure $options(name).label:$rowID:$columnID -in $options(name) -column $columnID -row $rowID -columnspan $columnSpan -sticky $sticky - grid columnconfigure $options(name).label:$rowID:$columnID 0 -weight 1 - } - } - incr columnID $columnSpan - incr columnItem - } - - if {$columnCount != $columnTotal} { - ::ttk::frame $options(name).space:$rowID:$columnID -width $options(-space) - grid $options(name).space:$rowID:$columnID -column $columnID -row $rowID -sticky ew - grid columnconfigure $options(name) $columnID -weight [lindex $stretch $columnCount] - incr columnID - } else { - ::ttk::frame $options(name).space:$rowID:$columnID -width 0 - grid $options(name).space:$rowID:$columnID -column $columnID -row $rowID -sticky ew - grid columnconfigure $options(name) $columnID -weight [lindex $stretch $columnCount] - } - - incr columnCount - } - - incr rowID - - if {$rowCount != $rowTotal} { - ::ttk::frame $options(name).space:$rowID:$columnID -height 4 -width 4 - grid $options(name).space:$rowID:$columnID -row $rowID -column 0 -sticky ns -columnspan 3 - grid rowconfigure $options(name) $rowID -weight $weightY - incr rowID - } elseif {! $weightY && ! $attachNS} { - ::ttk::frame $options(name).space:$rowID:$columnID -height 4 -width 4 - grid $options(name).space:$rowID:$columnID -row $rowID -column 0 -sticky ns -columnspan 3 - grid rowconfigure $options(name) $rowID -weight 1 - } - - incr rowCount - } - - foreach stretch $options(-stretch) { - grid columnconfigure $options(name) [expr {(($stretch + 1) * 3) - 1}] -weight 1 - } - - gpSetTabOrder $options(name) - - if {$options(-wtitle) ne ""} { - wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] - } -} - -#=======================================================================# -# PROC : ::gridplus::gpInit # -# PURPOSE: Gridplus initailise. # -#=======================================================================# - -proc ::gridplus::gpInit {} { - variable gpConfig - variable gpInfo - variable gpOptionSets - variable gpValidation - - wm resizable . 0 0 - - set gpInfo(.:toplevel) 1 - set gpInfo(.:modal) 0 - set gpInfo() {} - - ttk::label .gpWidthFactor -width 1 - set gpInfo() [winfo reqwidth .gpWidthFactor] - destroy .gpWidthFactor - - if {[namespace exists "::starkit"]} { - set iconPath [file join $::starkit::topdir lib] - } else { - set iconPath [file join [info library]] - } - - array set gpConfig [list \ - dateformat [=< dateFormat us] \ - errormessage [=< errorMessage %] \ - iconfile [=< iconFile tkIcons] \ - iconpath [=< iconPath $iconPath] \ - locale [=< locale] \ - prefix [=< prefix] \ - proc [=< proc 0] \ - ] - - switch -- $gpConfig(dateformat) { - eu { - set gpConfig(date:day) 0 - set gpConfig(date:month) 1 - set gpConfig(date:year) 2 - set gpConfig(date:separator) . - } - iso { - set gpConfig(date:day) 2 - set gpConfig(date:month) 1 - set gpConfig(date:year) 0 - set gpConfig(date:separator) - - } - uk { - set gpConfig(date:day) 0 - set gpConfig(date:month) 1 - set gpConfig(date:year) 2 - set gpConfig(date:separator) / - } - us { - set gpConfig(date:day) 1 - set gpConfig(date:month) 0 - set gpConfig(date:year) 2 - set gpConfig(date:separator) / - } - } - - set gpConfig(date:century) [=< century 50] - - array set gpValidation { - alpha {^[a-zA-Z]+$} - alphanum {^[a-zA-Z0-9]+$} - date {proc:gpValidateDate} - decimal {trim:^[0-9]+[.][0-9]+$} - -decimal {trim:^(-)?[0-9]+[.][0-9]+$} - money {trim:^[0-9]+[.][0-9][0-9]$} - -money {trim:^(-)?[0-9]+[.][0-9][0-9]$} - num {trim:^[0-9]+([.][0-9]+)?$} - -num {trim:^(-)?[0-9]+([.][0-9]+)?$} - int {trim:^[0-9]+$} - -int {trim:^(-)?[0-9]+$} - notnull {[^\000]} - ! {[^\000]} - alpha:text {Alpha} - alphanum:text {Alphanumeric} - date:text {Date} - decimal:text {Decimal} - -decimal:text {Decimal} - money:text {Money Format} - -money:text {Money Format} - num:text {Numeric} - -num:text {Numeric} - int:text {Integer} - -int:text {Integer} - notnull:text {Not Null} - !:text {Non Blank} - } - - set gpOptionSets(.) { - -space 0 - -style {} - } - - ::gridplus::gpCreateIcons - - ::gridplus::gpEditMenuCreate {} - - bind . "::gridplus::gpWindowBindings . %W 1" - bind . "::gridplus::gpWindowBindings . %W 1" -} - -#=======================================================================# -# PROC : ::gridplus::gpInsertText # -# PURPOSE: Inserts "tagged" data into text widget. # -#=======================================================================# - -proc ::gridplus::gpInsertText {name tag end parameter position text} { - upvar 1 options options - - global {} - - variable gpInfo - - if {! [regexp -- {^[.]([^.]+)[.]} $name -> window]} { - set window {} - } - - set command false - set imageCommand {} - set imageInfo {} - set imageLink {} - set imageParameter {} - set link false - set bgColor $gpInfo($name:bgcolor) - set fgColor $gpInfo($name:fgcolor) - set linkColor $gpInfo($name:link) - set setCommand 0 - set validate 0 - - switch -- $end$tag { - init {set gpInfo($name:font) $gpInfo($name:defaultfont) - set gpInfo($name:size) 10 - set gpInfo($name:weight) normal - set gpInfo($name:slant) roman - set gpInfo($name:underline) false} - b {set gpInfo($name:weight) bold} - /b {set gpInfo($name:weight) normal} - bgcolor {set bgColor [lindex [split $parameter :] 0] - set bgParameter [lindex [split $parameter :] 1] - if {$bgParameter eq "default"} {set gpInfo($name:defaultbg) $bgColor} - set gpInfo($name:bgcolor) $bgColor} - /bgcolor {set bgColor $gpInfo($name:defaultbg) - set gpInfo($name:bgcolor) $gpInfo($name:defaultbg)} - color {set fgColor [lindex [split $parameter :] 0] - set fgParameter [lindex [split $parameter :] 1] - if {$fgParameter eq "default"} {set gpInfo($name:defaultfg) $fgColor} - set gpInfo($name:fgcolor) $fgColor} - /color {set fgColor $gpInfo($name:defaultfg) - set gpInfo($name:fgcolor) $gpInfo($name:defaultfg)} - command {set fgColor $gpInfo($name:normalcolor) - set gpInfo($name:underline) $gpInfo($name:normalstyle) - set command [lindex [split $parameter :] 0] - set commandParameter [lindex [split $parameter :] 1] - if {$commandParameter eq ""} {set commandParameter $text}} - font {set font [lindex [split $parameter :] 0] - set fontParameter [lindex [split $parameter :] 1] - if {$fontParameter eq "default"} {set gpInfo($name:defaultfont) $font} - set gpInfo($name:font) $font} - /font {set gpInfo($name:font) $gpInfo($name:defaultfont)} - i {set gpInfo($name:slant) italic} - /i {set gpInfo($name:slant) roman} - image {set imageInfo $parameter} - indent {set gpInfo($name:indent) $parameter - set tabs [string repeat "\t" $parameter] - set text "$tabs$text"} - /indent {set gpInfo($name:indent) 0} - label {set label [lindex [split $parameter :] 0] - set labelParameter [lindex [split $parameter :] 1] - if {$labelParameter eq "default"} {set ($name) $label} - $name.text mark set $label "insert wordstart" - $name.text mark gravity $label left} - link {set fgColor $gpInfo($name:normalcolor) - set gpInfo($name:underline) $gpInfo($name:normalstyle) - set link $parameter} - size {set size [lindex [split $parameter :] 0] - set sizeParameter [lindex [split $parameter :] 1] - if {$sizeParameter eq "default"} {set gpInfo($name:defaultsize) $size} - set gpInfo($name:size) [gridplus::gpSetFontSize $gpInfo($name:defaultsize) $size]} - /size {set gpInfo($name:size) $gpInfo($name:defaultsize)} - tab {if {$parameter eq ""} {set parameter 1} - set tabs [string repeat "\t" $parameter] - set text "$tabs$text"} - u {set gpInfo($name:underline) true} - /u {set gpInfo($name:underline) false} - } - - set tagName "tag[incr gpInfo($name:tagid)]" - set font "-family $gpInfo($name:font) -size $gpInfo($name:size) -slant $gpInfo($name:slant) -underline $gpInfo($name:underline) -weight $gpInfo($name:weight)" - set indent "[expr {$gpInfo($name:indent) * 0.5}]c" - - $name.text tag configure $tagName -lmargin1 $indent -lmargin2 $indent -background $bgColor -foreground $fgColor -font "$font" - - if {$imageInfo ne ""} { - if {[string match *@* $imageInfo]} { - set image [lindex [split $imageInfo @] 0] - set imageLink [lindex [split $imageInfo @] 1] - } else { - set image [lindex [split $imageInfo ~] 0] - set imageCommand [lindex [split [lindex [split $imageInfo ~] 1] :] 0] - set imageParameter [lindex [split [lindex [split $imageInfo ~] 1] :] 1] - - if {$imageCommand ne ""} { - set setCommand 1 - set imageCommand "$name,$imageCommand" - - if {$gpInfo($name:proc)} { - set imageCommand "set gridplus::gpInfo() \[focus\];gpProc $imageCommand" - } else { - set imageCommand "set gridplus::gpInfo() \[focus\];$gpInfo($name:prefix)$imageCommand" - regsub -all {[.]} $imageCommand ":" imageCommand - regsub {;:} $imageCommand ";" imageCommand - } - } - } - - if {[string match :* $image]} { - set icon [string range $image 1 end] - set image "::icon::$icon" - ::icons::icons create -file $gpInfo($name:iconlibrary) $icon - } - - set imageName [$name.text image create end -image $image] - - $name.text tag add $imageName $imageName - $name.text tag configure $imageName -background $bgColor - - if {$imageLink ne ""} { - $name.text tag bind $imageName "$name.text configure -cursor $gpInfo($name:linkcursor)" - $name.text tag bind $imageName "$name.text configure -cursor {}" - $name.text tag bind $imageName "set ($name) $imageLink; $name.text yview $imageLink" - } elseif {$setCommand} { - $name.text tag bind $imageName "$name.text configure -cursor $gpInfo($name:linkcursor)" - $name.text tag bind $imageName "$name.text configure -cursor {}" - $name.text tag bind $imageName "set ($name) \"$imageParameter\"; ::gridplus::gpCommand {$imageCommand} .$window $validate" - } - } - - if {$command ne "false"} { - - set command "$name,$command" - - if {$gpInfo($name:proc)} { - set command "set gridplus::gpInfo() \[focus\];gpProc $command" - } else { - set command "set gridplus::gpInfo() \[focus\];$gpInfo($name:prefix)$command" - regsub -all {[.]} $command ":" command - regsub {;:} $command ";" command - } - - $name.text tag bind $tagName "$name.text configure -cursor $gpInfo($name:linkcursor); $name.text tag configure $tagName -foreground $gpInfo($name:overcolor) -underline $gpInfo($name:overstyle)" - $name.text tag bind $tagName "$name.text configure -cursor {}; $name.text tag configure $tagName -foreground $gpInfo($name:normalcolor) -underline $gpInfo($name:normalstyle)" - $name.text tag bind $tagName "set ($name) \"$commandParameter\"; ::gridplus::gpCommand {$command} .$window $validate" - - set gpInfo($name:underline) false - } - - if {$link ne "false"} { - $name.text tag bind $tagName "$name.text configure -cursor $gpInfo($name:linkcursor); $name.text tag configure $tagName -foreground $gpInfo($name:overcolor) -underline $gpInfo($name:overstyle)" - $name.text tag bind $tagName "$name.text configure -cursor {}; $name.text tag configure $tagName -foreground $gpInfo($name:normalcolor) -underline $gpInfo($name:normalstyle)" - $name.text tag bind $tagName "set ($name) $link; $name.text yview $link" - set gpInfo($name:underline) false - } - - if {$text ne ""} { - regsub -all {!b:} $text "\u2022" text - regsub -all {!ob:} $text \{ text - regsub -all {!cb:} $text \} text - regsub -all {!bs:} $text {\\} text - regsub -all {!lt:} $text {<} text - regsub -all {!gt:} $text {>} text - $name.text insert $position $text $tagName - } -} - -#=======================================================================# -# PROC : ::gridplus::gpLabelframe # -# PURPOSE: Implements work-around to deal with ttk::labelframe bug. # -#=======================================================================# - -proc ::gridplus::gpLabelframe {} { - upvar 1 options options - - if {$options(-relief) eq "theme"} { - if {$options(-title) eq ""} { - ::ttk::labelframe $options(name) -padding $options(-padding) - ::ttk::separator $options(name).separator -orient horizontal - $options(name) configure -labelwidget $options(name).separator -labelanchor s - } else { - if {$options(-labelanchor) eq ""} { - ::ttk::labelframe $options(name) -padding $options(-padding) -text [mc $options(-title)] - } else { - ::ttk::labelframe $options(name) -labelanchor $options(-labelanchor) -padding $options(-padding) -text [mc $options(-title)] - } - } - } else { - ::ttk::frame $options(name) -padding $options(-padding) -relief $options(-relief) - } -} - -#=======================================================================# -# PROC : ::gridplus::gpLayout # -# PURPOSE: Create layout. # -#=======================================================================# - -proc ::gridplus::gpLayout {} { - upvar 1 options options - - global {} - - variable gpTabOrder - - set rowCount 0 - set layout(items) {} - set toplevel {} - - set setWeights 0 - set columnWeight1 {} - set rowWeight1 {} - - set maxColumn 0 - set maxRow 0 - - if {$options(-subst)} { - if {[=< substCommandLayout [=< substCommand 0]]} { - set options(layout) [subst -nobackslashes $options(layout)] - } else { - set options(layout) [subst -nobackslashes -nocommands $options(layout)] - } - } - - foreach row [split $options(layout) "\n"] { - set columnCount 0 - set rowIncr 1 - foreach column $row { - set columnIncr 1 - set setXweight 0 - set setYweight 0 - set sticky {} - - if {$column eq "="} {set column ".="} - if {$column eq "|"} {set column ".|"} - - regexp -- {(^[^:]+)(:([nsewc]+$)?)} $column -> column -> sticky - - if {[regexp -- {(^[.][^|]+)([|]([nsewc]+$)?)} $column -> column -> sticky]} { - set setXweight 1 - } - if {[regexp -- {(^[.][^=]+)([=]([nsewc]+$)?)} $column -> column -> sticky]} { - set setYweight 1 - } - if {[regexp -- {(^[.][^+]+)([+]([nsewc]+$)?)} $column -> column -> sticky]} { - set setXweight 1 - set setYweight 1 - } - - set layout($column:xweight) 1 - set layout($column:yweight) 1 - - if {$setXweight} {set layout($column:xweight) 0} - if {$setYweight} {set layout($column:yweight) 0} - - switch -- $sticky { - c {set sticky {}} - "" {set sticky w} - } - switch -glob -- $column { - .* { - if {$column eq ".="} { - ::ttk::separator $options(name):line:$columnCount:$rowCount -orient horizontal - set sticky "nsew" - set column $options(name):line:$columnCount:$rowCount - set layout($column:yweight) 0 - } - if {$column eq ".|"} { - ::ttk::separator $options(name):line:$columnCount:$rowCount -orient vertical - set sticky "nsew" - set column $options(name):line:$columnCount:$rowCount - set layout($column:xweight) 0 - } - set column [regsub -all -- {%} $column [string range $options(name) 1 end]] - lappend layout(items) $column - set layout(cell:$columnCount,$rowCount) $column - set layout($column:x) $columnCount - set layout($column:y) $rowCount - set layout($column:xspan) 1 - set layout($column:yspan) 1 - set layout($column:sticky) $sticky - if {$options(-taborder) eq "column"} { - set gpTabOrder([format "%s:%03d%03d001" $options(name) $columnCount $rowCount]) $column - } else { - set gpTabOrder([format "%s:%03d%03d001" $options(name) $rowCount $columnCount]) $column - } - } - - { - if {$columnCount == 0} {error "GRIDPLUS ERROR (layout): Column span not valid in first column"} - set previousColumn [expr {$columnCount - 1}] - set cell $layout(cell:$previousColumn,$rowCount) - set layout(cell:$columnCount,$rowCount) $layout(cell:$previousColumn,$rowCount) - incr layout($cell:xspan) - } - ^ { - if {$rowCount == 0} {error "GRIDPLUS ERROR (layout): Row span not valid in first row"} - set previousRow [expr {$rowCount - 1}] - set previousCell [expr {$columnCount - 1}] - set cell $layout(cell:$columnCount,$previousRow) - set layout(cell:$columnCount,$rowCount) $layout(cell:$columnCount,$previousRow) - if {! ([info exists layout(cell:$previousCell,$rowCount)] && $layout(cell:$previousCell,$rowCount) eq $cell)} { - incr layout($cell:yspan) - } - } - x { - } - > { - set setWeights 1 - set columnIncr 0 - lappend rowWeight1 $rowCount - } - v { - set setWeights 1 - set rowIncr 0 - lappend columnWeight1 $columnCount - } - ~ { - set setWeights 1 - } - default { - error "GRIDPLUS ERROR (layout): Invalid item/option ($column)" - } - } - if {$columnCount > $maxColumn} {set maxColumn $columnCount} - incr columnCount $columnIncr - } - if {$rowCount > $maxRow} {set maxRow $rowCount} - incr rowCount $rowIncr - } - - if {$options(-wtitle) ne "" && [regexp {([.][^.]*)[.].+$} $options(name) -> window]} { - wm title $window [mc $options(-wtitle)] - } - - ::gridplus::gpLabelframe - - foreach item $layout(items) { - set padxLeft $options(-padx) - set padxRight $options(-padx) - - if {$layout($item:x) == 0} { - set padxLeft 0 - } - if {[expr {$layout($item:x) + $layout($item:xspan)}] == $columnCount} { - set padxRight 0 - } - - set padyTop $options(-pady) - set padyBottom $options(-pady) - - if {$layout($item:y) == 0} { - set padyTop 0 - } - if {[expr {$layout($item:y) + $layout($item:yspan)}] == $rowCount} { - set padyBottom 0 - } - - set padx [list $padxLeft $padxRight] - set pady [list $padyTop $padyBottom] - - grid configure $item -in $options(name) -column $layout($item:x) -row $layout($item:y) -columnspan $layout($item:xspan) -rowspan $layout($item:yspan) -sticky $layout($item:sticky) -padx $padx -pady $pady - - if {[info exists layout($item:xweight)]} { - set xweight $layout($item:xweight) - } else { - set xweight 1 - } - if {[info exists layout($item:yweight)]} { - set yweight $layout($item:yweight) - } else { - set yweight 1 - } - - grid columnconfigure $options(name) $layout($item:x) -weight $xweight - grid rowconfigure $options(name) $layout($item:y) -weight $yweight - gpSetTabOrder $options(name) - } - - if {$setWeights} { - for {set rowCount 0} {$rowCount <= $maxRow} {incr rowCount} { - if {[lsearch $rowWeight1 $rowCount] > -1} { - grid rowconfigure $options(name) $rowCount -weight 1 - } else { - grid rowconfigure $options(name) $rowCount -weight 0 - } - } - - for {set columnCount 0} {$columnCount <= $maxColumn} {incr columnCount} { - if {[lsearch $columnWeight1 $columnCount] > -1} { - grid columnconfigure $options(name) $columnCount -weight 1 - } else { - grid columnconfigure $options(name) $columnCount -weight 0 - } - } - } - - if {$options(-wtitle) ne ""} { - wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] - } -} - -#=======================================================================# -# PROC : ::gridplus::gpLine # -# PURPOSE: Gridplus create line. # -#=======================================================================# - -proc ::gridplus::gpLine {} { - upvar 1 options options - - if {$options(-background) eq ""} { - set background [. cget -background] - } else { - set background $options(-background) - } - - if {$options(-title) ne ""} { - frame $options(name) -background $background -padx $options(-padx) -pady $options(-pady) - frame $options(name).left -background $background -borderwidth 2 -height 2 -relief sunken -width 5 - frame $options(name).right -background $background -borderwidth 2 -height 2 -relief sunken - label $options(name).label -background $background -text [mc $options(-title)] -borderwidth 1 - grid configure $options(name).left -column 0 -row 0 -sticky ew - grid configure $options(name).label -column 1 -row 0 - grid configure $options(name).right -column 2 -row 0 -sticky ew - grid columnconfigure $options(name) 2 -weight 1 - } else { - frame $options(name) -background $background -borderwidth $options(-borderwidth) -height $options(-linewidth) -padx $options(-padx) -pady $options(-pady) -relief $options(-linerelief) -width $options(-linewidth) - } -} - -#=======================================================================# -# PROC : ::gridplus::gpMenu # -# PURPOSE: Create menu(bar). # -#=======================================================================# - -proc ::gridplus::gpMenu {} { - upvar 1 options options - - if {$options(name) eq "."} { - set rootMenu .menubar - $options(name) configure -menu $rootMenu - } elseif {[winfo exists $options(name)] && [winfo class $options(name)] eq "Toplevel"} { - set rootMenu $options(name).menubar - $options(name) configure -menu $rootMenu - } else { - set rootMenu $options(name) - } - - menu $rootMenu - - $rootMenu configure -tearoff 0 - - set rootMenuIndex 0 - - foreach {menuLabel menuEntries} $options(layout) { - set underline [string first "_" $menuLabel] - regsub -all -- {_} $menuLabel {} menuLabel - - if {$menuLabel eq "~"} { - ::gridplus::gpMenuOption $rootMenu {} $rootMenuIndex $menuEntries - incr rootMenuIndex - continue - } - - if {[string match @* $menuEntries]} { - set cascade ".[string range $menuEntries 1 end]" - $rootMenu add cascade -label [mc $menuLabel] -menu $cascade -underline $underline - continue - } - - set menu [string tolower $menuLabel] - - $rootMenu add cascade -label [mc $menuLabel] -menu $rootMenu.$menu -underline $underline - menu $rootMenu.$menu - $rootMenu.$menu configure -tearoff 0 - - set menuIndex 0 - - foreach menuEntryData $menuEntries { - ::gridplus::gpMenuOption $rootMenu $menu $menuIndex $menuEntryData - incr menuIndex - } - - incr rootMenuIndex - } - -} - -#=======================================================================# -# PROC : ::gridplus::gpMenuOption # -# PURPOSE: Create menu(bar) option. # -#=======================================================================# - -proc ::gridplus::gpMenuOption {rootMenu menu menuIndex menuEntryData} { - upvar 1 options options - - variable gpInfo - - set menuEntryLabel [lindex $menuEntryData 0] - set menuEntryOptions [lrange $menuEntryData 1 end] - set underline [string first "_" $menuEntryLabel] - - regsub -all -- {_} $menuEntryLabel {} menuEntryLabel - - set menuEntry [string tolower $menuEntryLabel] - - regsub -all -- { } $menuEntry {_} menuEntry - - if {$menuEntry eq "-" || $menuEntry eq "="} { - if {$menu eq ""} { - $rootMenu add separator - } else { - $rootMenu.$menu add separator - } - } else { - if {$menu eq ""} { - set command $rootMenu,$menuEntry - set menuEntryID $rootMenu@$menuIndex - set menuName {} - } else { - set command $rootMenu:$menu,$menuEntry - set menuEntryID $rootMenu.$menu@$menuIndex - set menuName .$menu - } - set cascade {} - set compound none - set menuIcon {} - set state $options(-state) - set validate 0 - - foreach item $menuEntryOptions { - switch -regexp -- $item { - ^% { - set gpInfo($menuEntryID:group) [string range $item 1 end] - } - ^<$ { - set state disabled - } - ^>$ { - set state normal - } - ^!$ { - set validate 1 - } - ^@ { - set cascade ".[string range $item 1 end]" - } - ^[.~].+ { - set command [string range $item 1 end] - } - ^: { - set menuIcon "::icon::[::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] [string range $item 1 end]]" - set compound left - } - } - } - - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $command]" - } else { - set command "$options(-prefix)[::gridplus::gpCommandFormat $command]" - } - - set state [=% $menuEntryID $state] - - if {$cascade ne ""} { - $rootMenu$menuName add cascade -label [mc $menuEntryLabel] -menu $cascade -state $state -compound $compound -image $menuIcon -underline $underline - } else { - $rootMenu$menuName add command -label [mc $menuEntryLabel] -command "::gridplus::gpCommand {$command} $options(name) $validate" -state $state -compound $compound -image $menuIcon -underline $underline - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpNotebook # -# : ::gridplus::gpNotebookSet # -# PURPOSE: Create notebook. # -#=======================================================================# - -proc ::gridplus::gpNotebook {} { - upvar 1 options options - - global {} - - variable gpTabOrder - - if {$options(-subst)} { - if {[=< substCommandNotebook [=< substCommand 0]]} { - set options(layout) [subst -nobackslashes $options(layout)] - } else { - set options(layout) [subst -nobackslashes -nocommands $options(layout)] - } - } - - ::ttk::notebook $options(name) -padding $options(-padding) - - if {$options(-command) ne ""} { - set command "$options(-command) \[$options(name) index current\] \[$options(name) tab \[$options(name) index current\] -text\];" - } else { - set command "" - } - - bind $options(name) <> "${command}::gridplus::gpNotebookSet $options(name)" - - foreach {tab item} $options(layout) { - set pane [winfo name $item] - $options(name) add [::ttk::frame $options(name).$pane -padding $options(-tabpadding)] -text [mc $tab] - pack $item -in $options(name).$pane -expand 1 -fill both - } - - ::gridplus::gpNotebookSet $options(name) - - if {$options(-wtitle) ne ""} { - wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] - } -} - -proc ::gridplus::gpNotebookSet {name} { - global {} - - variable gpInfo - variable gpValidations - - if {[info exists gpInfo(validation:failed)]} { - foreach windowValidations [array names ::gridplus::gpValidations] { - foreach windowValidation $windowValidations { - foreach validationInfo $::gridplus::gpValidations($windowValidation) { - foreach {entry validation} [split $validationInfo :] {} - if {[info exists gpInfo(validation:failed)] && $gpInfo(validation:failed) eq $entry} { - if {! [::gridplus::gpValidate $entry $validation focusout - - 1]} { - ::gridplus::gpValidateFailed $entry - } - } - } - } - } - - if {[info exists gpInfo(validation:failed)]} { - ::gridplus::gpNotebookIn $gpInfo(validation:failed) - return - } - } - - variable gpTabOrder - - set pane [$name index current] - set panes [$name tabs] - - #!FIX - # regsub -all .[winfo name $name] [lindex $panes $pane] {} item - regsub .[winfo name $name] [lindex $panes $pane] {} item - - set gpTabOrder($name:000000) $item - - gpSetTabOrder $name -} - -#=======================================================================# -# PROC : ::gridplus::gpOptionAlias # -# PURPOSE: Set value for option with "alias". # -#=======================================================================# - -proc ::gridplus::gpOptionAlias {option alias} { - upvar 1 options options - - if {$options($option) ne ""} {return $options($option)} - if {$options($alias) ne ""} {return $options($alias)} - - return {} -} - -#=======================================================================# -# PROC : ::gridplus::gpOptionset # -# PURPOSE: Create optionset. # -#=======================================================================# - -proc ::gridplus::gpOptionset {} { - upvar 1 options options - - variable gpOptionSets - - set gpOptionSets($options(name)) $options(layout) - - if {[lsearch $gpOptionSets($options(name)) -style] < 0 && [=< optionsetDefaultStyle 0]} { - lappend gpOptionSets($options(name)) -style {} - } -} - -#=======================================================================# -# PROC : ::gridplus::gpPack # -# PURPOSE: Pack specified layout where resizing is required. # -#=======================================================================# - -proc ::gridplus::gpPack {} { - upvar 1 options options - - if {$options(-resize) eq ""} { - pack $options(name) - return - } - - if {! [regexp -- {(^[.][^.]+)[.]} $options(name) -> window]} { - set window "." - } - - set resizeX 0 - set resizeY 0 - - switch -- $options(-resize) { - x {set resizeX 1} - y {set resizeY 1} - xy {set resizeX 1; set resizeY 1} - } - - wm minsize $window 1 1 - - update idletasks - - pack $options(name) -expand 1 -fill both - - update idletasks - - regexp -- {^([0-9]+)x([0-9]+)} [wm geometry $window] -> width height - - set width [expr {int(($width / 100.0) * $options(-minx))}] - set height [expr {int(($height / 100.0) * $options(-miny))}] - - wm minsize $window $width $height - wm resizable $window $resizeX $resizeY -} - -#=======================================================================# -# PROC : ::gridplus::gpPane # -# PURPOSE: Create paned window. # -#=======================================================================# - -proc ::gridplus::gpPane {} { - upvar 1 options options - - variable gpInfo - variable gpTabOrder - - ::gridplus::gpLabelframe - - if {[llength [lindex [split $options(layout) "\n"] 0]] > 1} { - set orient horizontal - } else { - set orient vertical - } - - set paneCount 1 - - ::ttk::panedwindow $options(name).pane -height $options(-height) -width $options(-width) -orient $orient - - foreach row [split $options(layout) "\n"] { - set columnCount 0 - - foreach column $row { - if {[regexp -- {(^[^:+|=]+)[:+|=]} $column -> column]} { - set weight 1 - } else { - set weight 0 - } - - $options(name).pane insert end $column - - $options(name).pane pane $column -weight $weight - - set gpTabOrder([format "%s:000000%03d" $options(name) $paneCount]) $column - incr paneCount - } - } - - pack $options(name).pane -expand 1 -fill both - - gpSetTabOrder $options(name) -} - -#=======================================================================# -# PROC : ::gridplus::gpParseEmbeddedGrid # -# PURPOSE: If column contains embedded grid, parse it. # -#=======================================================================# - -proc ::gridplus::gpParseEmbeddedGrid {column} { - - if {! [regexp -- {[|][|:>&<=]} $column]} {return $column} - - set left {} - set right {} - - regsub -- {[|]:[|]} $column {|: __gpBar__ |:} column - regsub -- {[|]>[|]} $column {|> __gpBar__ |:} column - regsub -- {[|]<[|]} $column {|: __gpBar__ |>} column - regsub -- {[|]=[|]} $column {|> __gpBar__ |>} column - - if {"||" in $column} { - regexp -- {^(.*)\|\|(.*)$} $column -> left right - - if {[regexp -- {[|][:>&]} $left]} { - set grid [gpEmbeddedGridParse $left] - set side left - } else { - set label $left - } - - if {[regexp -- {[|][:>&]} $right]} { - set grid [gpEmbeddedGridParse $right] - set side right - } else { - set label $right - } - } else { - set grid [gpEmbeddedGridParse $column] - set side both - } - - switch -- $side { - left {return "$grid .:ew $label"} - right {return "$grid $label .:ew"} - both {return "$grid .:ew"} - } -} - -proc ::gridplus::gpEmbeddedGridParse {grid} { - - set columns {} - set stretch {} - set defaultWidget grid - set leftStretch 0 - set rightStretch 1 - set style {} - set widgetOptions {} - - if {[regexp -- {^(.+) [|][:]$} $grid -> left]} { - set grid $left - set leftStretch 1 - set rightStretch 0 - } - - if {[regexp -- {[|][#]([^ ]*)} $grid -> style]} { - regsub -- {[|][#]([^ ]*)} $grid {} grid - if {$style eq ""} {set style %} - } - - if {[regexp -- {[|][&]([^ ]*)} $grid -> defaultWidget]} { - regsub -- {[|][&]([^ ]*)} $grid {} grid - if {$defaultWidget eq ""} {set defaultWidget "grid"} - } - - if {[regexp -- {[|][(](.*)[)]} $grid -> widgetOptions]} { - regsub -- {[|][(](.*)[)]} $grid {} grid - regsub -- {\&} $widgetOptions {\\&} widgetOptions - if {$widgetOptions ne ""} { - set newGrid {} - foreach item $grid { - set item [list $item] - if {[string match ".*" $item]} { - set item "$widgetOptions $item" - } - set newGrid "$newGrid $item" - } - set grid $newGrid - } - } - - while {[regexp -- {^([^|]*)([|][:>])(.*)$} $grid -> left op right]} { - lappend columns $left - switch -- $op { - |: {lappend stretch 0} - |> {lappend stretch 1;set rightStretch 0} - } - - set grid $right - } - - lappend columns $grid - - regsub -- {__gpBar__} $columns {|} columns - - set stretch "$leftStretch $stretch $rightStretch" - - return "{&& {$stretch} {$defaultWidget} {$style} $columns}" -} - -#=======================================================================# -# PROC : ::gridplus::gpParseTags # -# PURPOSE: Parse tags for text widget. # -#=======================================================================# - -proc ::gridplus::gpParseTags {name tagText position} { - - regsub -all \{ $tagText {!ob:} tagText - regsub -all \} $tagText {!cb:} tagText - regsub -all {\\} $tagText {!bs:} tagText - - set whitespace " \t\r\n" - set pattern <(/?)(\[^$whitespace>]+)\[$whitespace]*(\[^>]*)> - - set substitute "\}\n::gridplus::gpInsertText $name {\\2} {\\1} {\\3} $position \{" - regsub -all $pattern $tagText $substitute tagText - - eval "::gridplus::gpInsertText $name {init} {} {} $position {$tagText}" -} - -#=======================================================================# -# PROC : ::gridplus::gpSet # -# PURPOSE: Gridplus Set values. # -#=======================================================================# - -proc ::gridplus::gpSet {} { - upvar 1 options options - - variable gpConfig - variable gpInfo - variable gpValidation - - foreach option [array names options -*] { - switch -- $option { - -century { - set gpConfig(date:century) $options(-century) - } - -dateformat { - switch -- $options(-dateformat) { - eu { - set gpConfig(date:day) 0 - set gpConfig(date:month) 1 - set gpConfig(date:year) 2 - set gpConfig(date:separator) . - } - iso { - set gpConfig(date:day) 2 - set gpConfig(date:month) 1 - set gpConfig(date:year) 0 - set gpConfig(date:separator) - - } - uk { - set gpConfig(date:day) 0 - set gpConfig(date:month) 1 - set gpConfig(date:year) 2 - set gpConfig(date:separator) / - } - us { - set gpConfig(date:day) 1 - set gpConfig(date:month) 0 - set gpConfig(date:year) 2 - set gpConfig(date:separator) / - } - default { - error "GRIDPLUS ERROR: Invalid date format ($options(-dateformat))." - return - } - } - set gpConfig(dateformat) $options(-dateformat) - } - -errormessage { - set gpConfig(errormessage) $options(-errormessage) - } - -group { - set gpInfo($options(-group)) $options(-state) - ::gridplus::gpSetGroup - } - -locale { - set gpConfig(locale) $options(-locale) - } - -prefix { - set gpConfig(prefix) $options(-prefix) - } - -proc { - set gpConfig(proc) $options(-proc) - } - -validation { - if {$options(-pattern) ne ""} { - set gpValidation($options(-validation)) $options(-pattern) - if {$options(-text) ne ""} { - set gpValidation($options(-validation):text) $options(-text) - } else { - set gpValidation($options(-validation):text) $options(-validation) - } - } - - } - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpSetFont # -# PURPOSE: Gridplus Set font attributes. # -#=======================================================================# - -proc ::gridplus::gpSetFont {attributes} { - - set font [dict create {*}[font configure TkDefaultFont]] - - if {[dict get $font -size] < 0} { - set sign "-" - } else { - set sign "" - } - - foreach attribute $attributes { - switch -regexp -- $attribute { - {^[0-9]+$} { - set font [dict replace $font -size $attribute] - } - {^[+][0-9]+$} { - set font [dict replace $font -size $sign[expr {abs([dict get $font -size]) + $attribute}]] - } - {^[-][0-9]+$} { - set font [dict replace $font -size $sign[expr {abs([dict get $font -size]) - $attribute}]] - } - {^bold$} { - set font [dict replace $font -weight bold] - } - {^underline$} { - set font [dict replace $font -underline 1] - } - {^italic$} { - set font [dict replace $font -slant italic] - } - } - } - - return "[lrange $font 2 end] [lrange $font 0 1]" -} - -#=======================================================================# -# PROC : ::gridplus::gpSetFontSize # -# PURPOSE: Gridplus Set font size for "tagged" text widget. # -#=======================================================================# - -proc ::gridplus::gpSetFontSize {defaultSize newSize} { - - switch -regexp -- $newSize { - {^[0-9]+$} { - set fontSize $newSize - } - {^[+][0-9]+$} { - set value [string range $newSize 1 end] - set fontSize [expr {$defaultSize + $value}] - } - {^[-][0-9]+$} { - set value [string range $newSize 1 end] - set fontSize [expr {$defaultSize - $value}] - } - default { - set fontSize $defaultSize - } - } - - return $fontSize -} - -#=======================================================================# -# PROC : ::gridplus::gpSetGroup # -# PURPOSE: Gridplus Set widgets state to "group" state. # -#=======================================================================# - -proc ::gridplus::gpSetGroup {} { - variable gpInfo - - foreach groupItem [array names gpInfo *:group] { - set item [string map {:group {}} $groupItem] - if {[info exists gpInfo($gpInfo($item:group))]} { - if {[regexp {^([^@]+)@(.+)$} $item -> configureItem index]} { - $configureItem entryconfigure $index -state $gpInfo($gpInfo($item:group)) - } else { - if {[string match *Entry [winfo class $item]] && $gpInfo($gpInfo($item:group)) eq "disabled"} { - $item configure -state [=< entryDisabled readonly] - } elseif {[winfo class $item] in "TSpinbox TCombobox" && $gpInfo($gpInfo($item:group)) eq "normal"} { - $item configure -state readonly - } else { - $item configure -state $gpInfo($gpInfo($item:group)) - } - } - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpSetOptionset # -# PURPOSE: Set optionset options. # -#=======================================================================# - -proc ::gridplus::gpSetOptionset {} { - upvar 1 options options - - variable gpOptionSets - - if {$options(-optionset) eq ""} { - if {$options(-style) ne "" && [info exists gpOptionSets($options(-style))] && [=< optionSetStyle 1]} { - set options(-optionset) $options(-style) - } else { - return - } - } - - if {[info exists gpOptionSets($options(-optionset))]} { - foreach {option value} $gpOptionSets($options(-optionset)) { - if {$option eq "-pad"} { - set options(-padx) $value - set options(-pady) $value - } else { - set options($option) $value - } - } - } else { - error "GRIDPLUS ERROR: Invalid optionset ($options(-optionset))." - } -} - -#=======================================================================# -# PROC : ::gridplus::gpSetTabOrder # -# PURPOSE: Gridplus Set widgets to correct "tab" order. # -#=======================================================================# - -proc ::gridplus::gpSetTabOrder {name} { - variable gpTabOrder - - foreach item [lsort [array names gpTabOrder $name:*]] { - raise $gpTabOrder($item) - ::gridplus::gpSetTabOrder $gpTabOrder($item) - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelist # -# PURPOSE: Create tablelist. # -#=======================================================================# - -proc ::gridplus::gpTablelist {} { - upvar 1 options options - - global {} - - variable gpInfo - - if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { - set window {} - } - - set gpInfo($options(name):action) $options(-action) - set gpInfo($options(name):columnsort) $options(-columnsort) - set gpInfo($options(name):iconlibrary) [file join $options(-iconpath) $options(-iconfile)] - set gpInfo($options(name):insertexpr) $options(-insertexpr) - set gpInfo($options(name):insertoptions) $options(-insertoptions) - set gpInfo($options(name):maintainsort) $options(-maintainsort) - set gpInfo($options(name):selectfirst) $options(-selectfirst) - set gpInfo($options(name):selectmode) $options(-selectmode) - set gpInfo($options(name):selectpage) $options(-selectpage) - set gpInfo($options(name):sortorder) $options(-sortorder) - set gpInfo($options(name):validate) $options(-validate) - set gpInfo($options(name):window) .$window - - if {[regsub -all -- {/[^/\} ]*} $options(-insertoptions) {} gpInfo($options(name):trueOptions)]} { - regsub -all -- {[^/\} ]*/} $options(-insertoptions) {} gpInfo($options(name):falseOptions) - } else { - set gpInfo($options(name):trueOptions) $options(-insertoptions) - set gpInfo($options(name):falseOptions) {} - } - - set state $options(-state) - - if {$options(-group) ne ""} { - set gpInfo($options(name).tablelist:group) $options(-group) - } - - set state [=% $options(name).tablelist $state] - -#-------------------------------------# -# Deal with "hide" columns in layout. # -#-------------------------------------# - - set column -1 - set columnNames {} - set count 0 - set first 0 - set hide {} - set index 0 - set sortASCIInocase {} - set sortDictionary {} - set sortInteger {} - set sortReal {} - - foreach item $options(layout) { - - if {[string is integer $item]} { - set count 0 - incr column - } - - if {$item in {asciinocase dicionary hide integer real} && $count > 1} { - switch -- $item { - asciinocase {lappend sortASCIInocase $column} - dictionary {lappend sortDictionary $column} - hide {lappend hide $column} - integer {lappend sortInteger $column} - real {lappend sortReal $column} - } - set options(layout) [lreplace $options(layout) $index $index] - incr index -1 - if {$item eq "hide" && $column == $first} { - incr first - } - } - - if {[string match =* $item]} { - lappend columnNames [list $column [string range $item 1 end]] - set options(layout) [lreplace $options(layout) $index $index] - incr index -1 - } - - incr count - incr index - } - - if {$options(-sortfirst)} { - set gpInfo($options(name):firstcolumn) 0 - } else { - set gpInfo($options(name):firstcolumn) $first - } - - set gpInfo($options(name):seeinsert) $options(-seeinsert) - - ::gridplus::gpLabelframe - - tablelist::tablelist $options(name).tablelist \ - -columns $options(layout) \ - -exportselection 0 \ - -height $options(-height) \ - -listvariable $options(-listvariable) \ - -selectmode $options(-selectmode) \ - -state $state \ - -stretch all \ - -width $options(-width) \ - -xscrollcommand [list $options(name).xbar set] \ - -yscrollcommand [list $options(name).ybar set] \ - -takefocus $options(-takefocus) \ - - if {$options(-columnsort)} { - $options(name).tablelist configure -labelcommand ::gridplus::gpTablelistSort - } - - ::ttk::scrollbar $options(name).xbar -orient horizontal -command [list $options(name).tablelist xview] - ::ttk::scrollbar $options(name).ybar -orient vertical -command [list $options(name).tablelist yview] - - foreach item $hide { - $options(name).tablelist columnconfigure $item -hide 1 - } - - foreach item $sortASCIInocase { - $options(name).tablelist columnconfigure $item -sortmode "asciinocase" - } - - foreach item $sortDictionary { - $options(name).tablelist columnconfigure $item -sortmode "dictionary" - } - - foreach item $sortInteger { - $options(name).tablelist columnconfigure $item -sortmode "integer" - } - - foreach item $sortReal { - $options(name).tablelist columnconfigure $item -sortmode "real" - } - - for {set column 0} {$column < [$options(name).tablelist columncount]} {incr column} { - set columnName [string tolower [$options(name).tablelist columncget $column -title]] - regsub -all -- {[ ]+} $columnName {_} columnName - regsub -all -- {[^a-z0-9_]} $columnName {} columnName - $options(name).tablelist columnconfigure $column -name $columnName - } - - foreach item $columnNames { - $options(name).tablelist columnconfigure [lindex $item 0] -name [lindex $item 1] - } - - if {$options(-names) ne ""} { - ::gridplus::gpTablelistSetColumns $options(name) -name $options(-names) - } - - for {set column 0} {$column < [$options(name).tablelist columncount]} {incr column} { - lappend gpInfo($options(name):columnNames) [$options(name).tablelist columncget $column -name] - } - - grid $options(name).tablelist -row 0 -column 0 -sticky news - - switch -- $options(-scroll) { - x { - grid $options(name).xbar -row 1 -column 0 -sticky ew - } - y { - grid $options(name).ybar -row 0 -column 1 -sticky ns - } - xy { - grid $options(name).xbar -row 1 -column 0 -sticky ew - grid $options(name).ybar -row 0 -column 1 -sticky ns - } - } - - grid rowconfigure $options(name) 0 -weight 1 - grid columnconfigure $options(name) 0 -weight 1 - - foreach item $options(-tableoptions) { - switch -- $item { - stripe { - $options(name).tablelist configure -stripebackground #e0e8f0 - } - separator { - $options(name).tablelist configure -showseparators yes - } - } - } - - foreach unknownItem [array names gpInfo *] { - set unknownOption [string map { {}} $unknownItem] - $options(name).tablelist configure $unknownOption $gpInfo($unknownItem) - } - - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $options(name)]" - } else { - if {$options(-command) eq ""} { - set command "$options(-prefix)[::gridplus::gpCommandFormat $options(name)]" - } else { - set command $options(-command) - } - } - - set gpInfo($options(name):command) $command - - switch -- $options(-action) { - double { - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window 0]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpCommand [list $command] .$window $options(-validate)]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window 0]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window 0]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window 0]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window 0]" - } - single { - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate) [list $command]]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate) [list $command]]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate) [list $command]]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate) [list $command]]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate) [list $command]]" - } - default { - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate)]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate)]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) \[$options(name).tablelist curselection\] .$window $options(-validate)]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate)]" - bind [$options(name).tablelist bodypath] "after 1 [list ::gridplus::gpTablelistSelect $options(name) - .$window $options(-validate)]" - } - } - - if {$options(-menu) ne ""} { - bind [$options(name).tablelist bodypath] "after 1 {::gridplus::gpTablelistMenu $options(-menu) %x %y %X %Y %W $options(name)}" - } - - bind ::$options(name) "rename ::$options(name) {}" - rename ::$options(name) ::gridplus::$options(name):frame - - proc ::$options(name) {args} { - - set thisProc [lindex [info level 0] 0] - set frameProc "::gridplus::$thisProc:frame" - - if {[lindex $args 0] in "configure cget"} { - $frameProc {*}$args - } else { - ::gridplus::gpget $thisProc [lindex $args 0] - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistColumnIndex # -# PURPOSE: Returns tablelist numeric column index for column "index". # -#=======================================================================# - -proc ::gridplus::gpTablelistColumnIndex {item index caller} { - variable gpInfo - - if {[string is integer $index]} { - return $index - } else { - if {[set columnIndex [lsearch $gpInfo($item:columnNames) $index]] == -1} { - error "GRIDPLUS ERROR: ($caller) Column name \"$index\" does not exist." - } else { - return $columnIndex - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistInsert # -# PURPOSE: Inserts/updates tablelist line. # -#=======================================================================# - -proc ::gridplus::gpTablelistInsert {item position line {gpset 0} {update 0}} { - variable gpInfo - - set column 0 - set tableLine {} - - unset -nocomplain tableIcon - - foreach tableColumn $line { - if {[regexp -- {^:([^ ]+) ?} $tableColumn -> tableIcon($column)]} { - regsub -- {^:([^ ]+) ?} $tableColumn {} tableColumn - } - lappend tableLine $tableColumn - incr column - } - - if {$update} { - $item.tablelist rowconfigure $position -text $tableLine - } else { - $item.tablelist insert $position $tableLine - } - - if {[info exists tableIcon]} { - foreach iconColumn [array names tableIcon] { - set icon $tableIcon($iconColumn) - set image "::icon::$icon" - if {$image ni [image names]} {::icons::icons create -file $gpInfo($item:iconlibrary) $icon} - $item.tablelist cellconfigure $position,$iconColumn -image $image - } - } - - if {$gpInfo($item:insertexpr) ne ""} { - gpTablelistInsertExpr $item $position $line - } - - if {$gpInfo($item:seeinsert) && ! $gpset} { - update idletasks - $item.tablelist see $position - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistInsertExpr # -# PURPOSE: Expand tablelist insert expression. # -#=======================================================================# - -proc ::gridplus::gpTablelistInsertExpr {name position line} { - upvar 1 options options - - variable gpInfo - - regsub -all -- {%([a-zA-Z0-9_]+)} $gpInfo($name:insertexpr) {[lindex $line [::gridplus::gpTablelistColumnIndex $name \1 "gpTablelistInsertExpr"]]} insertExpr - - eval "if {$insertExpr} {set result 1} else {set result 0}" - - ::gridplus::gpTablelistInsertOptions $name $position $result -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistInsertOptions # -# PURPOSE: Process tablelist insert options. # -#=======================================================================# - -proc ::gridplus::gpTablelistInsertOptions {name position result} { - upvar 1 options options - - variable gpInfo - - if {$result} { - foreach insertOption $gpInfo($name:trueOptions) { - if {[lindex $insertOption 0] eq "*"} { - regsub -- {[*]} $insertOption $position insertOption - eval "$name.tablelist rowconfigure $insertOption" - } else { - eval "$name.tablelist cellconfigure $position,$insertOption" - } - } - } else { - if {$gpInfo($name:falseOptions) ne ""} { - foreach insertOption $gpInfo($name:falseOptions) { - if {[lindex $insertOption 0] eq "*"} { - regsub -- {[*]} $insertOption $position insertOption - eval "$name.tablelist rowconfigure $insertOption" - } else { - eval "$name.tablelist cellconfigure $position,$insertOption" - } - } - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistMenu # -# PURPOSE: Right-click pop-up menu for tablelist. # -#=======================================================================# - -proc ::gridplus::gpTablelistMenu {menu x y X Y W name} { - global {} - - foreach {Widget xPosition yPosition} [tablelist::convEventFields $W $x $y] {} - set row [$name.tablelist nearest $yPosition] - - $name.tablelist selection clear 0 end - $name.tablelist selection set $row - - set ($name) [$name.tablelist get $row] - - $menu post $X $Y -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistSelect # -# PURPOSE: Sets value for tablelist selections. # -#=======================================================================# - -proc ::gridplus::gpTablelistSelect {name selection window validate {command {}}} { - upvar 1 options options - - global {} - - variable gpInfo - - if {$selection eq "-"} { - if {$gpInfo($name:selectpage) && $gpInfo($name:selectmode) eq "browse"} { - $name.tablelist selection clear 0 end - $name.tablelist selection set [$name.tablelist index active] - set selection [$name.tablelist curselection] - } else { - return - } - } - - set count [llength $selection] - set value [$name.tablelist get $selection] - - if {$gpInfo($name:selectmode) eq "multiple" || $gpInfo($name:selectmode) eq "extended"} { - if {$count == 1} { - set ($name) [list $value] - } else { - set ($name) $value - } - } else { - set ($name) $value - } - - if {$command ne ""} {{*}[list ::gridplus::gpCommand $command $window $validate]} -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistSetColumns # -# PURPOSE: Set tablelist column titles/names. # -#=======================================================================# - -proc ::gridplus::gpTablelistSetColumns {name option values} { - - set column 0 - - foreach value $values { - $name.tablelist columnconfigure $column $option $value - incr column - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTablelistSort # -# PURPOSE: Sort tablelist and save last sort. # -#=======================================================================# - -proc ::gridplus::gpTablelistSort {name column} { - - variable gpInfo - - ::tablelist::sortByColumn $name $column - - set item [regsub -- {[.]tablelist$} $name {}] - - set gpInfo($item:lastsortcolumn) [$name sortcolumn] - set gpInfo($item:lastsortorder) [$name sortorder] -} - -#=======================================================================# -# PROC : ::gridplus::gpText # -# PURPOSE: Create text. # -#=======================================================================# - -proc ::gridplus::gpText {} { - upvar 1 options options - - global {} - - variable gpInfo - - set state $options(-state) - - if {$options(-group) ne ""} { - set gpInfo($options(name).text:group) $options(-group) - } - - set state [=% $options(name).text $state] - - ::gridplus::gpLabelframe - - text $options(name).text \ - -background white \ - -height $options(-height) \ - -font TkTextFont \ - -state $state \ - -tabs {0.5c 1c 1.5c 2c 2.5c 3.0c 3.5c 4.0c 4.5c 5.0c 5.5c 6.0c 6.5c 7.0c 7.5c 8.0c} \ - -takefocus $options(-takefocus) \ - -width $options(-width) \ - -wrap $options(-wrap) \ - -xscrollcommand [list $options(name).xbar set] \ - -yscrollcommand [list $options(name).ybar set] \ - - ::ttk::scrollbar $options(name).xbar -orient horizontal -command [list $options(name).text xview] - ::ttk::scrollbar $options(name).ybar -orient vertical -command [list $options(name).text yview] - - grid $options(name).text -row 0 -column 0 -sticky news - - switch -- $options(-scroll) { - x { - grid $options(name).xbar -row 1 -column 0 -sticky ew - } - y { - grid $options(name).ybar -row 0 -column 1 -sticky ns - } - xy { - grid $options(name).xbar -row 1 -column 0 -sticky ew - grid $options(name).ybar -row 0 -column 1 -sticky ns - } - } - - grid rowconfigure $options(name) 0 -weight 1 - grid columnconfigure $options(name) 0 -weight 1 - - set gpInfo($options(name):seeinsert) $options(-seeinsert) - - if {$options(-tags)} { - set normalColor [lindex [split $options(-linkcolor) /] 0] - set overColor [lindex [split $options(-linkcolor) /] 1] - set normalStyle [lindex [split $options(-linkstyle) /] 0] - set overStyle [lindex [split $options(-linkstyle) /] 1] - - regsub -- {[&]} $overStyle $normalStyle, overStyle - - if {! [string match */* $options(-linkcolor)]} {set overColor $normalColor} - if {! [string match */* $options(-linkstyle)]} {set overStyle $normalStyle} - - if {$normalColor eq ""} {set normalColor "blue"} - if {$overColor eq ""} {set overColor "blue"} - - if {$normalStyle eq "underline"} { - set normalStyle "true" - } else { - set normalStyle "false" - } - if {$overStyle eq "underline"} { - set overStyle "true" - } else { - set overStyle "false" - } - - set gpInfo($options(name):bgcolor) white - set gpInfo($options(name):defaultbg) white - set gpInfo($options(name):defaultfg) black - set gpInfo($options(name):defaultfont) helvetica - set gpInfo($options(name):defaultsize) [::gridplus::gpGetFontSize [$options(name).text cget -font]] - set gpInfo($options(name):fgcolor) black - set gpInfo($options(name):font) [lindex [$options(name).text cget -font] 0] - set gpInfo($options(name):iconlibrary) [file join $options(-iconpath) $options(-iconfile)] - set gpInfo($options(name):indent) 0 - set gpInfo($options(name):link) blue - set gpInfo($options(name):linkcursor) $options(-linkcursor) - set gpInfo($options(name):normalcolor) $normalColor - set gpInfo($options(name):normalstyle) $normalStyle - set gpInfo($options(name):overcolor) $overColor - set gpInfo($options(name):overstyle) $overStyle - set gpInfo($options(name):prefix) $options(-prefix) - set gpInfo($options(name):proc) $options(-proc) - set gpInfo($options(name):size) [::gridplus::gpGetFontSize [$options(name).text cget -font]] - set gpInfo($options(name):tagid) 0 - set gpInfo($options(name):tags) 1 - - $options(name).text configure -cursor {} -state disabled - } else { - if {$options(-font) ne ""} { - $options(name).text configure -font $options(-font) - } - - set gpInfo($options(name):tags) 0 - } - - if {$options(-menu) eq ""} { - set menuName $options(name).text.edit - - menu $menuName -tearoff 0 - - if {$options(-tags) || $options(-state) eq "disabled"} { - $options(name).text.edit add command -label [mc "Copy"] -command "tk_textCopy $options(name).text" - $options(name).text.edit add separator - $options(name).text.edit add command -label [mc "Find"] -command "::gridplus::gpTextFind $options(name).text" - } else { - $options(name).text.edit add command -label [mc "Cut"] -command "tk_textCut $options(name).text;$options(name).text edit modified 1" - $options(name).text.edit add command -label [mc "Copy"] -command "tk_textCopy $options(name).text" - $options(name).text.edit add command -label [mc "Paste"] -command "tk_textPaste $options(name).text;$options(name).text edit modified 1" - $options(name).text.edit add separator - $options(name).text.edit add command -label [mc "Find"] -command "::gridplus::gpTextFind $options(name).text" - } - } else { - set menuName $options(-menu) - } - - if {$options(-command) ne ""} { - bind $options(name).text <> "::gridplus::gpTextSet $options(name) ; eval $options(-command)" - } else { - bind $options(name).text <> "::gridplus::gpTextSet $options(name)" - } - - bind $options(name).text "tk_popup $menuName %X %Y" - bind $options(name).text "[bind all ];break" - bind $options(name).text "[bind all <>]; break" - - set ($options(name)) {} - - if {$options(-autogroup) ne ""} { - set autoGroupCommand "::gridplus::gpAutoGroup $options(name) $options(-autogroup) normal" - trace add variable ($options(name)) write $autoGroupCommand - } - -} - -#=======================================================================# -# PROC : ::gridplus::gpTextSet # -# PURPOSE: Set contents of GRIDPLUS Text. # -#=======================================================================# - -proc ::gridplus::gpTextSet {item} { - global {} - - if {[$item.text edit modified]} { - set ($item) {} - - foreach {key text index} [$item.text dump -text 1.0 end] { - set ($item) "$($item)$text" - } - - $item.text edit modified 0 - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTextInsert # -# PURPOSE: Inserts line into text. # -#=======================================================================# - -proc ::gridplus::gpTextInsert {item position line} { - variable gpInfo - - set textState [$item.text cget -state] - - $item.text configure -state normal - - if {$position eq "end"} { - set insertPosition end - } else { - set insertPosition $position.0 - } - - if {$gpInfo($item:tags)} { - if {$position eq "end"} { - ::gridplus::gpParseTags $item $line $insertPosition - $item.text insert $insertPosition "\n" - } else { - $item.text insert $position.0 "\n" - ::gridplus::gpParseTags $item $line $position.end - } - $item.text tag raise sel - } else { - $item.text insert $insertPosition "$line\n" - $item.text edit modified 0 - set ($item) {} - foreach {key text index} [$item.text dump -text 1.0 end] { - set ($item) "$($item)$text" - } - } - - $item.text configure -state $textState - - if {$gpInfo($item:seeinsert)} { - update idletasks - $item.text see $insertPosition - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTextFind # -# PURPOSE: Find string in GRIDPLUS Text. # -#=======================================================================# - -proc ::gridplus::gpTextFind {item} { - variable gpInfo - - if {[winfo exists .gpTextFind]} { - ::gridplus::gpTextFind:action,cancel - } - - if {[string match *?.text $item]} { - set gpInfo() $item - } else { - set gpInfo() $item.text - } - - gridplus window .gpTextFind -topmost 1 -wcmd ::gridplus::gpTextFind:action,cancel -wtitle Find - - gridplus checkbutton .gpTextFind.match -padding 0 { - {.word "Match whole word only"} - {.case "Match case"} - } - - gridplus radiobutton .gpTextFind.direction -title Direction { - {. Up -backwards} {. Down +forwards} - } - - gridplus button .gpTextFind.action -prefix gridplus:: { - {&e "Find What: " .string 38 + >next ~gpTextFind.action,next} {"Find Next" .next < %next} - {@gpTextFind.match |> @gpTextFind.direction} {"Cancel" .cancel} - } - - pack .gpTextFind.action -} - -#=======================================================================# -# PROC : ::gridplus::gpTextFind:action,next # -# PURPOSE: Find next/previous occurance of string in GRIDPLUS Text. # -#=======================================================================# - -proc ::gridplus::gpTextFind:action,next {} { - global {} - - variable gpInfo - - if {$(.gpTextFind.direction) eq "forwards"} { - set searchIndex "insert+1char" - } else { - set searchIndex "insert" - } - - if {$(.gpTextFind.match,word)} { - set matchWord "-regexp" - set pattern "\[\[:<:\]\]$(.gpTextFind.action,string)\[\[:>:\]\]" - } else { - set matchWord "-exact" - set pattern "$(.gpTextFind.action,string)" - } - - if {$(.gpTextFind.match,case)} { - set position [$gpInfo() search -$(.gpTextFind.direction) $matchWord -- $pattern $searchIndex] - } else { - set position [$gpInfo() search -$(.gpTextFind.direction) $matchWord -nocase -- $pattern $searchIndex] - } - - if {$position ne ""} { - catch "$gpInfo() tag remove sel sel.first sel.last" - $gpInfo() tag add sel $position $position+[string length $(.gpTextFind.action,string)]chars - $gpInfo() configure -inactiveselectbackground [$gpInfo() cget -selectbackground] - $gpInfo() mark set insert $position - $gpInfo() see $position - } -} - -#=======================================================================# -# PROC : ::gridplus::gpTextFind:action,cancel # -# PURPOSE: Cancel/close Find dialog. # -#=======================================================================# - -proc ::gridplus::gpTextFind:action,cancel {} { - global {} - - variable gpInfo - - set gpInfo() {} - - gridplus clear .gpTextFind - destroy .gpTextFind -} - -#=======================================================================# -# PROC : ::gridplus::gpTree # -# PURPOSE: Create tree. # -#=======================================================================# - -proc ::gridplus::gpTree {} { - upvar 1 options options - - global {} - - variable gpInfo - - if {! [regexp -- {^[.]([^.]+)[.]} $options(name) -> window]} { - set window {} - } - - set gpInfo($options(name):action) $options(-action) - set gpInfo($options(name):fileicon) $options(-fileicon) - set gpInfo($options(name):foldericon) $options(-foldericon) - set gpInfo($options(name):iconlibrary) [file join $options(-iconpath) $options(-iconfile)] - set gpInfo($options(name):icons) $options(-icons) - set gpInfo($options(name):open) $options(-open) - set gpInfo($options(name):selectfirst) $options(-selectfirst) - set gpInfo($options(name):validate) $options(-validate) - set gpInfo($options(name):window) .$window - - ::gridplus::gpLabelframe - - ::ttk::treeview $options(name).tree \ - -cursor left_ptr \ - -height $options(-height) \ - -selectmode $options(-selectmode) \ - -show $options(-show) \ - -xscrollcommand [list $options(name).xbar set] \ - -yscrollcommand [list $options(name).ybar set] - - $options(name).tree column #0 -width $options(-width) - - ::ttk::scrollbar $options(name).xbar -orient horizontal -command [list $options(name).tree xview] - ::ttk::scrollbar $options(name).ybar -orient vertical -command [list $options(name).tree yview] - - grid $options(name).tree -row 0 -column 0 -sticky news - - switch -- $options(-scroll) { - x { - grid $options(name).xbar -row 1 -column 0 -sticky ew - } - y { - grid $options(name).ybar -row 0 -column 1 -sticky ns - } - xy { - grid $options(name).xbar -row 1 -column 0 -sticky ew - grid $options(name).ybar -row 0 -column 1 -sticky ns - } - } - - grid rowconfigure $options(name) 0 -weight 1 - grid columnconfigure $options(name) 0 -weight 1 - - if {$options(-proc)} { - set command "gpProc [::gridplus::gpCommandFormat $options(name)]" - } else { - if {$options(-command) eq ""} { - set command "$options(-prefix)[::gridplus::gpCommandFormat $options(name)]" - } else { - set command $options(-command) - } - } - - set gpInfo($options(name):command) $command - - switch -- $options(-action) { - double { - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window 0]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window 0]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window 0]" - bind $options(name).tree "after 1 [list ::gridplus::gpCommand [list $command] .$window $options(-validate)]" - } - single { - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - } - single/space { - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate) [list $command]]" - } - default { - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate)]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate)]" - bind $options(name).tree "after 1 [list ::gridplus::gpTreeSelect $options(name) .$window $options(-validate)]" - } - } - - if {$options(-menu) ne ""} { - bind $options(name).tree "after 1 {::gridplus::gpTreeMenu $options(-menu) %x %y %X %Y %W $options(name)}" - } - - if {[lsearch [image names] ::icon::$options(-fileicon)] < 0} { - ::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $options(-fileicon) - } - if {[lsearch [image names] ::icon::$options(-foldericon)] < 0} { - ::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $options(-foldericon) - } - - set ($options(name)) {} -} - -#=======================================================================# -# PROC : ::gridplus::gpTreeMenu # -# PURPOSE: Right-click pop-up menu for tree. # -#=======================================================================# - -proc ::gridplus::gpTreeMenu {menu x y X Y W name} { - global {} - - $name.tree selection remove $($name) - - set item [lindex [$name.tree identify $x $y] 1] - - $name.tree selection set $item - - set ($name) [$name.tree selection] - - $menu post $X $Y -} - -#=======================================================================# -# PROC : ::gridplus::gpTreeSelect # -# PURPOSE: Sets value for tree selections. # -#=======================================================================# - -proc ::gridplus::gpTreeSelect {name window validate {command {}}} { - global {} - - set ($name) [regsub -all "\034" [$name.tree selection] { }] - - if {$command ne ""} {{*}[list ::gridplus::gpCommand $command $window $validate]} -} - -#=======================================================================# -# PROC : ::gridplus::gpTreeSet # -# PURPOSE: Set contents of GRIDPLUS Tree. # -#=======================================================================# - -proc ::gridplus::gpTreeSet {name nodes} { - variable gpInfo - - $name.tree delete [$name.tree children {}] - - foreach node $nodes { - set icon {} - set nodeText {} - set nodeType file - - foreach item $node { - switch -regexp -- $item { - ^: { - set icon [string range $item 1 end] - } - ^[+]$ { - set nodeType folder - } - ^[/] { - regsub -all { } $item "\034" nodeFullName - } - default { - set nodeText $item - } - } - } - - if {! [regexp {^(.*/)([^/]+)$} $nodeFullName -> path nodeName]} { - set path $nodeFullName - set nodeName $nodeFullName - set indent "" - } - - if {$nodeText ne ""} { - set nodeName $nodeText - } else { - regsub -all "\034" $nodeName { } nodeName - } - - set nodeName [mc $nodeName] - - if {$icon eq ""} { - set icon $gpInfo($name:${nodeType}icon) - } else { - if {[lsearch [image names] ::icon::$icon] < 0} { - ::icons::icons create -file $gpInfo($name:iconlibrary) $icon - } - } - - if {$path eq "/"} { - set parent {} - } else { - regsub -- {/$} $path {} parent - } - - if {$gpInfo($name:icons)} { - $name.tree insert $parent end -id $nodeFullName -image ::icon::$icon -open $gpInfo($name:open) -text $nodeName - } else { - $name.tree insert $parent end -id $nodeFullName -open $gpInfo($name:open) -text $nodeName - } - } - - if {$gpInfo($name:selectfirst)} { - gpselect $name [lindex [$name.tree children {}] 0] - } -} - -#=======================================================================# -# PROC : ::gridplus::gpValidate # -# PURPOSE: Validates contents of entry. # -#=======================================================================# - -proc ::gridplus::gpValidate {item validation condition prevalue fixed auto} { - global {} - - variable gpConfig - variable gpInfo - variable gpValidateError - variable gpValidation - - set focus [focus] - - if {$focus ne ""} { - set focusClass [winfo class $focus] - set focusToplevel [winfo toplevel $focus] - # Set toplevel to modal if unknown (for Tk dialogs?) - if {[info exists gpInfo($focusToplevel:modal)]} { - set focusToplevelModal $gpInfo($focusToplevel:modal) - } else { - set focusToplevelModal 1 - } - } else { - set focusClass "" - set focusToplevel "" - set focusToplevelModal 0 - } - - if {[info exists gpInfo(validation:failed)]} { - set failedItem $gpInfo(validation:failed) - set failedItemToplevel [winfo toplevel $failedItem] - set failedItemToplevelModal $gpInfo($failedItemToplevel:modal) - } else { - set failedItem "" - set failedItemToplevel "" - set failedItemToplevelModal 0 - } - - set itemToplevel [winfo toplevel $item] - set itemToplevelModal $gpInfo($itemToplevel:modal) - - if {[info exists gpInfo($focus:validationmode)]} { - set validationMode $gpInfo($focus:validationmode) - } else { - set validationMode "" - } - - switch -- $condition { - focusout { - if {$focusToplevel ne $itemToplevel && $focusToplevelModal} { - return 1 - } - if {$failedItem ne "" && $failedItem ne $item} { - if {$failedItemToplevel ne $itemToplevel && $itemToplevelModal} { - unset -nocomplain gpInfo(validation:failed) - } - - return 1 - } - } - - focusin { - if {$failedItem ne ""} { - if {$itemToplevelModal && ! $failedItemToplevelModal} { - $failedItem configure -foreground black - - if {[set window $failedItemToplevel] eq "."} { - set window {} - } - - if {[winfo exists $window.errormessage]} { - $window.errormessage configure -text {} - } - - unset -nocomplain gpInfo(validation:failed) - - ::gridplus::gpValidateErrorCancel - - 0 - - return 1 - } - - if {$failedItemToplevel ne $itemToplevel} { - focus $failedItem - return 1 - } - } - } - - key { - if {[string length $prevalue] > $fixed} { - return 0 - } - return 1 - } - } - - if {$validation eq "__gpFixed__" || $condition ne "focusout" || ! $auto} { - return 1 - } - - if {$focusClass in "Button TButton" && $validationMode ne "focus" && $prevalue ne "-"} { - return 1 - } - - if {! [regexp {^([.][^.,]+)} $item -> window]} { - set window {} - } else { - if {[winfo class $window] ne "Toplevel"} { - set window {} - } - } - - set validationOK 0 - - regexp -- {@?([^:?]+)(:([^?]*))*([?](.*))*} $validation -> validationName -> parameter -> errorText - - if {[string match @* $validation] && $($item) eq ""} { - set validationOK 1 - } else { - switch -glob -- $gpValidation($validationName) { - proc:* { - set validateProc [string range $gpValidation($validationName) 5 end] - if {[$validateProc $item $parameter]} { - set validationOK 1 - } - } - trim:* { - set ($item) [string trim $($item)] - if {[regexp [string range $gpValidation($validationName) 5 end] $($item)]} { - set validationOK 1 - } - } - default { - if {[regexp $gpValidation($validationName) $($item)]} { - set validationOK 1 - } - } - } - } - - if $validationOK { - $item configure -foreground black - - if {[winfo exists $window.errormessage]} { - $window.errormessage configure -text {} - } - - unset -nocomplain gpInfo(validation:failed) - - ::gridplus::gpValidateErrorCancel - - 0 - - return 1 - } else { - if {$focus ne ""} { - ::gridplus::gpNotebookIn $item - } - - update idletasks - - set gpInfo(validation:failed) $item - - return 0 - } -} - -#=======================================================================# -# PROC : ::gridplus::gpValidateFailed # -# PURPOSE: Sets focus to failed validation entry. # -#=======================================================================# - -proc ::gridplus::gpValidateFailed {item} { - - variable gpInfo - - if {! [winfo exists $item]} { - return - } - - set focus [focus] - - if {[string compare {} $focus] && [winfo class $focus] eq "Entry"} { - $focus selection clear - - if {[regexp {^(focus(out)?|all)} [set validate [$focus cget -validate]]]} { - $focus configure -validate none - after idle [list $focus configure -validate $validate] - } - } - - if {[info exists gpInfo(validation:failed)]} { - if {[set window [winfo toplevel $item]] eq "."} { - set window {} - } - after 1 "[list focus $item]; ::gridplus::gpValidateErrorDisplay $item" - } -} - -#=======================================================================# -# PROC : ::gridplus::gpValidateErrorDisplay # -# PURPOSE: Display validation error messages. # -#=======================================================================# - -proc ::gridplus::gpValidateErrorDisplay {item} { - variable gpValidateError - - if {! [regexp {^([.][^.,]+)} $item -> window]} { - set window {} - } else { - if {[winfo class $window] ne "Toplevel"} { - set window {} - } - } - - if {[winfo exists $window.errormessage]} { - $window.errormessage configure -text $gpValidateError($item:text) - } - - if {$gpValidateError($item:popup)} { - ::gridplus::gpValidateErrorShow $item - } - - $item configure -foreground red -} - -#=======================================================================# -# PROCS : ::gridplus::gpValidateErrorInit # -# : ::gridplus::gpValidateErrorCancel # -# : ::gridplus::gpValidateErrorShow # -# PURPOSE: Gridplus widget validation "pop-up" error message. # -#=======================================================================# - -proc ::gridplus::gpValidateErrorInit {item message {mode label}} { - variable gpValidateError - - if {! [winfo exists .gpValidateError]} { - toplevel .gpValidateError -background black -borderwidth 1 -relief flat - label .gpValidateError.message -background red -foreground white - pack .gpValidateError.message - wm overrideredirect .gpValidateError 1 - wm withdraw .gpValidateError - } - - if {$mode eq "popup"} { - set gpValidateError($item:popup) 1 - } else { - set gpValidateError($item:popup) 0 - } - - set gpValidateError($item:text) $message -} - -proc ::gridplus::gpValidateErrorCancel {testWindow eventWindow binding} { - variable gpInfo - variable gpValidateError - - if {! $binding && [info exists gpInfo(validation:failed)]} { - return 1 - } - - if {$testWindow eq $eventWindow} { - if {[winfo exists .gpValidateError]} { - wm withdraw .gpValidateError - } - } -} - -proc ::gridplus::gpValidateErrorShow {item} { - variable gpValidateError - - .gpValidateError.message configure -text $gpValidateError($item:text) - - set helpX [expr [winfo rootx $item] + 10] - set helpY [expr [winfo rooty $item] + [expr {[winfo height $item] - 1}]] - - wm geometry .gpValidateError +$helpX+$helpY - wm deiconify .gpValidateError - - raise .gpValidateError -} - -#=======================================================================# -# PROC : ::gridplus::gpValidateText # -# PURPOSE: Returns formatted validation message text. # -#=======================================================================# - -proc ::gridplus::gpValidateText {validation} { - variable gpConfig - variable gpValidation - - regexp -- {@?([^:?]+)(:([^?]*))*([?](.*))*} $validation -> validationName -> parameter -> errorText - - if {$errorText eq ""} { - set errorText [mc $gpValidation($validationName:text)] - set errorMessage [mc $gpConfig(errormessage)] - regsub {%} $errorText $parameter errorText - regsub {%} $errorMessage $errorText errorMessage - return $errorMessage - } else { - return $errorText - } -} - -#=======================================================================# -# PROC : ::gridplus::gpValidateDate # -# PURPOSE: Validates for valid date. # -#=======================================================================# - -proc ::gridplus::gpValidateDate {entry parameter} { - global {} - - foreach {month day year} [::gridplus::gpFormatDate $($entry) internal] {} - - set day [scan $day "%d"] - set month [scan $month "%d"] - set result 0 - - if {$month < 1 || $month > 12} { - return 0 - } else { - if {$day < 1 || $day > [::gridplus::gpCalMonthDays $month $year]} { - return 0 - } else { - set ($entry) [::gridplus::gpFormatDate $($entry) application] - $entry configure -validate focusout - return 1 - } - } -} - -#=======================================================================# -# PROCS : ::gridplus::gpGridIn # -# : ::gridplus::gpPackIn # -# : ::gridplus::gpNotebokIn # -# PURPOSE: If validated entry in notebook select pane containing entry. # -#=======================================================================# - -proc ::gridplus::gpGridIn {name} { - - array set info [grid info $name] - - if {[info exists info(-in)]} { - return $info(-in) - } else { - return {} - } -} - -proc ::gridplus::gpPackIn {name} { - - if {! [catch "pack info $name"]} { - array set info [pack info $name] - return $info(-in) - } else { - return {} - } -} - -proc ::gridplus::gpNotebookIn {name} { - global {} - - variable gpTabOrder - - set in $name - - while {[set in [gpGridIn $in]] ne ""} { - set lastIn $in - } - - set in $lastIn - - while {[set in [gpPackIn $in]] ne ""} { - set lastIn $in - } - - set toplevelLastIn {} - - if {[winfo class $lastIn] eq "Toplevel"} { - foreach item [array names ::gridplus::gpInfo *:in] { - if {$::gridplus::gpInfo($item) eq $lastIn} { - set in [lindex [split $item :] 0] - set toplevelLastIn $in - while {[set in [gpPackIn $in]] ne ""} { - set lastIn $in - } - } - } - } - - if {[regexp -- {(.*)[.]([^.]+$)} $lastIn -> containedIn]} { - - if {$containedIn eq "" && $toplevelLastIn ne ""} { - gpNotebookIn $toplevelLastIn - } elseif {[winfo exists $containedIn] && [winfo class $containedIn] eq "TNotebook"} { - $containedIn select $lastIn - - set pane [$containedIn index current] - set panes [$containedIn tabs] - - regsub -all .[winfo name $containedIn] [lindex $panes $pane] {} item - - set gpTabOrder($containedIn:000000) $item - - gpSetTabOrder $containedIn - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpFormatDate # -# PURPOSE: Converts date format for validation and display. # -#=======================================================================# - -proc ::gridplus::gpFormatDate {date mode} { - variable gpConfig - - if {$gpConfig(dateformat) eq "iso"} { - switch -regexp -- $date { - {^[0-9]{8}$} { - set part(0) [string range $date 0 3] - set part(1) [string range $date 4 5] - set part(2) [string range $date 6 7] - } - {^[0-9]{4}-[0-9]{2}-[0-9]{2}$} { - set part(0) [string range $date 0 3] - set part(1) [string range $date 5 6] - set part(2) [string range $date 8 9] - } - default { - set part(0) 0 - set part(1) 0 - set part(2) 0 - } - } - } else { - switch -regexp -- $date { - {^[0-9]{6}$} { - set part(0) [string range $date 0 1] - set part(1) [string range $date 2 3] - set part(2) [string range $date 4 5] - if {$part(2) <= $gpConfig(date:century)} { - set part(2) "20$part(2)" - } else { - set part(2) "19$part(2)" - } - } - {^[0-9]{8}$} { - set part(0) [string range $date 0 1] - set part(1) [string range $date 2 3] - set part(2) [string range $date 4 7] - } - {^[0-9]{2}.[0-9]{2}.[0-9]{4}$} { - set part(0) [string range $date 0 1] - set part(1) [string range $date 3 4] - set part(2) [string range $date 6 9] - } - default { - set part(0) 0 - set part(1) 0 - set part(2) 0 - } - } - } - - set separator $gpConfig(date:separator) - - if {[string equal $mode internal]} { - return "$part($gpConfig(date:month)) $part($gpConfig(date:day)) $part($gpConfig(date:year))" - } else { - return $part(0)$separator$part(1)$separator$part(2) - } -} - -#=======================================================================# -# PROC : ::gridplus::gpCalCheckDate # -# PURPOSE: Checks for valid date. # -#=======================================================================# - -proc ::gridplus::gpCalCheckDate {month day year} { - - set result 0 - - if {[scan $month %d] < 1 || [scan $month %d] > 12} { - return 0 - } else { - if {[scan $day %d] < 1 || [scan $day %d] > [::gridplus::gpCalMonthDays $month $year]} { - return 0 - } else { - return 1 - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpCalDayNames # -# PURPOSE: Returns day name header information. # -#=======================================================================# - -proc ::gridplus::gpCalDayNames {weekstart} { - variable gpConfig - - set basetime 1220223600 - set daynames {} - - for {set day [expr {$weekstart - 1}]} {$day < [expr {$weekstart + 6}]} {incr day} { - lappend daynames [string range [clock format [clock add $basetime $day day] -format %a -locale $gpConfig(locale)] 0 1] - } - - return $daynames -} - -#=======================================================================# -# PROC : ::gridplus::gpCalMonthDays # -# PURPOSE: Returns number of days for specified month/year. # -#=======================================================================# - -proc ::gridplus::gpCalMonthDays {month year} { - array set days { - 1 31 - 2 28 - 3 31 - 4 30 - 5 31 - 6 30 - 7 31 - 8 31 - 9 30 - 10 31 - 11 30 - 12 31 - } - - if {[clock format [clock add [clock scan 28/02/${year} -format "%d/%m/%Y"] 1 day] -format %d] eq "29"} { - set days(2) 29 - } - - return $days([scan $month "%d"]) -} - - -#=======================================================================# -# PROC : ::gridplus::gpDedent # -# PURPOSE: Returns "dedented" version of "value" string. # -#=======================================================================# - -proc ::gridplus::gpDedent {value} { - - set first 1 - - foreach line [split $value "\n"] { - set spaces {} - - if {[regexp -- {^ +} $line spaces]} { - if {$first} { - set indent [string length $spaces] - set first 0 - } elseif {[string length $spaces] < $indent} { - set indent [string length $spaces] - } - } - } - - regsub -lineanchor -all -- "^ {$indent}" $value {} result - - return $result -} - -#=======================================================================# -# PROC : ::gridplus::gpWindow # -# PURPOSE: Create toplevel window with "modal" option. # -#=======================================================================# - -proc ::gridplus::gpWindow {} { - upvar 1 options options - - variable gpInfo - - set options(-windowcommand) [::gridplus::gpOptionAlias -windowcommand -wcmd] - - if {[winfo exists $options(name)] && $options(-in) eq ""} { - if {! $gpInfo($options(name):toplevel)} { - return 0 - } - - if {$options(-windowcommand) ne ""} { - wm protocol $options(name) WM_DELETE_WINDOW "after 1 {$options(-windowcommand)}" - } - if {$options(-wtitle) ne ""} { - wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] - } - return 0 - } - - regsub -- {%c} $options(-windowcommand) "::gridplus::gridplus clear $options(name)" - regsub -- {%d} $options(-windowcommand) "destroy $options(name)" - - set gpInfo($options(name):modal) 0 - - if {$options(-in) ne ""} { - if {[info exists gpInfo($options(-in):wcmd)]} { - eval $gpInfo($options(-in):wcmd) - } - - if {[winfo exists $options(-in).container]} { - destroy $options(-in).container - } - - frame $options(-in).container -container 1 - - set gpInfo($options(-in):container) [winfo id $options(-in).container] - - grid $options(-in).container -sticky $gpInfo($options(-in):sticky) - grid rowconfigure $options(-in) $options(-in).container -weight 1 - grid columnconfigure $options(-in) $options(-in).container -weight 1 - - toplevel $options(name) -use $gpInfo($options(-in):container) - - set gpInfo($options(name):toplevel) 0 - - if {$gpInfo([winfo toplevel $options(-in)]:modal)} { - set gpInfo($options(name):modal) 1 - } else { - set gpInfo($options(name):modal) 0 - } - - ::gridplus::gpEditMenuCreate $options(name) - - if {$options(-windowcommand) ne ""} { - set gpInfo($options(-in):wcmd) "$options(-windowcommand)" - } else { - set gpInfo($options(-in):wcmd) "::gridplus::gridplus clear $options(name);destroy $options(name)" - } - - set gpInfo($options(-in):in) $options(name) - - return 1 - } else { - set gpInfo($options(name):toplevel) 1 - - if {$options(-modal)} { - set gpInfo($options(name):modal) 1 - } - - toplevel $options(name) - wm overrideredirect $options(name) $options(-overrideredirect) - - bind $options(name) "::gridplus::gpWindowBindings $options(name) %W 1" - bind $options(name) "::gridplus::gpWindowBindings $options(name) %W 1" - bind $options(name) "::gridplus::gpWindowBindings $options(name) %W 1" - } - - wm attributes $options(name) -topmost $options(-topmost) - - bind $options(name) "::gridplus::gpWidgetHelpCancel;::gridplus::gpValidateErrorCancel $options(name) %W 1" - - ::gridplus::gpEditMenuCreate $options(name) - - wm resizable $options(name) 0 0 - - if {$options(-windowcommand) ne ""} { - wm protocol $options(name) WM_DELETE_WINDOW "after 1 {$options(-windowcommand)}" - } else { - wm protocol $options(name) WM_DELETE_WINDOW "after 1 {::gridplus::gridplus clear $options(name);destroy $options(name)}" - } - - if {$options(-wtitle) ne ""} { - wm title [winfo toplevel $options(name)] [mc $options(-wtitle)] - } - - if {$options(-modal)} { - bind modalWindow {wm deiconify %W;raise %W} - bindtags $options(name) [linsert [bindtags $options(name)] 0 modalWindow] - wm deiconify $options(name) - tkwait visibility $options(name) - grab set $options(name) - } - - return 1 -} - -#=======================================================================# -# PROC : ::gridplus::gpWindowBindings # -# PURPOSE: Process window bindings. # -#=======================================================================# - -proc ::gridplus::gpWindowBindings {testWindow eventWindow binding} { - - ::gridplus::gpWidgetHelpCancel - ::gridplus::gpValidateErrorCancel $testWindow $eventWindow $binding - ::gridplus::gpDateSelectorUnpost $testWindow -} - -#=======================================================================# -# PROC : ::gridplus::gpclear # -# PURPOSE: Clear selected text for item. # -#=======================================================================# - -proc ::gridplus::gpclear {{item {}}} { - - if {$item eq ""} { - set item [focus] - } - - if {[string match *.text $item] && [winfo class $item] eq "Text"} { - set textItem $item - } else { - set textItem $item.text - } - - if {[winfo exists $textItem]} { - event generate $textItem <> - $textItem edit modified 1 - } else { - event generate $item <> - } -} - -#=======================================================================# -# PROC : ::gridplus::gpcopy # -# PURPOSE: Perform clipboard copy for item. # -#=======================================================================# - -proc ::gridplus::gpcopy {{item {}}} { - - if {$item eq ""} { - set item [focus] - } - - if {[string match *.text $item] && [winfo class $item] eq "Text"} { - set textItem $item - } else { - set textItem $item.text - } - - if {[winfo exists $textItem]} { - tk_textCopy $textItem - } else { - clipboard clear - catch {clipboard append [selection get]} - } -} - -#=======================================================================# -# PROC : ::gridplus::gpcut # -# PURPOSE: Perform clipboard cut for item. # -#=======================================================================# - -proc ::gridplus::gpcut {{item {}}} { - - if {$item eq ""} { - set item [focus] - } - - if {[string match *.text $item] && [winfo class $item] eq "Text"} { - set textItem $item - } else { - set textItem $item.text - } - - if {[winfo exists $textItem]} { - tk_textCut $textItem - $textItem edit modified 1 - } else { - clipboard clear - catch {clipboard append [selection get]} - catch {$item delete sel.first sel.last} - } -} - -#=======================================================================# -# PROC : ::gridplus::gpdate # -# PURPOSE: Returns (calculated) date in "-dateformat". # -#=======================================================================# - -proc ::gridplus::gpdate {{action {@}} {date {}}} { - variable gpConfig - - # Run initialisation if neccessary. - if {! [info exists gpConfig]} { - gpInit - } - - set unitCode [string index $action 0] - set increment [string range $action 1 end] - - switch -- $gpConfig(dateformat) { - eu {set dateFormat "%d.%m.%Y"} - iso {set dateFormat "%Y-%m-%d"} - uk {set dateFormat "%d/%m/%Y"} - us {set dateFormat "%m/%d/%Y"} - } - - if {$date eq ""} { - set clockSeconds [clock seconds] - } else { - set clockSeconds [clock scan $date -format $dateFormat] - } - - switch -- $unitCode { - @ {return [clock format $clockSeconds -format $dateFormat]} - + {set unit "day"} - - {set unit "day";set increment "-$increment"} - > {set unit "month"} - < {set unit "month";set increment "-$increment"} - default {return $action} - } - - return [clock format [clock add $clockSeconds $increment $unit] -format $dateFormat] -} - -#=======================================================================# -# PROC : ::gridplus::gpdb # -# PURPOSE: TDBC interface. # -#=======================================================================# - -proc ::gridplus::gpdb {args} { - - foreach {option arg database window sql FOREACH code data} [lrepeat 8 {}] {} - - switch [llength $args] { - 3 { - foreach {database window sql} $args {} - } - 4 { - foreach {database window sql data} $args {} - } - 5 { - foreach {database window sql FOREACH code} $args {} - } - 6 { - foreach {database window sql FOREACH code data} $args {} - } - default { - error "GRIDPLUS ERROR: (gpdb) Invalid number of args." - } - } - - ::gridplus::gpdbRunSQL $database $window $sql "$code" $data -} - -#=======================================================================# -# PROC : ::gridplus::gpdbRunSQL # -# PURPOSE: Run SQL and set approprite result. # -#=======================================================================# - -proc ::gridplus::gpdbRunSQL {database window sql code data} { - global {} - - variable gpInfo - - set columnID 1 - set columnMap [dict create] - set dataType "map" - set format "dicts" - set prefix @ - set result {} - set rowCount 1 - set varCount 1 - - if {$code ne ""} { - set dataType "foreach" - set format "dicts" - if {[string match *@* $data]} { - set prefix $data - } - } elseif {$data ne ""} { - if {[string match .* $data]} { - set dataType "tablelist" - set format "lists" - } elseif {[string match *@* $data]} { - set dataType "gridplus" - set prefix $data - } elseif {$data eq "="} { - set dataType "list" - set format "lists" - } else { - set dataType "dict" - upvar #0 $data variable - } - } - - while {[regexp -- {@[(]([^( )@]+)[)]} $sql sqlItem itemID]} { - set columnName "gpdb____$columnID" - dict set columnMap $columnName $itemID - set sql [string map "$sqlItem {as $columnName}" $sql] - incr columnID - } - - while {[regexp -- {((%?):[(]([^( ):]+)(:([a-zA-Z0-9]+))?[)](%?))} $sql -> sqlItem wildcard1 itemID -> index wildcard2]} { - switch -glob -- $itemID { - ,* { - if {$window eq "."} { - set pattern "^\[.\]\[^,.\]+$itemID$" - } else { - set pattern "^\[.\][string range $window 1 end]\[.\]\[^,.\]+$itemID$" - } - set item [array names {} -regexp $pattern] - if {[llength $item] > 1} { - error "GRIDPLUS ERROR: (gpdb) Ambiguous item ($sqlItem)." - } - } - [.]* { - set item $itemID - } - *[@]* { - set item $itemID - } - default { - if {[string match *, $window]} { - set item $window$itemID - } else { - if {$window eq "."} { - set item .$itemID - } else { - set item $window.$itemID - } - } - } - } - - if {! [info exists ($item)]} { - error "GRIDPLUS ERROR: (gpdb) Item \"$item\" does not exist." - } - - if {$index eq ""} { - set gpdbSQLvar$varCount "$wildcard1$($item)$wildcard2" - } else { - set gpdbSQLvar$varCount "$wildcard1[lindex $($item) [::gridplus::gpTablelistColumnIndex $item $index gpdb]]$wildcard2" - } - - set sql [string map "$sqlItem :gpdbSQLvar$varCount" $sql] - - incr varCount - } - - set statement [$database prepare $sql] - - if {[catch { - $statement foreach -as $format -columnsvariable columns row { - switch -- $dataType { - foreach { - dict for {column value} $row { - gpset "$prefix$column" $value - } - eval "global {};$code" - } - tablelist { - lappend result $row - } - list { - lappend result $row - } - default { - if {$rowCount > 1} { - error "GRIDPLUS ERROR: (gpdb) More than 1 row returned for non-list result." - } else { - set result $row - } - } - } - incr rowCount - } - } sqlErrorText]} { - if {[=< sqlErrorProc] eq ""} { - error "GRIDPLUS ERROR: (gpdb) SQL error ($sqlErrorText)." - } else { - [=< sqlErrorProc] "$sqlErrorText" - } - } - - $statement close - - switch -- $dataType { - dict { - set variable [dict create {*}$result] - } - gridplus { - dict for {column value} $result { - gpset "$prefix$column" $value - } - } - map { - ::gridplus::gpdbMap $window $result $columnMap - } - tablelist { - gpset $data $result - } - list { - return $result - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpdbMap # -# PURPOSE: Map result from SQL to GRIDPLUS "variable(s)". # -#=======================================================================# - -proc ::gridplus::gpdbMap {window result columnMap} { - global {} - - dict for {column value} $result { - set mapWindow {} - set mapGrid {} - set mapItem {} - - if {[string match "gpdb____*" $column]} { - set item [dict get $columnMap $column] - } else { - regsub -all -- {[.:]} $column "_" column - set pattern $column - if {[string match *, $window]} { - set item $window$column - } else { - if {$window eq "."} { - set pattern "^\[.\]\[^,.\]+,$pattern$" - } else { - set pattern "^\[.\][string range $window 1 end]\[.\]\[^,.\]+,$pattern$" - } - set item [array names {} -regexp $pattern] - if {[llength $item] > 1} { - error "GRIDPLUS ERROR: (gpdb) Ambiguous item ($column)." - } - } - } - - if {[info exists ($item)]} { - gpset $item $value - } else { - gpset "@$column" $value - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpdefault # -# PURPOSE: Set default values for GRIDPLUS "variable(s)". # -#=======================================================================# - -proc ::gridplus::gpdefault {args} { - - variable gpInfo - - switch -- [llength $args] { - 1 { - if {[expr [llength [lindex $args 0]] % 2] != 0} { - error "GRIDPLUS ERROR: (gpdefault) Unmatched item/value." - } - foreach {item value} [lindex $args 0] { - set gpInfo(default:$item) $value - } - } - 2 { - set item [lindex $args 0] - set value [lindex $args 1] - set gpInfo(default:$item) $value - } - default { - error "GRIDPLUS ERROR: (gpdefault) Wrong number of Args." - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpdelete # -# PURPOSE: Deletes specified row/line/item from a tablelist/text/tree. # -#=======================================================================# - -proc ::gridplus::gpdelete {args} { - global {} - - variable gpInfo - - set focus 0 - set index 0 - set select 0 - - set column 0 - set match {} - - set count 1 - set current 0 - set option 1 - - set autoSelect [=< autoSelect 1] - - foreach arg $args { - switch -glob -- $arg { - | {set option 0} - -first {if {$option} {set index 1; set match 0}} - -focus {if {$option} {set select 1; set focus 1}} - -index {if {$option} {set index 1}} - -last {if {$option} {set index 1; set match "end"}} - -row {if {$option} {set index 1}} - -select {if {$option} {set select 1}} - -- {set option 0} - default { - if {$option && [string match -* $arg]} { - error "GRIDPLUS ERROR: (gpdelete) Invalid option ($arg)." - } - switch -- $count { - 1 {set name $arg; incr count} - 2 {set arg2 $arg; incr count} - 3 {set arg3 $arg; incr count} - } - } - } - } - - switch -- $count { - 2 {if {! $index} { - set current 1 - set index 1 - } - } - 3 {set match $arg2 - } - 4 {set column $arg2 - set match $arg3 - } - default { - error "GRIDPLUS ERROR: (gpdelete) Invalid number of Args." - } - } - - if {[winfo exists $name.tablelist]} { - if {$current && [$name.tablelist cget -selectmode] ni "browse single"} { - error "GRIDPLUS ERROR: (gpdelete) Current row delete only allowed when tablelist selectmode is \"browse\" or \"single\"." - } - - set currentSelection [$name.tablelist curselection] - - if {$currentSelection ne ""} { - if {$autoSelect} { - set select 1 - } - } - - if {$current} { - if {$currentSelection ne ""} { - set match $currentSelection - } else { - error "GRIDPLUS ERROR: (gpdelete) Tablelist does not have a selected row." - } - } - - $name.tablelist selection clear 0 end - set ($name) {} - - if {$index} { - set row $match - if {$row ne "end" && $row >= [$name.tablelist size]} { - set row "end" - } - } else { - set columnIndex [::gridplus::gpTablelistColumnIndex $name $column gpdelete] - set row [lsearch -exact [$name.tablelist getcolumn $columnIndex] $match] - if {$row == -1} { - error "GRIDPLUS ERROR: (gpdelete) Tablelist row with match \"$match\" not found." - } - } - - $name.tablelist delete $row - - if {$select} { - if {$focus} { - gpselect $name -focus -row $row - } else { - gpselect $name -row $row - } - } - } elseif {[winfo exists $name.text]} { - if {$match eq ""} { - error "GRIDPLUS ERROR: (gpdelete) Text line not specified." - } - - if {$match eq "first"} { - set match 1 - } - - if {$match in "end last"} { - $name.text delete "end - 1 line" "end" - } else { - $name.text delete $match.0 $match.end - $name.text delete $match.end - } - } elseif {[winfo exists $name.tree]} { - if {$current && [$name.tree cget -selectmode] ne "browse"} { - error "GRIDPLUS ERROR: (gpdelete) Current node delete only allowed when tree selectmode is \"browse\"." - } - - set currentSelection [$name.tree selection] - - if {$currentSelection ne ""} { - if {$autoSelect} { - set select 1 - } - } - - if {$current} { - if {$currentSelection ne ""} { - set match $currentSelection - } else { - error "GRIDPLUS ERROR: (gpdelete) Tree does not have a selected node." - } - } - - if {$select} { - set selectNode [$name.tree identify item 1 [expr {[lindex [$name.tree bbox $($name)] 1] + [lindex [$name.tree bbox $($name)] 3] + 1}]] - if {$selectNode eq ""} { - set selectNode [$name.tree identify item 1 [expr {[lindex [$name.tree bbox $($name)] 1] - 1}]] - } - } - - $name.tree selection remove $($name) - set ($name) {} - $name.tree delete $match - - if {$select && $selectNode ne ""} { - if {$focus} { - gpselect $name -focus $selectNode - } else { - gpselect $name $selectNode - } - } - } else { - error "GRIDPLUS ERROR: (gpdelete) Widget \"$name\" is not tablelist, text or tree." - } -} - -#=======================================================================# -# PROC : ::gridplus::gpfind # -# PURPOSE: Find next/previous occurance of string in GRIDPLUS Text. # -#=======================================================================# - -proc ::gridplus::gpfind {item pattern {direction forwards}} { - global {} - - if {$direction eq "forwards"} { - set searchIndex "insert+1char" - } else { - set searchIndex "insert" - } - - set position [$item.text search -$direction -exact -nocase -- $pattern $searchIndex] - - if {$position ne ""} { - catch "$item.text tag remove sel sel.first sel.last" - $item.text tag add sel $position $position+[string length $pattern]chars - $item.text configure -inactiveselectbackground [$item.text cget -selectbackground] - $item.text mark set insert $position - $item.text see $position - } -} - -#=======================================================================# -# PROC : ::gridplus::gpfind_dialog # -# PURPOSE: Display find dialog for specified GRIDPLUS text item. # -#=======================================================================# - -proc ::gridplus::gpfind_dialog {item} { - - ::gridplus::gpTextFind $item -} - -#=======================================================================# -# PROC : ::gridplus::gpget # -# PURPOSE: Returns tablelist column data for "columns". # -#=======================================================================# - -proc ::gridplus::gpget {item columns} { - global {} - - set result {} - - if {[string match ?*>*? $columns]} { - foreach {first last} [split $columns >] {} - set firstIndex [::gridplus::gpTablelistColumnIndex $item $first "gpget"] - set lastIndex [::gridplus::gpTablelistColumnIndex $item $last "gpget"] - set columns {} - for {set index $firstIndex} {$index <= $lastIndex} {incr index} { - lappend columns $index - } - set columns [string map {{ } ,} $columns] - } - - foreach column [split $columns ,+] { - if {$column ne ""} { - lappend result [lindex $($item) [::gridplus::gpTablelistColumnIndex $item $column "gpget"]] - } - } - - if {([string match *+* $columns] || [llength $result] == 1) && ! [string match *,* $columns]} { - set result [concat {*}$result] - } - - return $result -} - -#=======================================================================# -# PROC : ::gridplus::gpinsert # -# PURPOSE: Inserts line into tablelist/text. # -#=======================================================================# - -proc ::gridplus::gpinsert {name position line} { - global {} - - variable gpInfo - - if {[winfo exists $name.tablelist]} { - ::gridplus::gpTablelistInsert $name $position $line - } elseif {[winfo exists $name.text]} { - ::gridplus::gpTextInsert $name $position $line - } else { - error "GRIDPLUS ERROR: (gpinsert) Widget \"$name\" is not tablelist or text." - } -} - -#=======================================================================# -# PROC : ::gridplus::gpmap # -# PURPOSE: Map GRIDPLUS "variable(s)" to a list of values, array or dict# -#=======================================================================# - -proc ::gridplus::gpmap {map values {arg __direct}} { - - if {$arg ni "__direct __left __right"} { - upvar #0 $arg variable - - set position 0 - - if {[array exists variable]} { - foreach item $map { - if {[winfo exists $item] && [winfo class $item] eq "TCombobox"} { - gpset [list $item $variable([lindex $values $position])] - } else { - gpset $item $variable([lindex $values $position]) - } - incr position - } - } elseif {! [catch {dict size $variable}]} { - foreach item $map { - if {[winfo exists $item] && [winfo class $item] eq "TCombobox"} { - gpset [list $item [dict get $variable [lindex $values $position]]] - } else { - gpset $item [dict get $variable [lindex $values $position]] - } - incr position - } - } else { - error "GRIDPLUS ERROR: (gpmap) Array/Dict \"$arg\" does not exist." - } - } else { - switch -- $arg { - __direct {set start 0; set increment 1} - __left {set start 0; set increment 2} - __right {set start 1; set increment 2} - default {set start 0; set increment 1} - } - - set position $start - - foreach item $map { - if {[winfo exists $item] && [winfo class $item] eq "TCombobox"} { - gpset [list $item [lindex $values $position]] - } else { - gpset $item [lindex $values $position] - } - incr position $increment - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpnav # -# PURPOSE: Navigate to text label or calendar month. # -#=======================================================================# - -proc ::gridplus::gpnav {name target {increment {}}} { - - global {} - - if {[winfo exists $name.text]} { - $name.text yview $target - set ($name) $target - } elseif {[winfo exists $name.calendar]} { - if {$target in "current month year"} { - ::gridplus::gpCalendarNav $name $target $increment - } else { - if {[llength $target] == 1} { - foreach {month day year} [::gridplus::gpFormatDate $target internal] {} - if {! [::gridplus::gpCalCheckDate $month $day $year]} { - error "GRIDPLUS ERROR: (gpnav) \"$target\" is not a valid date." - } - } elseif {[llength $target] == 2} { - set day {} - set month [lindex $target 0] - set year [lindex $target 1] - if {[scan $month %d] < 1 || [scan $month %d] > 12} { - error "GRIDPLUS ERROR: (gpnav) \"$month\" is not a valid month." - } - if {! [string is integer $year]} { - error "GRIDPLUS ERROR: (gpnav) \"$year\" is not a valid year." - } - } - ::gridplus::gpCalendarDisplay $name $day $month $year - if {$increment ne ""} { - ::gridplus::gpCalendarNav $name month $increment - } - } - } else { - error "GRIDPLUS ERROR: (gpnav) Widget \"$name\" is not text or calendar." - } -} - -#=======================================================================# -# PROC : ::gridplus::gpoptions # -# PURPOSE: Set GRIDPLUS option database options. # -#=======================================================================# - -proc ::gridplus::gpoptions {args} { - - variable gpInfo - - switch -- [llength $args] { - 1 { - if {[expr [llength [lindex $args 0]] % 2] != 0} { - error "GRIDPLUS ERROR: (gpoption) Unmatched option/value." - } - foreach {option value} [lindex $args 0] { - option add *Gridplus.$option $value - } - } - 2 { - foreach {option value} $args {} - option add *Gridplus.$option $value - } - default { - error "GRIDPLUS ERROR: (gpoption) Wrong number of Args." - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gppaste # -# PURPOSE: Perform clipboard paste for item. # -#=======================================================================# - -proc ::gridplus::gppaste {{item {}}} { - - if {$item eq ""} { - set item [focus] - } - - if {[string match *.text $item] && [winfo class $item] eq "Text"} { - set textItem $item - } else { - set textItem $item.text - } - - if {[winfo exists $textItem]} { - tk_textPaste $textItem - $textItem edit modified 1 - } else { - if {! [catch {$item selection clear}]} { - $item insert insert [clipboard get] - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpselect # -# PURPOSE: Selects specified item in a tablelist/tree/calendar. # -#=======================================================================# - -proc ::gridplus::gpselect {args} { - global {} - - variable gpInfo - - set column 0 - set focus {} - set index 0 - set nocase {} - set restore 0 - set save 0 - set selectonly 0 - - set columnMatch 0 - set match {} - set sortOrder {} - - set count 1 - set option 1 - - foreach arg $args { - switch -glob -- $arg { - | {set columnMatch 1; set option 0} - -first {if {$option} {set index 1; set match 0}} - -focus {if {$option} {set focus "-focus"}} - -index {if {$option} {set index 1}} - -last {if {$option} {set index 1; set match "end"}} - -max {if {$option} {set sortOrder "decreasing"}} - -min {if {$option} {set sortOrder "increasing"}} - -restore {if {$option} {set restore 1}} - -row {if {$option} {set index 1}} - -save {if {$option} {set save 1}} - -selectonly {if {$option} {set selectonly 1}} - -- {set option 0} - default { - if {$option && [string match -* $arg]} { - error "GRIDPLUS ERROR: (gpselect) Invalid option ($arg)." - } - switch -- $count { - 1 {set name $arg; incr count} - 2 {set arg2 $arg; incr count} - 3 {set arg3 $arg; incr count} - } - } - } - } - - switch -- $count { - 3 {set match $arg2} - 4 {if {$columnMatch} { - set column $arg2 - set match $arg3 - } else { - set match $arg2 - set column $arg3} - } - } - - if {[winfo exists $name.tablelist]} { - if {$save} { - if {[$name.tablelist cget -selectmode] ni "browse single"} { - error "GRIDPLUS ERROR: (gpselect) Current selection save only allowed when tablelist selectmode is \"browse\" or \"single\"." - } - if {$match eq ""} { - set gpInfo($name:savedSelection) [$name.tablelist curselection] - } else { - set columnIndex [::gridplus::gpTablelistColumnIndex $name $match gpselect] - set gpInfo($name:savedSelection) [list [lindex [$name.tablelist get [$name.tablelist curselection]] $columnIndex] $columnIndex] - } - return - } - - if {$restore} { - if {[info exists gpInfo($name:savedSelection)]} { - if {[llength $gpInfo($name:savedSelection)] == 1} { - gpselect {*}$focus -index $name $gpInfo($name:savedSelection) - } else { - gpselect {*}$focus $name [lindex $gpInfo($name:savedSelection) 0] [lindex $gpInfo($name:savedSelection) 1] - } - } else { - error "GRIDPLUS ERROR: (gpselect) No selection saved for \"$name\"." - } - return - } - - if {$sortOrder ne ""} { - set columnIndex [::gridplus::gpTablelistColumnIndex $name $match gpselect] - set sortMode [$name.tablelist columncget $columnIndex -sortmode] - if {$sortMode eq "asciinocase"} { - set sortMode "ascii" - set nocase "-nocase" - } - set selectMatch [lindex [lsort {*}$nocase -$sortMode -$sortOrder -index $columnIndex [set [$name.tablelist itemlistvar]]] "0 $columnIndex"] - gpselect {*}$focus $name -- $selectMatch $columnIndex - return - } - - $name.tablelist selection clear 0 end - - if {$index} { - set row $match - if {$row ne "end" && $row >= [$name.tablelist size]} { - set row "end" - } - } else { - set columnIndex [::gridplus::gpTablelistColumnIndex $name $column gpselect] - set row [lsearch -exact [$name.tablelist getcolumn $columnIndex] $match] - if {$row == -1} { - error "GRIDPLUS ERROR: (gpselect) Tablelist line with match \"$match\" not found." - } - } - - $name.tablelist selection set $row - $name.tablelist activate $row - $name.tablelist see $row - - if {$gpInfo($name:action) eq "single"} { - ::gridplus::gpTablelistSelect $name $row $gpInfo($name:window) $gpInfo($name:validate) $gpInfo($name:command) - } else { - ::gridplus::gpTablelistSelect $name $row $gpInfo($name:window) $gpInfo($name:validate) {} - } - - if {$focus eq "-focus"} { - after idle focus [$name.tablelist bodypath] - $name.tablelist see $row - } - } elseif {[winfo exists $name.tree]} { - if {! [catch {$name.tree selection set $match}]} { - if {$gpInfo($name:action) eq "single"} { - ::gridplus::gpTreeSelect $name $gpInfo($name:window) $gpInfo($name:validate) $gpInfo($name:command) - } else { - ::gridplus::gpTreeSelect $name $gpInfo($name:window) $gpInfo($name:validate) {} - } - - if {$focus eq "-focus"} { - after idle focus $name.tree - $name.tree see $match - } - } else { - error "GRIDPLUS ERROR: (gpselect) Tree node \"$match\" not found." - } - } elseif {[winfo exists $name.calendar]} { - if {$match ne ""} { - foreach {month day year} [::gridplus::gpFormatDate $match internal] {} - if {! [::gridplus::gpCalCheckDate $month $day $year]} { - error "GRIDPLUS ERROR: (gpselect) \"$match\" is not a valid date." - } - set gpInfo($name:selecttoday) 1 - ::gridplus::gpCalendarDisplay $name $day $month $year - } else { - if {$gpInfo($name:variable) ne ""} { - set variable $gpInfo($name:variable) - } else { - set variable $name - } - - if {! $selectonly} { - set ($variable) {} - } - - if {[info exists gpInfo($name:selected)] && $gpInfo($name:selected) ne ""} { - $gpInfo($name:selected) configure -bg $gpInfo($name:bg) -fg $gpInfo($name:fg) - unset gpInfo($name:selected) - unset gpInfo($name:selectedday) - unset gpInfo($name:selectedmonth) - unset gpInfo($name:selectedyear) - } - } - } else { - error "GRIDPLUS ERROR: (gpselect) Widget \"$name\" is not calendar, tablelist or tree." - } -} - -#=======================================================================# -# PROC : ::gridplus::gpset # -# PURPOSE: Set GRIDPLUS "variable(s)". # -#=======================================================================# - -proc ::gridplus::gpset {args} { - global {} - - variable gpInfo - - update idletasks - - switch -- [llength $args] { - 1 { - if {[expr [llength [lindex $args 0]] % 2] != 0} { - error "GRIDPLUS ERROR: (gpset) Unmatched item/value." - } - foreach {item value} [lindex $args 0] { - if {[winfo exists $item.text]} { - $item.text delete 1.0 end - $item.text insert end $value - set ($item) $value - } elseif {[winfo exists $item.calendar]} { - ::gridplus::gpset -calendar $item $value - } else { - set ($item) $value - } - } - } - 2 { - set item [lindex $args 0] - set value [lindex $args 1] - if {[winfo exists $item.tablelist]} { - unset -nocomplain ($item) - $item.tablelist delete 0 end - foreach line $value { - ::gridplus::gpTablelistInsert $item end $line 1 - } - if {$gpInfo($item:columnsort)} { - if {$gpInfo($item:maintainsort) && [info exists gpInfo($item:lastsortcolumn)]} { - $item.tablelist sortbycolumn $gpInfo($item:lastsortcolumn) -$gpInfo($item:lastsortorder) - } else { - $item.tablelist sortbycolumn $gpInfo($item:firstcolumn) -$gpInfo($item:sortorder) - } - } - if {$gpInfo($item:selectfirst) && ! [info exists gpInfo($item:savedSelection)]} { - $item.tablelist selection set 0 - $item.tablelist activate 0 - set ($item) [$item.tablelist get 0] - } - } elseif {[winfo exists $item.text]} { - set textState [$item.text cget -state] - $item.text configure -state normal - if {$gpInfo($item:tags)} { - $item.text delete 1.0 end - ::gridplus::gpParseTags $item $value end - $item.text tag raise sel - } else { - $item.text delete 1.0 end - $item.text insert end $value - $item.text edit modified 0 - set ($item) $value - } - $item.text configure -state $textState - } elseif {[winfo exists $item.tree]} { - ::gridplus::gpTreeSet $item $value - } elseif {[winfo exists $item.calendar]} { - ::gridplus::gpselect $item $value - } elseif {[winfo exists $item] && [winfo class $item] eq "TCombobox" && ! [info exists gpInfo($item:datecommand)]} { - $item configure -value $value - } else { - set ($item) $value - } - } - 3 { - set option [lindex $args 0] - set item [lindex $args 1] - set value [lindex $args 2] - switch -- $option { - -| {::gridplus::gpset $item [::gridplus::gpDedent $value]} - -names {::gridplus::gpTablelistSetColumns $item -name $value} - -titles {::gridplus::gpTablelistSetColumns $item -title $value} - default {::gridplus::gpselect $item $value $option} - } - } - default { - error "GRIDPLUS ERROR: (gpset) Wrong number of Args." - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpunset # -# PURPOSE: Unset GRIDPLUS "variable(s)". # -#=======================================================================# - -proc ::gridplus::gpunset {args} { - global {} - - foreach pattern $args { - foreach item [array names {} $pattern] { - if {[info exists ($item)]} { - unset ($item) - } - if {[winfo exists $item.tablelist]} { - $item.tablelist delete 0 end - } elseif {[winfo exists $item.text]} { - $item.text delete 1.0 end - } elseif {[winfo exists $item.tree]} { - $item.tree configure -state normal - $item.tree delete 1.0 end - $item.tree configure -state disabled - } - } - } -} - -#=======================================================================# -# PROC : ::gridplus::gpupdate # -# PURPOSE: Updates specified row in a tablelist. # -#=======================================================================# - -proc ::gridplus::gpupdate {args} { - global {} - - variable gpInfo - - set focus 0 - set index 0 - set select 0 - - set column 0 - set current 0 - set match {} - set target {} - set value {} - - set count 1 - set option 1 - - foreach arg $args { - switch -glob -- $arg { - | {set option 0} - -focus {if {$option} {set focus 1}} - -index {if {$option} {set index 1}} - -row {if {$option} {set index 1}} - -select {if {$option} {set select 1}} - -- {set option 0} - default { - if {$option && [string match -* $arg]} { - error "GRIDPLUS ERROR: (gpupdate) Invalid option ($arg)." - } - switch -- $count { - 1 {set name $arg; incr count} - 2 {set arg2 $arg; incr count} - 3 {set arg3 $arg; incr count} - 4 {set arg4 $arg; incr count} - 5 {set arg5 $arg; incr count} - } - } - } - } - - set currentSelection [$name.tablelist curselection] - - switch -- $count { - 3 {set index 1 - set current 1 - set match $currentSelection - set value $arg2 - # gpupdate .mytable {row data} - } - 4 {if {$index} { - set match $arg2 - set value $arg3 - # gpupdate .mytable -row 99 {row data} - } else { - set index 1 - set current 1 - set match $currentSelection - set target $arg2 - set value $arg3 - # gpupdate .mytable | mytarget "value" - } - } - 5 {if {$index} { - set match $arg2 - set target $arg3 - set value $arg4 - # gpupdate .mytable -row 99 | mytarget "value" - } else { - set column $arg2 - set match $arg3 - set value $arg4 - # gpupdate .mytable | mycolumn "my match" | {row data} - } - } - 6 {set column $arg2 - set match $arg3 - set target $arg4 - set value $arg5 - # gpupdate .mytable | mycolumn "my match" | mytarget "value" - } - default { - error "GRIDPLUS ERROR: (gpupdate) Invalid number of Args." - } - } - - if {[winfo exists $name.tablelist]} { - if {$current && [$name.tablelist cget -selectmode] ni "browse single"} { - error "GRIDPLUS ERROR: (gpupdate) Current record update only allowed when tablelist selectmode is \"browse\" or \"single\"." - } - $name.tablelist selection clear 0 end - if {$index} { - set row $match - if {$row ne "end" && $row >= [$name.tablelist size]} { - set row "end" - } - } else { - set columnIndex [::gridplus::gpTablelistColumnIndex $name $column gpupdate] - set row [lsearch -exact [$name.tablelist getcolumn $columnIndex] $match] - if {$row == -1} { - error "GRIDPLUS ERROR: (gpupdate) Tablelist row with match \"$match\" not found." - } - } - - if {$target ne ""} { - set targetIndex [::gridplus::gpTablelistColumnIndex $name $target gpupdate] - set value [lreplace [$name.tablelist get $row] $targetIndex $targetIndex $value] - } - - ::gridplus::gpTablelistInsert $name $row $value 0 1 - - if {$select} { - gpselect $name -row $row - } elseif {$currentSelection ne ""} { - gpselect $name -row $currentSelection - } - if {$focus} { - after idle focus [$name.tablelist bodypath] - $name.tablelist see $row - } - } else { - error "GRIDPLUS ERROR: (gpupdate) Widget \"$name\" is not tablelist." - } -} - -#=======================================================================# -# PROC : ::gridplus::= # -# PURPOSE: Return specified (widget) option. # -#=======================================================================# - -proc ::gridplus::= {value key {default {}}} { - - if {[dict exists $value $key]} { - return [dict get $value $key] - } else { - return $default - } -} - -#=======================================================================# -# PROC : ::gridplus::=% # -# PURPOSE: Return state for widget group. # -#=======================================================================# - -proc ::gridplus::=% {name state {flag {}}} { - - variable gpInfo - - if {[info exists gpInfo($name:group)] && [info exists gpInfo($gpInfo($name:group))]} { - - set state $gpInfo($gpInfo($name:group)) - - if {$flag eq "!" && $state eq "disabled"} { - return "readonly" - } else { - return $state - } - } - - return $state -} - -#=======================================================================# -# PROC : ::gridplus::=: # -# PURPOSE: Create icon and return image name. # -#=======================================================================# - -proc ::gridplus::=: {icon} { - upvar 1 options options - - if {[lsearch [image names] ::icon::$icon] < 0} { - return "::icon::[::icons::icons create -file [file join $options(-iconpath) $options(-iconfile)] $icon]" - } else { - return "::icon::$icon" - } -} - -#=======================================================================# -# PROC : ::gridplus::=? # -# PURPOSE: Check if widget option has been set. # -#=======================================================================# - -proc ::gridplus::=? {value key} { - return [dict exists $value $key] -} - -#=======================================================================# -# PROC : ::gridplus::=@ # -# PURPOSE: Return default for widget. # -#=======================================================================# - -proc ::gridplus::=@ {name {default {}}} { - - variable gpInfo - - if {[info exists gpInfo(default:$name)]} { - return $gpInfo(default:$name) - } else { - return $default - } -} - -#=======================================================================# -# PROC : ::gridplus::=< # -# PURPOSE: Return specified widget option -or- default. # -#=======================================================================# - -proc ::gridplus::=< {option {default {}}} { - - set value [option get . "Gridplus.$option" -] - - if {$value eq ""} { - return $default - } else { - return $value - } -} - -#=======================================================================# -# End of Script: gridplus.tcl # -#=======================================================================# diff --git a/src/punk86.vfs/lib/gridplus2.11/pkgIndex.tcl b/src/punk86.vfs/lib/gridplus2.11/pkgIndex.tcl deleted file mode 100644 index d2e74a2d..00000000 --- a/src/punk86.vfs/lib/gridplus2.11/pkgIndex.tcl +++ /dev/null @@ -1 +0,0 @@ -package ifneeded gridplus 2.11 [list source [file join $dir gridplus.tcl]] \ No newline at end of file diff --git a/src/runtime/mapvfs.config b/src/runtime/mapvfs.config index f21d57e2..1aab40a1 100644 --- a/src/runtime/mapvfs.config +++ b/src/runtime/mapvfs.config @@ -4,7 +4,8 @@ #e.g #- myproject.vfs #- punk86.vfs -tclkit86bi.exe punk86.vfs +#tclkit86bi.exe punk86.vfs +tclkit8613.exe punk86.vfs #tclkit87a5bawt.exe punk86.vfs #tclkit86bi.exe vfs_windows/punk86win.vfs diff --git a/src/vendormodules/Thread-2.8.9.tm b/src/vendormodules/Thread-2.8.9.tm new file mode 100644 index 00000000..273d8c5a Binary files /dev/null and b/src/vendormodules/Thread-2.8.9.tm differ diff --git a/src/vendormodules/Thread/platform/win32_x86_64-2.8.9.tm b/src/vendormodules/Thread/platform/win32_x86_64-2.8.9.tm new file mode 100644 index 00000000..798ef624 Binary files /dev/null and b/src/vendormodules/Thread/platform/win32_x86_64-2.8.9.tm differ diff --git a/src/vendormodules/dictutils-0.2.1.tm b/src/vendormodules/dictutils-0.2.1.tm index cd6b4e58..12ca495b 100644 --- a/src/vendormodules/dictutils-0.2.1.tm +++ b/src/vendormodules/dictutils-0.2.1.tm @@ -1,145 +1,145 @@ -# dictutils.tcl -- - # - # Various dictionary utilities. - # - # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). - # - # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). - # - - #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" - - package require Tcl 8.6- - package provide dictutils 0.2.1 - - namespace eval dictutils { - namespace export equal apply capture witharray nlappend - namespace ensemble create - - # dictutils witharray dictVar arrayVar script -- - # - # Unpacks the elements of the dictionary in dictVar into the array - # variable arrayVar and then evaluates the script. If the script - # completes with an ok, return or continue status, then the result is copied - # back into the dictionary variable, otherwise it is discarded. A - # [break] can be used to explicitly abort the transaction. - # - proc witharray {dictVar arrayVar script} { - upvar 1 $dictVar dict $arrayVar array - array set array $dict - try { uplevel 1 $script - } on break {} { # Discard the result - } on continue result - on ok result { - set dict [array get array] ;# commit changes - return $result - } on return {result opts} { - set dict [array get array] ;# commit changes - dict incr opts -level ;# remove this proc from level - return -options $opts $result - } - # All other cases will discard the changes and propagage - } - - # dictutils equal equalp d1 d2 -- - # - # Compare two dictionaries for equality. Two dictionaries are equal - # if they (a) have the same keys, (b) the corresponding values for - # each key in the two dictionaries are equal when compared using the - # equality predicate, equalp (passed as an argument). The equality - # predicate is invoked with the key and the two values from each - # dictionary as arguments. - # - proc equal {equalp d1 d2} { - if {[dict size $d1] != [dict size $d2]} { return 0 } - dict for {k v} $d1 { - if {![dict exists $d2 $k]} { return 0 } - if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } - } - return 1 - } - - # apply dictVar lambdaExpr ?arg1 arg2 ...? -- - # - # A combination of *dict with* and *apply*, this procedure creates a - # new procedure scope populated with the values in the dictionary - # variable. It then applies the lambdaTerm (anonymous procedure) in - # this new scope. If the procedure completes normally, then any - # changes made to variables in the dictionary are reflected back to - # the dictionary variable, otherwise they are ignored. This provides - # a transaction-style semantics whereby atomic updates to a - # dictionary can be performed. This procedure can also be useful for - # implementing a variety of control constructs, such as mutable - # closures. - # - proc apply {dictVar lambdaExpr args} { - upvar 1 $dictVar dict - set env $dict ;# copy - lassign $lambdaExpr params body ns - if {$ns eq ""} { set ns "::" } - set body [format { - upvar 1 env __env__ - dict with __env__ %s - } [list $body]] - set lambdaExpr [list $params $body $ns] - set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] - if {$rc == 0} { - # Copy back any updates - set dict $env - } - return -options $opts $ret - } - - # capture ?level? ?exclude? ?include? -- - # - # Captures a snapshot of the current (scalar) variable bindings at - # $level on the stack into a dictionary environment. This dictionary - # can later be used with *dictutils apply* to partially restore the - # scope, creating a first approximation of closures. The *level* - # argument should be of the forms accepted by *uplevel* and - # designates which level to capture. It defaults to 1 as in uplevel. - # The *exclude* argument specifies an optional list of literal - # variable names to avoid when performing the capture. No variables - # matching any item in this list will be captured. The *include* - # argument can be used to specify a list of glob patterns of - # variables to capture. Only variables matching one of these - # patterns are captured. The default is a single pattern "*", for - # capturing all visible variables (as determined by *info vars*). - # - proc capture {{level 1} {exclude {}} {include {*}}} { - if {[string is integer $level]} { incr level } - set env [dict create] - foreach pattern $include { - foreach name [uplevel $level [list info vars $pattern]] { - if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } - upvar $level $name value - catch { dict set env $name $value } ;# no arrays - } - } - return $env - } - - # nlappend dictVar keyList ?value ...? - # - # Append zero or more elements to the list value stored in the given - # dictionary at the path of keys specified in $keyList. If $keyList - # specifies a non-existent path of keys, nlappend will behave as if - # the path mapped to an empty list. - # - proc nlappend {dictvar keylist args} { - upvar 1 $dictvar dict - if {[info exists dict] && [dict exists $dict {*}$keylist]} { - set list [dict get $dict {*}$keylist] - } - lappend list {*}$args - dict set dict {*}$keylist $list - } - - # invoke cmd args... -- - # - # Helper procedure to invoke a callback command with arguments at - # the global scope. The helper ensures that proper quotation is - # used. The command is expected to be a list, e.g. {string equal}. - # - proc invoke {cmd args} { uplevel #0 $cmd $args } - - } +# dictutils.tcl -- + # + # Various dictionary utilities. + # + # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). + # + # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). + # + + #2023 0.2.1 - changed "package require Tcl 8.6" to "package require Tcl 8.6-" + + package require Tcl 8.6- + package provide dictutils 0.2.1 + + namespace eval dictutils { + namespace export equal apply capture witharray nlappend + namespace ensemble create + + # dictutils witharray dictVar arrayVar script -- + # + # Unpacks the elements of the dictionary in dictVar into the array + # variable arrayVar and then evaluates the script. If the script + # completes with an ok, return or continue status, then the result is copied + # back into the dictionary variable, otherwise it is discarded. A + # [break] can be used to explicitly abort the transaction. + # + proc witharray {dictVar arrayVar script} { + upvar 1 $dictVar dict $arrayVar array + array set array $dict + try { uplevel 1 $script + } on break {} { # Discard the result + } on continue result - on ok result { + set dict [array get array] ;# commit changes + return $result + } on return {result opts} { + set dict [array get array] ;# commit changes + dict incr opts -level ;# remove this proc from level + return -options $opts $result + } + # All other cases will discard the changes and propagage + } + + # dictutils equal equalp d1 d2 -- + # + # Compare two dictionaries for equality. Two dictionaries are equal + # if they (a) have the same keys, (b) the corresponding values for + # each key in the two dictionaries are equal when compared using the + # equality predicate, equalp (passed as an argument). The equality + # predicate is invoked with the key and the two values from each + # dictionary as arguments. + # + proc equal {equalp d1 d2} { + if {[dict size $d1] != [dict size $d2]} { return 0 } + dict for {k v} $d1 { + if {![dict exists $d2 $k]} { return 0 } + if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } + } + return 1 + } + + # apply dictVar lambdaExpr ?arg1 arg2 ...? -- + # + # A combination of *dict with* and *apply*, this procedure creates a + # new procedure scope populated with the values in the dictionary + # variable. It then applies the lambdaTerm (anonymous procedure) in + # this new scope. If the procedure completes normally, then any + # changes made to variables in the dictionary are reflected back to + # the dictionary variable, otherwise they are ignored. This provides + # a transaction-style semantics whereby atomic updates to a + # dictionary can be performed. This procedure can also be useful for + # implementing a variety of control constructs, such as mutable + # closures. + # + proc apply {dictVar lambdaExpr args} { + upvar 1 $dictVar dict + set env $dict ;# copy + lassign $lambdaExpr params body ns + if {$ns eq ""} { set ns "::" } + set body [format { + upvar 1 env __env__ + dict with __env__ %s + } [list $body]] + set lambdaExpr [list $params $body $ns] + set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] + if {$rc == 0} { + # Copy back any updates + set dict $env + } + return -options $opts $ret + } + + # capture ?level? ?exclude? ?include? -- + # + # Captures a snapshot of the current (scalar) variable bindings at + # $level on the stack into a dictionary environment. This dictionary + # can later be used with *dictutils apply* to partially restore the + # scope, creating a first approximation of closures. The *level* + # argument should be of the forms accepted by *uplevel* and + # designates which level to capture. It defaults to 1 as in uplevel. + # The *exclude* argument specifies an optional list of literal + # variable names to avoid when performing the capture. No variables + # matching any item in this list will be captured. The *include* + # argument can be used to specify a list of glob patterns of + # variables to capture. Only variables matching one of these + # patterns are captured. The default is a single pattern "*", for + # capturing all visible variables (as determined by *info vars*). + # + proc capture {{level 1} {exclude {}} {include {*}}} { + if {[string is integer $level]} { incr level } + set env [dict create] + foreach pattern $include { + foreach name [uplevel $level [list info vars $pattern]] { + if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } + upvar $level $name value + catch { dict set env $name $value } ;# no arrays + } + } + return $env + } + + # nlappend dictVar keyList ?value ...? + # + # Append zero or more elements to the list value stored in the given + # dictionary at the path of keys specified in $keyList. If $keyList + # specifies a non-existent path of keys, nlappend will behave as if + # the path mapped to an empty list. + # + proc nlappend {dictvar keylist args} { + upvar 1 $dictvar dict + if {[info exists dict] && [dict exists $dict {*}$keylist]} { + set list [dict get $dict {*}$keylist] + } + lappend list {*}$args + dict set dict {*}$keylist $list + } + + # invoke cmd args... -- + # + # Helper procedure to invoke a callback command with arguments at + # the global scope. The helper ensures that proper quotation is + # used. The command is expected to be a list, e.g. {string equal}. + # + proc invoke {cmd args} { uplevel #0 $cmd $args } + + } diff --git a/src/vendormodules/dictutils-0.2.tm b/src/vendormodules/dictutils-0.2.tm deleted file mode 100644 index 154042e0..00000000 --- a/src/vendormodules/dictutils-0.2.tm +++ /dev/null @@ -1,143 +0,0 @@ -# dictutils.tcl -- - # - # Various dictionary utilities. - # - # Copyright (c) 2007 Neil Madden (nem@cs.nott.ac.uk). - # - # License: http://www.cs.nott.ac.uk/~nem/license.terms (Tcl-style). - # - - package require Tcl 8.6- - package provide dictutils 0.2 - - namespace eval dictutils { - namespace export equal apply capture witharray nlappend - namespace ensemble create - - # dictutils witharray dictVar arrayVar script -- - # - # Unpacks the elements of the dictionary in dictVar into the array - # variable arrayVar and then evaluates the script. If the script - # completes with an ok, return or continue status, then the result is copied - # back into the dictionary variable, otherwise it is discarded. A - # [break] can be used to explicitly abort the transaction. - # - proc witharray {dictVar arrayVar script} { - upvar 1 $dictVar dict $arrayVar array - array set array $dict - try { uplevel 1 $script - } on break {} { # Discard the result - } on continue result - on ok result { - set dict [array get array] ;# commit changes - return $result - } on return {result opts} { - set dict [array get array] ;# commit changes - dict incr opts -level ;# remove this proc from level - return -options $opts $result - } - # All other cases will discard the changes and propagage - } - - # dictutils equal equalp d1 d2 -- - # - # Compare two dictionaries for equality. Two dictionaries are equal - # if they (a) have the same keys, (b) the corresponding values for - # each key in the two dictionaries are equal when compared using the - # equality predicate, equalp (passed as an argument). The equality - # predicate is invoked with the key and the two values from each - # dictionary as arguments. - # - proc equal {equalp d1 d2} { - if {[dict size $d1] != [dict size $d2]} { return 0 } - dict for {k v} $d1 { - if {![dict exists $d2 $k]} { return 0 } - if {![invoke $equalp $k $v [dict get $d2 $k]]} { return 0 } - } - return 1 - } - - # apply dictVar lambdaExpr ?arg1 arg2 ...? -- - # - # A combination of *dict with* and *apply*, this procedure creates a - # new procedure scope populated with the values in the dictionary - # variable. It then applies the lambdaTerm (anonymous procedure) in - # this new scope. If the procedure completes normally, then any - # changes made to variables in the dictionary are reflected back to - # the dictionary variable, otherwise they are ignored. This provides - # a transaction-style semantics whereby atomic updates to a - # dictionary can be performed. This procedure can also be useful for - # implementing a variety of control constructs, such as mutable - # closures. - # - proc apply {dictVar lambdaExpr args} { - upvar 1 $dictVar dict - set env $dict ;# copy - lassign $lambdaExpr params body ns - if {$ns eq ""} { set ns "::" } - set body [format { - upvar 1 env __env__ - dict with __env__ %s - } [list $body]] - set lambdaExpr [list $params $body $ns] - set rc [catch { ::apply $lambdaExpr {*}$args } ret opts] - if {$rc == 0} { - # Copy back any updates - set dict $env - } - return -options $opts $ret - } - - # capture ?level? ?exclude? ?include? -- - # - # Captures a snapshot of the current (scalar) variable bindings at - # $level on the stack into a dictionary environment. This dictionary - # can later be used with *dictutils apply* to partially restore the - # scope, creating a first approximation of closures. The *level* - # argument should be of the forms accepted by *uplevel* and - # designates which level to capture. It defaults to 1 as in uplevel. - # The *exclude* argument specifies an optional list of literal - # variable names to avoid when performing the capture. No variables - # matching any item in this list will be captured. The *include* - # argument can be used to specify a list of glob patterns of - # variables to capture. Only variables matching one of these - # patterns are captured. The default is a single pattern "*", for - # capturing all visible variables (as determined by *info vars*). - # - proc capture {{level 1} {exclude {}} {include {*}}} { - if {[string is integer $level]} { incr level } - set env [dict create] - foreach pattern $include { - foreach name [uplevel $level [list info vars $pattern]] { - if {[lsearch -exact -index 0 $exclude $name] >= 0} { continue } - upvar $level $name value - catch { dict set env $name $value } ;# no arrays - } - } - return $env - } - - # nlappend dictVar keyList ?value ...? - # - # Append zero or more elements to the list value stored in the given - # dictionary at the path of keys specified in $keyList. If $keyList - # specifies a non-existent path of keys, nlappend will behave as if - # the path mapped to an empty list. - # - proc nlappend {dictvar keylist args} { - upvar 1 $dictvar dict - if {[info exists dict] && [dict exists $dict {*}$keylist]} { - set list [dict get $dict {*}$keylist] - } - lappend list {*}$args - dict set dict {*}$keylist $list - } - - # invoke cmd args... -- - # - # Helper procedure to invoke a callback command with arguments at - # the global scope. The helper ensures that proper quotation is - # used. The command is expected to be a list, e.g. {string equal}. - # - proc invoke {cmd args} { uplevel #0 $cmd $args } - - } diff --git a/src/vendormodules/gridplus-2.11.tm b/src/vendormodules/gridplus-2.11.tm new file mode 100644 index 00000000..c3d7957e Binary files /dev/null and b/src/vendormodules/gridplus-2.11.tm differ diff --git a/src/vendormodules/include_modules.config b/src/vendormodules/include_modules.config new file mode 100644 index 00000000..258273ca --- /dev/null +++ b/src/vendormodules/include_modules.config @@ -0,0 +1,17 @@ + +set local_modules [list\ + c:/repo/jn/tclmodules/overtype/modules overtype\ + c:/repo/jn/tclmodules/modpod/modules modpod\ + c:/repo/jn/tclmodules/packageTest/modules packageTest\ + c:/repo/jn/tclmodules/gridplus/modules gridplus\ + c:/repo/jn/tclmodules/tablelist/modules tablelist\ + c:/repo/jn/tclmodules/tablelist/modules tablelist_tile\ + c:/repo/jn/tclmodules/Thread/modules Thread\ + c:/repo/jn/tclmodules/Thread/modules Thread::platform::win32_x86_64\ +] + +set fossil_modules [dict create\ +] + +set git_modules [dict create\ +] \ No newline at end of file diff --git a/src/vendormodules/md5-2.0.8.tm b/src/vendormodules/md5-2.0.8.tm index f021c0ac..51f35dce 100644 --- a/src/vendormodules/md5-2.0.8.tm +++ b/src/vendormodules/md5-2.0.8.tm @@ -16,7 +16,7 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # ------------------------------------------------------------------------- -package require Tcl 8.2; # tcl minimum version +package require Tcl 8.2-; # tcl minimum version namespace eval ::md5 { variable accel diff --git a/src/vendormodules/modpod-0.1.0.tm b/src/vendormodules/modpod-0.1.0.tm new file mode 100644 index 00000000..84c4e754 --- /dev/null +++ b/src/vendormodules/modpod-0.1.0.tm @@ -0,0 +1,700 @@ +# -*- 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) 2024 +# +# @@ Meta Begin +# Application modpod 0.1.0 +# Meta platform tcl +# Meta license +# @@ Meta End + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# doctools header +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[manpage_begin modpod_module_modpod 0 0.1.0] +#[copyright "2024"] +#[titledesc {Module API}] [comment {-- Name section and table of contents description --}] +#[moddesc {-}] [comment {-- Description at end of page heading --}] +#[require modpod] +#[keywords module] +#[description] +#[para] - + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section Overview] +#[para] overview of modpod +#[subsection Concepts] +#[para] - + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Requirements +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[subsection dependencies] +#[para] packages used by modpod +#[list_begin itemized] + +package require Tcl 8.6- +package require struct::set ;#review +package require punk::lib +package require punk::args +#*** !doctools +#[item] [package {Tcl 8.6-}] + +# #package require frobz +# #*** !doctools +# #[item] [package {frobz}] + +#*** !doctools +#[list_end] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +#*** !doctools +#[section API] + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# oo::class namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::class { + #*** !doctools + #[subsection {Namespace modpod::class}] + #[para] class definitions + if {[info commands [namespace current]::interface_sample1] eq ""} { + #*** !doctools + #[list_begin enumerated] + + # oo::class create interface_sample1 { + # #*** !doctools + # #[enum] CLASS [class interface_sample1] + # #[list_begin definitions] + + # method test {arg1} { + # #*** !doctools + # #[call class::interface_sample1 [method test] [arg arg1]] + # #[para] test method + # puts "test: $arg1" + # } + + # #*** !doctools + # #[list_end] [comment {-- end definitions interface_sample1}] + # } + + #*** !doctools + #[list_end] [comment {--- end class enumeration ---}] + } +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Base namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod { + namespace export {[a-z]*}; # Convention: export all lowercase + + variable connected + if {![info exists connected(to)]} { + set connected(to) list + } + variable modpodscript + set modpodscript [info script] + if {[string tolower [file extension $modpodscript]] eq ".tcl"} { + set connected(self) [file dirname $modpodscript] + } else { + #expecting a .tm + set connected(self) $modpodscript + } + variable loadables [info sharedlibextension] + variable sourceables {.tcl .tk} ;# .tm ? + + #*** !doctools + #[subsection {Namespace modpod}] + #[para] Core API functions for modpod + #[list_begin definitions] + + + + #proc sample1 {p1 args} { + # #*** !doctools + # #[call [fun sample1] [arg p1] [opt {?option value...?}]] + # #[para]Description of sample1 + # return "ok" + #} + + proc connect {args} { + puts stderr "modpod::connect--->>$args" + set argd [punk::args::get_dict { + -type -default "" + *values -min 1 -max 1 + path -type string -minlen 1 -help "path to .tm file or toplevel .tcl script within #modpod-- folder (unwrapped modpod)" + } $args] + catch { + punk::lib::showdict $argd ;#heavy dependencies + } + set opt_path [dict get $argd values path] + variable connected + set original_connectpath $opt_path + set modpodpath [modpod::system::normalize $opt_path] ;# + + if {$modpodpath in $connected(to)} { + return [dict create ok ALREADY_CONNECTED] + } + lappend connected(to) $modpodpath + + set connected(connectpath,$opt_path) $original_connectpath + set is_sourced [expr {[file normalize $modpodpath] eq [file normalize [info_script]]}] + + set connected(location,$modpodpath) [file dirname $modpodpath] + set connected(startdata,$modpodpath) -1 + set connected(type,$modpodpath) [dict get $argd-opts -type] + set connected(fh,$modpodpath) "" + + if {[string range [file tail $modpodpath] 0 7] eq "#modpod-"} { + set connected(type,$modpodpath) "unwrapped" + lassign [::split [file tail [file dirname $modpodpath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname [file dirname $modpodpath]] + + } else { + #connect to .tm but may still be unwrapped version available + lassign [::split [file rootname [file tail $modpodath]] -] connected(package,$modpodpath) connected(version,$modpodpath) + set this_pkg_tm_folder [file dirname $modpodpath] + if {$connected(type,$modpodpath) ne "unwrapped"} { + #Not directly connected to unwrapped version - but may still be redirected there + set unwrappedFolder [file join $connected(location,$modpodpath) #modpod-$connected(package,$modpodpath)-$connected(version,$modpodpath)] + if {[file exists $unwrappedFolder]} { + #folder with exact version-match must exist for redirect to 'unwrapped' + set con(type,$modpodpath) "modpod-redirecting" + } + } + + } + set unwrapped_tm_file [file join $this_pkg_tm_folder] "[set connected(package,$modpodpath)]-[set connected(version,$modpodpath)].tm" + set connected(tmfile,$modpodpath) + set tail_segments [list] + set lcase_tmfile_segments [string tolower [file split $this_pkg_tm_folder]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [struct::set intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $this_pkg_tm_folder] [llength $mpath_segments] end] + break + } + } + if {[llength $tail_segments]} { + set connected(fullpackage,$modpodpath) [join [concat $tail_segments [set connected(package,$modpodpath)]] ::] ;#full name of package as used in package require + } else { + set connected(fullpackage,$modpodpath) [set connected(package,$modpodpath)] + } + + switch -exact -- $connected(type,$modpodpath) { + "modpod-redirecting" { + #redirect to the unwrapped version + set loadscript_name [file join $unwrappedFolder #modpod-loadscript-$con(package,$modpod).tcl] + + } + "unwrapped" { + if {[info commands ::thread::id] ne ""} { + set from [pid],[thread::id] + } else { + set from [pid] + } + #::modpod::Puts stderr "$from-> Package $connected(package,$modpodpath)-$connected(version,$modpodpath) is using unwrapped version: $modpodpath" + return [list ok ""] + } + default { + #autodetect .tm - zip/tar ? + #todo - use vfs ? + + #connect to tarball - start at 1st header + set connected(startdata,$modpodpath) 0 + set fh [open $modpodpath r] + set connected(fh,$modpodpath) $fh + fconfigure $fh -encoding iso8859-1 -translation binary -eofchar {} + + if {$connected(startdata,$modpodpath) >= 0} { + #verify we have a valid tar header + if {![catch {::modpod::system::tar::readHeader [red $fh 512]}]} { + seek $fh $connected(startdata,$modpodpath) start + return [list ok $fh] + } else { + #error "cannot verify tar header" + } + } + lpop connected(to) end + set connected(startdata,$modpodpath) -1 + unset connected(fh,$modpodpath) + catch {close $fh} + return [dict create err {Does not appear to be a valid modpod}] + } + } + } + proc disconnect {{modpod ""}} { + variable connected + if {![llength $connected(to)]} { + return 0 + } + if {$modpod eq ""} { + puts stderr "modpod::disconnect WARNING: modpod not explicitly specified. Disconnecting last connected: [lindex $connected(to) end]" + set modpod [lindex $connected(to) end] + } + + if {[set posn [lsearch $connected(to) $modpod]] == -1} { + puts stderr "modpod::disconnect WARNING: disconnect called when not connected: $modpod" + return 0 + } + if {[string length $connected(fh,$modpod)]} { + close $connected(fh,$modpod) + } + array unset connected *,$modpod + set connected(to) [lreplace $connected(to) $posn $posn] + return 1 + } + proc get {args} { + set argd [punk::args::get_dict { + -from -default "" -help "path to pod" + *values -min 1 -max 1 + filename + } $args] + set frompod [dict get $argd opts -from] + set filename [dict get $argd values filename] + + variable connected + set modpod [::tarjar::system::connect_if_not $frompod] + set fh $connected(fh,$modpod) + if {$connected(type,$modpod) eq "unwrapped"} { + #for unwrapped connection - $connected(location) already points to the #modpod-pkg-ver folder + if {[string range $filename 0 0 eq "/"]} { + #absolute path (?) + set path [file join $connected(location,$modpod) .. [string trim $filename /]] + } else { + #relative path - use #modpod-xxx as base + set path [file join $connected(location,$modpod) $filename] + } + set fd [open $path r] + #utf-8? + #fconfigure $fd -encoding iso8859-1 -translation binary + return [list ok [lindex [list [read $fd] [close $fd]] 0]] + } else { + #read from vfs + puts stderr "get $filename from wrapped pod '$frompod' not implemented" + } + } + + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +# Secondary API namespace +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +namespace eval modpod::lib { + namespace export {[a-z]*}; # Convention: export all lowercase + namespace path [namespace parent] + #*** !doctools + #[subsection {Namespace modpod::lib}] + #[para] Secondary functions that are part of the API + #[list_begin definitions] + + #proc utility1 {p1 args} { + # #*** !doctools + # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] + # #[para]Description of utility1 + # return 1 + #} + + proc is_valid_tm_version {versionpart} { + #Needs to be suitable for use with Tcl's 'package vcompare' + if {![catch [list package vcompare $versionparts $versionparts]]} { + return 1 + } else { + return 0 + } + } + proc make_zip_modpod {zipfile outfile} { + set mount_stub { + #zip file with Tcl loader prepended. + #generated using modpod::make_zip_modpod + if {[catch {file normalize [info script]} modfile]} { + error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" + } + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + if {[file exists $moddir/#modpod-$mod_and_ver]} { + source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #determine module namespace so we can mount appropriately + proc intersect {A B} { + if {[llength $A] == 0} {return {}} + if {[llength $B] == 0} {return {}} + if {[llength $B] > [llength $A]} { + set res $A + set A $B + set B $res + } + set res {} + foreach x $A {set ($x) {}} + foreach x $B { + if {[info exists ($x)]} { + lappend res $x + } + } + return $res + } + set lcase_tmfile_segments [string tolower [file split $moddir]] + set lcase_modulepaths [string tolower [tcl::tm::list]] + foreach lc_mpath $lcase_modulepaths { + set mpath_segments [file split $lc_mpath] + if {[llength [intersect $lcase_tmfile_segments $mpath_segments]] == [llength $mpath_segments]} { + set tail_segments [lrange [file split $moddir] [llength $mpath_segments] end] ;#use propertly cased tail + break + } + } + if {[llength $tail_segments]} { + set fullpackage [join [concat $tail_segments $moduletail] ::] ;#full name of package as used in package require + set mount_at #modpod/[file join {*}$tail_segments]/#mounted-modpod-$mod_and_ver + } else { + set fullpackage $moduletail + set mount_at #modpod/#mounted-modpod-$mod_and_ver + } + + if {[info commands tcl::zipfs::mount] ne ""} { + #argument order changed to be consistent with vfs::zip::Mount etc + #early versions: zipfs::Mount mountpoint zipname + #since 2023-09: zipfs::Mount zipname mountpoint + #don't use 'file exists' when testing mountpoints. (some versions at least give massive delays on non-existance) + set mountpoints [dict keys [tcl::zipfs::mount]] + if {"//zipfs:/$mount_at" ni $mountpoints} { + #despite API change tcl::zipfs package version was unfortunately not updated - so we don't know argument order without trying it + if {[catch { + #tcl::zipfs::mount $modfile //zipfs:/#mounted-modpod-$mod_and_ver ;#extremely slow if this is a wrong guess (artifact of aforementioned file exists issue ?) + puts "tcl::zipfs::mount $modfile $mount_at" + tcl::zipfs::mount $modfile $mount_at + } errM]} { + #try old api + puts stderr ">>> tcl::zipfs::mount //zipfs://$mount_at $modfile" + tcl::zipfs::mount //zipfs:/$mount_at $modfile + } + if {![file exists //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + puts stderr "zipfs mounts: [zipfs mount]" + #tcl::zipfs::unmount //zipfs:/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + # #modpod-$mod_and_ver subdirectory always present in the archive so it can be conveniently extracted and run in that form + source //zipfs:/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + #fallback to slower vfs::zip + #NB. We don't create the intermediate dirs - but the mount still works + if {![file exists $moddir/$mount_at]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver" + append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ + } + set fd [vfs::zip::Mount $modfile $moddir/$mount_at] + if {![file exists $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $moddir/$mount_at + error "Unable to find $mod_and_ver.tm in $modfile for module $fullpackage" + } + } + source $moddir/$mount_at/#modpod-$mod_and_ver/$mod_and_ver.tm + } + } + #zipped data follows + } + #todo - test if zipfile has #modpod-loadcript.tcl before even creating + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub + + } + proc make_zip_modpod1 {zipfile outfile} { + set mount_stub { + #zip file with Tcl loader prepended. + #generated using modpod::make_zip_modpod + if {[catch {file normalize [info script]} modfile]} { + error "modpod zip stub error. Unable to determine module path. (possible safe interp restrictions?)" + } + if {$modfile eq "" || ![file exists $modfile]} { + error "modpod zip stub error. Unable to determine module path" + } + set moddir [file dirname $modfile] + set mod_and_ver [file rootname [file tail $modfile]] + lassign [split $mod_and_ver -] moduletail version + if {[file exists $moddir/#modpod-$mod_and_ver]} { + source $moddir/#modpod-$mod_and_ver/$mod_and_ver.tm + } else { + if {![file exists $moddir/#mounted-modpod-$mod_and_ver]} { + if {[catch {package require vfs::zip} errM]} { + set msg "Unable to load vfs::zip package to mount module $mod_and_ver" + append msg \n "If vfs::zip is unavailable - the module can still be loaded by manually unzipping the file $modfile in place." + append msg \n "The unzipped data will all be contained in a folder named #modpod-$mod_and_ver in the same parent folder as $ + } + set fd [vfs::zip::Mount $modfile $moddir/#mounted-modpod-$mod_and_ver] + if {![file exists $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm]} { + vfs::zip::Unmount $fd $moddir/#mounted-modpod-$mod_and_ver + error "Unable to find #modpod-$mod_and_ver/$mod_and_ver.tm in $modfile" + } + } + source $moddir/#mounted-modpod-$mod_and_ver/#modpod-$mod_and_ver/$mod_and_ver.tm + } + #zipped data follows + } + #todo - test if zipfile has #modpod-loadcript.tcl before even creating + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub + + } + proc make_zip_source_mountable {zipfile outfile} { + set mount_stub { + package require vfs::zip + vfs::zip::Mount [info script] [info script] + } + append mount_stub \x1A + modpod::system::make_mountable_zip $zipfile $outfile $mount_stub + } + + #*** !doctools + #[list_end] [comment {--- end definitions namespace modpod::lib ---}] +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ + + + +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +#*** !doctools +#[section Internal] +namespace eval modpod::system { + #*** !doctools + #[subsection {Namespace modpod::system}] + #[para] Internal functions that are not part of the API + + #deflate,store only supported + proc make_mountable_zip {zipfile outfile mount_stub} { + set in [open $zipfile r] + fconfigure $in -encoding iso8859-1 -translation binary + set out [open $outfile w+] + fconfigure $out -encoding iso8859-1 -translation binary + puts -nonewline $out $mount_stub + set offset [tell $out] + lappend report "sfx stub size: $offset" + fcopy $in $out + + close $in + set size [tell $out] + #Now seek in $out to find the end of directory signature: + #The structure itself is 24 bytes Long, followed by a maximum of 64Kbytes text + if {$size < 65559} { + set seek 0 + } else { + set seek [expr {$size - 65559}] + } + seek $out $seek + set data [read $out] + set start_of_end [string last "\x50\x4b\x05\x06" $data] + #set start_of_end [expr {$start_of_end + $seek}] + incr start_of_end $seek + + lappend report "START-OF-END: $start_of_end ([expr {$start_of_end - $size}]) [string length $data]" + + seek $out $start_of_end + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + lappend report "End of central directory: [array get eocd]" + seek $out [expr {$start_of_end+16}] + + #adjust offset of start of central directory by the length of our sfx stub + puts -nonewline $out [binary format i [expr {$eocd(diroffset) + $offset}]] + flush $out + + seek $out $start_of_end + set end_of_ctrl_dir [read $out] + binary scan $end_of_ctrl_dir issssiis eocd(signature) eocd(disknbr) eocd(ctrldirdisk) \ + eocd(numondisk) eocd(totalnum) eocd(dirsize) eocd(diroffset) eocd(comment_len) + + # 0x06054b50 - end of central dir signature + puts stderr "$end_of_ctrl_dir" + puts stderr "comment_len: $eocd(comment_len)" + puts stderr "eocd sig: $eocd(signature) [punk::lib::dec2hex $eocd(signature)]" + lappend report "New dir offset: $eocd(diroffset)" + lappend report "Adjusting $eocd(totalnum) zip file items." + catch { + punk::lib::showdict -roottype list -chan stderr $report ;#heavy dependencies + } + + seek $out $eocd(diroffset) + for {set i 0} {$i <$eocd(totalnum)} {incr i} { + set current_file [tell $out] + set fileheader [read $out 46] + puts -------------- + puts [ansistring VIEW -lf 1 $fileheader] + puts -------------- + #binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + # x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + + binary scan $fileheader ic4sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + set ::last_header $fileheader + + puts "sig: $x(sig) (hex: [punk::lib::dec2hex $x(sig)])" + puts "ver: $x(version)" + puts "method: $x(method)" + + #33639248 dec = 0x02014b50 - central file header signature + if { $x(sig) != 33639248 } { + error "modpod::system::make_mountable_zip Bad file header signature at item $i: dec:$x(sig) hex:[punk::lib::dec2hex $x(sig)]" + } + + foreach size $x(lengths) var {filename extrafield comment} { + if { $size > 0 } { + set x($var) [read $out $size] + } else { + set x($var) "" + } + } + set next_file [tell $out] + lappend report "file $i: $x(offset) $x(sizes) $x(filename)" + + seek $out [expr {$current_file+42}] + puts -nonewline $out [binary format i [expr {$x(offset)+$offset}]] + + #verify: + flush $out + seek $out $current_file + set fileheader [read $out 46] + lappend report "old $x(offset) + $offset" + binary scan $fileheader is2sss2ii2s3ssii x(sig) x(version) x(flags) x(method) \ + x(date) x(crc32) x(sizes) x(lengths) x(diskno) x(iattr) x(eattr) x(offset) + lappend report "new $x(offset)" + + seek $out $next_file + } + close $out + #pdict/showdict reuire punk & textlib - ie lots of dependencies + #don't fall over just because of that + catch { + punk::lib::showdict -roottype list -chan stderr $report + } + #puts [join $report \n] + return + } + + proc connect_if_not {{podpath ""}} { + upvar ::modpod::connected connected + set podpath [::modpod::system::normalize $podpath] + set docon 0 + if {![llength $connected(to)]} { + if {![string length $podpath]} { + error "modpod::system::connect_if_not - Not connected to a modpod file, and no podpath specified" + } else { + set docon 1 + } + } else { + if {![string length $podpath]} { + set podpath [lindex $connected(to) end] + puts stderr "modpod::system::connect_if_not WARNING: using last connected modpod:$podpath for operation\n -podpath not explicitly specified during operation: [info level -1]" + } else { + if {$podpath ni $connected(to)} { + set docon 1 + } + } + } + if {$docon} { + if {[lindex [modpod::connect $podpath]] 0] ne "ok"} { + error "modpod::system::connect_if_not error. file $podpath does not seem to be a valid modpod" + } else { + return $podpath + } + } + #we were already connected + return $podpath + } + + proc myversion {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myversion should only be called from within a loading modpod" + } + set fname [file tail [file rootname [file normalize $script]]] + set scriptdir [file dirname $script] + + if {![string match "#modpod-*" $fname]} { + lassign [lrange [split $fname -] end-1 end] _pkgname version + } else { + lassign [scan [file tail [file rootname $script]] {#modpod-loadscript-%[a-z]-%s}] _pkgname version + if {![string length $version]} { + #try again on the name of the containing folder + lassign [scan [file tail $scriptdir] {#modpod-%[a-z]-%s}] _pkgname version + #todo - proper walk up the directory tree + if {![string length $version]} { + #try again on the grandparent folder (this is a standard depth for sourced .tcl files in a modpod) + lassign [scan [file tail [file dirname $scriptdir]] {#modpod-%[a-z]-%s}] _pkgname version + } + } + } + + #tarjar::Log debug "'myversion' determined version for [info script]: $version" + return $version + } + + proc myname {} { + upvar ::modpod::connected connected + set script [info script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myname should only be called from within a loading modpod" + } + return $connected(fullpackage,$script) + } + proc myfullname {} { + upvar ::modpod::connected connected + set script [info script] + #set script [::tarjar::normalize $script] + set script [file normalize $script] + if {![string length $script]} { + error "No result from \[info script\] - modpod::system::myfullname should only be called from within a loading tarjar" + } + return $::tarjar::connected(fullpackage,$script) + } + proc normalize {path} { + #newer versions of Tcl don't do tilde sub + + #Tcl's 'file normalize' seems to do some unfortunate tilde substitution on windows.. (at least for relative paths) + # we take the assumption here that if Tcl's tilde substitution is required - it should be done before the path is provided to this function. + set matilda "<_tarjar_tilde_placeholder_>" ;#token that is *unlikely* to occur in the wild, and is somewhat self describing in case it somehow ..escapes.. + set path [string map [list ~ $matilda] $path] ;#give our tildes to matilda to look after + set path [file normalize $path] + #set path [string tolower $path] ;#must do this after file normalize + return [string map [list $matilda ~] $path] ;#get our tildes back. +} +} +# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +## Ready +package provide modpod [namespace eval modpod { + variable pkg modpod + variable version + set version 0.1.0 +}] +return + +#*** !doctools +#[manpage_end] + diff --git a/src/bootsupport/modules/overtype-1.6.3.tm b/src/vendormodules/overtype-1.6.5.tm similarity index 87% rename from src/bootsupport/modules/overtype-1.6.3.tm rename to src/vendormodules/overtype-1.6.5.tm index ef12e956..143794fb 100644 --- a/src/bootsupport/modules/overtype-1.6.3.tm +++ b/src/vendormodules/overtype-1.6.5.tm @@ -7,7 +7,7 @@ # (C) Julian Noble 2003-2023 # # @@ Meta Begin -# Application overtype 1.6.3 +# Application overtype 1.6.5 # Meta platform tcl # Meta license BSD # @@ Meta End @@ -17,7 +17,7 @@ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools -#[manpage_begin overtype_module_overtype 0 1.6.3] +#[manpage_begin overtype_module_overtype 0 1.6.5] #[copyright "2024"] #[titledesc {overtype text layout - ansi aware}] [comment {-- Name section and table of contents description --}] #[moddesc {overtype text layout}] [comment {-- Description at end of page heading --}] @@ -65,7 +65,15 @@ package require punk::assertion #*** !doctools #[list_end] - +#PERFORMANCE notes +#overtype is very performance sensitive - used in ansi output all over the place ie needs to be optimised +#NOTE use of tcl::dict::for tcl::string::range etc instead of ensemble versions. This is for the many tcl 8.6/8.7 interps which don't compile ensemble commands when in safe interps +#similar for tcl::namespace::eval - but this is at least on some versions of Tcl - faster even in a normal interp. Review to see if that holds for Tcl 9. +#for string map: when there are exactly 2 elements - it is faster to use a literal which has a special case optimisation in the c code +#ie use tcl::string::map {\n ""} ... instead of tcl::string::map [list \n ""] ... +#note that we can use unicode (e.g \uFF31) and other escapes such as \t within these curly braces - we don't have to use double quotes +#generally using 'list' is preferred for the map as less error prone. +#can also use: tcl::string::map "token $var" .. but be careful regarding quoting and whitespace in var. This should be used sparingly if at all. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ @@ -78,10 +86,10 @@ package require punk::assertion # #todo - ellipsis truncation indicator for center,right -#v1.4 2023-07 - naive ansi color handling - todo - fix string range +#v1.4 2023-07 - naive ansi color handling - todo - fix tcl::string::range # - need to extract and replace ansi codes? -namespace eval overtype { +tcl::namespace::eval overtype { namespace import ::punk::assertion::assert punk::assertion::active true @@ -90,7 +98,7 @@ namespace eval overtype { namespace export * variable default_ellipsis_horizontal "..." ;#fallback variable default_ellipsis_vertical "..." - namespace eval priv { + tcl::namespace::eval priv { proc _init {} { upvar ::overtype::default_ellipsis_horizontal e_h upvar ::overtype::default_ellipsis_vertical e_v @@ -112,18 +120,18 @@ proc overtype::about {} { return "Simple text formatting. Author JMN. BSD-License" } -namespace eval overtype { - variable grapheme_widths [dict create] +tcl::namespace::eval overtype { + variable grapheme_widths [tcl::dict::create] variable escape_terminals #single "final byte" in the range 0x40–0x7E (ASCII @A–Z[\]^_`a–z{|}~). - dict set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] - #dict set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic - dict set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals + tcl::dict::set escape_terminals CSI [list @ \\ ^ _ ` | ~ a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z "\{" "\}"] + #tcl::dict::set escape_terminals CSI [list J K m n A B C D E F G s u] ;#basic + tcl::dict::set escape_terminals OSC [list \007 \033\\] ;#note mix of 1 and 2-byte terminals #self-contained 2 byte ansi escape sequences - review more? variable ansi_2byte_codes_dict - set ansi_2byte_codes_dict [dict create\ + set ansi_2byte_codes_dict [tcl::dict::create\ "reset_terminal" "\u001bc"\ "save_cursor_posn" "\u001b7"\ "restore_cursor_posn" "\u001b8"\ @@ -138,66 +146,12 @@ namespace eval overtype { } -#proc overtype::stripansi {text} { -# variable escape_terminals ;#dict -# variable ansi_2byte_codes_dict -# #important that we don't spend too much time on this for plain text that doesn't contain any escapes anyway -# if {[string first \033 $text] <0 && [string first \009c $text] <0} { -# #\033 same as \x1b -# return $text -# } -# -# set text [convert_g0 $text] -# -# #we process char by char - line-endings whether \r\n or \n should be processed as per any other character. -# #line endings can theoretically occur within an ansi escape sequence (review e.g title?) -# set inputlist [split $text ""] -# set outputlist [list] -# -# set 2bytecodes [dict values $ansi_2byte_codes_dict] -# -# set in_escapesequence 0 -# #assumption - undertext already 'rendered' - ie no backspaces or carriagereturns or other cursor movement controls -# set i 0 -# foreach u $inputlist { -# set v [lindex $inputlist $i+1] -# set uv ${u}${v} -# if {$in_escapesequence eq "2b"} { -# #2nd byte - done. -# set in_escapesequence 0 -# } elseif {$in_escapesequence != 0} { -# set escseq [dict get $escape_terminals $in_escapesequence] -# if {$u in $escseq} { -# set in_escapesequence 0 -# } elseif {$uv in $escseq} { -# set in_escapseequence 2b ;#flag next byte as last in sequence -# } -# } else { -# #handle both 7-bit and 8-bit CSI and OSC -# if {[regexp {^(?:\033\[|\u009b)} $uv]} { -# set in_escapesequence CSI -# } elseif {[regexp {^(?:\033\]|\u009c)} $uv]} { -# set in_escapesequence OSC -# } elseif {$uv in $2bytecodes} { -# #self-contained e.g terminal reset - don't pass through. -# set in_escapesequence 2b -# } else { -# lappend outputlist $u -# } -# } -# incr i -# } -# return [join $outputlist ""] -#} - - - proc overtype::string_columns {text} { if {[punk::ansi::ta::detect $text]} { - #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::stripansi. Alternatively try punk::ansi::printing_length" - set text [punk::ansi::stripansi $text] + #error "error string_columns is for calculating character length of string - ansi codes must be stripped/rendered first e.g with punk::ansi::ansistrip. Alternatively try punk::ansi::printing_length" + set text [punk::ansi::ansistrip $text] } return [punk::char::ansifreestring_width $text] } @@ -206,7 +160,7 @@ proc overtype::string_columns {text} { #These have similar algorithms/requirements - and should be refactored to be argument-wrappers over a function called something like overtype::renderblock #overtype::renderblock could render the input to a defined (possibly overflowing in x or y) rectangle overlapping the underlay. #(i.e not even necessariy having it's top left within the underlay) -namespace eval overtype::priv { +tcl::namespace::eval overtype::priv { } #could return larger than colwidth @@ -232,7 +186,7 @@ proc _get_row_append_column {row} { } } -namespace eval overtype { +tcl::namespace::eval overtype { #*** !doctools #[subsection {Namespace overtype}] #[para] Core API functions for overtype @@ -240,7 +194,7 @@ namespace eval overtype { - #string range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r + #tcl::string::range should generally be avoided for both undertext and overtext which contain ansi escapes and other cursor affecting chars such as \b and \r #render onto an already-rendered (ansi already processed) 'underlay' string, a possibly ansi-laden 'overlay' string. #The underlay and overlay can be multiline blocks of text of varying line lengths. #The overlay may just be an ansi-colourised block - or may contain ansi cursor movements and cursor save/restore calls - in which case the apparent length and width of the overlay can't be determined as if it was a block of text. @@ -257,13 +211,14 @@ namespace eval overtype { variable default_ellipsis_horizontal if {[llength $args] < 2} { - error {usage: ?-transparent [0|1]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} + error {usage: ?-width ? ?-startcolumn ? ?-transparent [0|1|]? ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext} } lassign [lrange $args end-1 end] underblock overblock - set defaults [dict create\ + set opts [tcl::dict::create\ -bias ignored\ -width \uFFEF\ -height \uFFEF\ + -startcolumn 1\ -wrap 0\ -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ @@ -278,31 +233,33 @@ namespace eval overtype { ] #-ellipsis args not used if -wrap is true set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { + foreach {k v} $argsflags { switch -- $k { - -looplimit - -width - -height - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental {} + -looplimit - -width - -height - -startcolumn - -bias - -wrap - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -appendlines - -transparent - -exposed1 - -exposed2 - -experimental { + tcl::dict::set opts $k $v + } default { - set known_opts [dict keys $defaults] - error "overtype::renderspace unknown option '$k'. Known options: $known_opts" + error "overtype::renderspace unknown option '$k'. Known options: [tcl::dict::keys $opts]" } } } - set opts [dict merge $defaults $argsflags] + #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_overflow [dict get $opts -overflow] + set opt_overflow [tcl::dict::get $opts -overflow] ##### # review -wrap should map onto DECAWM terminal mode - the wrap 2 idea may not fit in with this?. - set opt_wrap [dict get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) + set opt_wrap [tcl::dict::get $opts -wrap] ;#wrap 1 is hard wrap cutting word at exact column, or 1 column early for 2w-glyph, wrap 2 is for language-based word-wrap algorithm (todo) ##### #for repl - standard output line indicator is a dash - todo, add a different indicator for a continued line. - set opt_width [dict get $opts -width] - set opt_height [dict get $opts -height] - set opt_appendlines [dict get $opts -appendlines] - set opt_transparent [dict get $opts -transparent] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_exposed1 [dict get $opts -exposed1] ;#widechar_exposed_left - todo - set opt_exposed2 [dict get $opts -exposed2] ;#widechar_exposed_right - todo + set opt_width [tcl::dict::get $opts -width] + set opt_height [tcl::dict::get $opts -height] + set opt_startcolumn [tcl::dict::get $opts -startcolumn] + set opt_appendlines [tcl::dict::get $opts -appendlines] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] ;#widechar_exposed_left - todo + set opt_exposed2 [tcl::dict::get $opts -exposed2] ;#widechar_exposed_right - todo # -- --- --- --- --- --- # ---------------------------- @@ -312,7 +269,7 @@ namespace eval overtype { set test_mode 1 set info_mode 0 set edit_mode 0 - set opt_experimental [dict get $opts -experimental] + set opt_experimental [tcl::dict::get $opts -experimental] foreach o $opt_experimental { switch -- $o { test_mode { @@ -343,9 +300,8 @@ namespace eval overtype { set reverse_mode 0 - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] #set underlines [split $underblock \n] @@ -393,11 +349,11 @@ namespace eval overtype { #a hack until we work out how to avoid infinite loops... # - set looplimit [dict get $opts -looplimit] + set looplimit [tcl::dict::get $opts -looplimit] if {$looplimit eq "\uFFEF"} { #looping for each char is worst case (all newlines?) - anything over that is an indication of something broken? #do we need any margin above the length? (telnet mapscii.me test) - set looplimit [expr {[string length $overblock] + 10}] + set looplimit [expr {[tcl::string::length $overblock] + 10}] } if {!$test_mode} { @@ -424,7 +380,7 @@ namespace eval overtype { } set sequence_split [punk::ansi::ta::split_codes_single $ln] ;#use split_codes Not split_codes_single? set lastpt [lindex $inputchunks end] - lset inputchunks end [string cat $lastpt [lindex $sequence_split 0]] + lset inputchunks end [tcl::string::cat $lastpt [lindex $sequence_split 0]] lappend inputchunks {*}[lrange $sequence_split 1 end] incr i } @@ -438,7 +394,7 @@ namespace eval overtype { lappend lflines $ln } if {[llength $lflines]} { - lset lflines end [string range [lindex $lflines end] 0 end-1] + lset lflines end [tcl::string::range [lindex $lflines end] 0 end-1] } set inputchunks $lflines[unset lflines] @@ -451,11 +407,11 @@ namespace eval overtype { #lassign [blocksize $overblock] _w overblock_width _h overblock_height - set replay_codes_underlay [dict create 1 ""] + set replay_codes_underlay [tcl::dict::create 1 ""] #lappend replay_codes_overlay "" set replay_codes_overlay "" set unapplied "" - set cursor_saved_position [dict create] + set cursor_saved_position [tcl::dict::create] set cursor_saved_attributes "" @@ -467,10 +423,10 @@ namespace eval overtype { if {$data_mode} { set col [_get_row_append_column $row] } else { - set col 1 + set col $opt_startcolumn } - set instruction_stats [dict create] + set instruction_stats [tcl::dict::create] set loop 0 #while {$overidx < [llength $inputchunks]} { } @@ -478,7 +434,7 @@ namespace eval overtype { while {[llength $inputchunks]} { #set overtext [lindex $inputchunks $overidx]; lset inputchunks $overidx "" set overtext [lpop inputchunks 0] - if {![string length $overtext]} { + if {![tcl::string::length $overtext]} { incr loop continue } @@ -489,10 +445,10 @@ namespace eval overtype { #renderline pads each underaly line to width with spaces and should track where end of data is - #set overtext [string cat [lindex $replay_codes_overlay $overidx] $overtext] - set overtext [string cat $replay_codes_overlay $overtext] - if {[dict exists $replay_codes_underlay $row]} { - set undertext [string cat [dict get $replay_codes_underlay $row] $undertext] + #set overtext [tcl::string::cat [lindex $replay_codes_overlay $overidx] $overtext] + set overtext [tcl::string::cat $replay_codes_overlay $overtext] + if {[tcl::dict::exists $replay_codes_underlay $row]} { + set undertext [tcl::string::cat [tcl::dict::get $replay_codes_underlay $row] $undertext] } #review insert_mode. As an 'overtype' function whose main function is not interactive keystrokes - insert is secondary - #but even if we didn't want it as an option to the function call - to process ansi adequately we need to support IRM (insertion-replacement mode) ESC [ 4 h|l @@ -512,25 +468,25 @@ namespace eval overtype { $undertext\ $overtext\ ] - set instruction [dict get $rinfo instruction] - set insert_mode [dict get $rinfo insert_mode] - set autowrap_mode [dict get $rinfo autowrap_mode] ;# - #set reverse_mode [dict get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set overflow_right_column [dict get $rinfo overflow_right_column] - set unapplied [dict get $rinfo unapplied] - set unapplied_list [dict get $rinfo unapplied_list] - set post_render_col [dict get $rinfo cursor_column] - set post_render_row [dict get $rinfo cursor_row] - set c_saved_pos [dict get $rinfo cursor_saved_position] - set c_saved_attributes [dict get $rinfo cursor_saved_attributes] - set visualwidth [dict get $rinfo visualwidth] - set insert_lines_above [dict get $rinfo insert_lines_above] - set insert_lines_below [dict get $rinfo insert_lines_below] - dict set replay_codes_underlay [expr {$renderedrow+1}] [dict get $rinfo replay_codes_underlay] - #lset replay_codes_overlay [expr $overidx+1] [dict get $rinfo replay_codes_overlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + set instruction [tcl::dict::get $rinfo instruction] + set insert_mode [tcl::dict::get $rinfo insert_mode] + set autowrap_mode [tcl::dict::get $rinfo autowrap_mode] ;# + #set reverse_mode [tcl::dict::get $rinfo reverse_mode];#how to support in rendered linelist? we need to examine all pt/code blocks and flip each SGR stack? + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set overflow_right_column [tcl::dict::get $rinfo overflow_right_column] + set unapplied [tcl::dict::get $rinfo unapplied] + set unapplied_list [tcl::dict::get $rinfo unapplied_list] + set post_render_col [tcl::dict::get $rinfo cursor_column] + set post_render_row [tcl::dict::get $rinfo cursor_row] + set c_saved_pos [tcl::dict::get $rinfo cursor_saved_position] + set c_saved_attributes [tcl::dict::get $rinfo cursor_saved_attributes] + set visualwidth [tcl::dict::get $rinfo visualwidth] + set insert_lines_above [tcl::dict::get $rinfo insert_lines_above] + set insert_lines_below [tcl::dict::get $rinfo insert_lines_below] + tcl::dict::set replay_codes_underlay [expr {$renderedrow+1}] [tcl::dict::get $rinfo replay_codes_underlay] + #lset replay_codes_overlay [expr $overidx+1] [tcl::dict::get $rinfo replay_codes_overlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] @@ -542,7 +498,7 @@ namespace eval overtype { } #-- - if {[dict size $c_saved_pos] >= 1} { + if {[tcl::dict::size $c_saved_pos] >= 1} { set cursor_saved_position $c_saved_pos set cursor_saved_attributes $c_saved_attributes } @@ -557,7 +513,7 @@ namespace eval overtype { #todo - handle potential insertion mode as above for cursor restore? #keeping separate branches for debugging - review and merge as appropriate when stable - dict incr instruction_stats $instruction + tcl::dict::incr instruction_stats $instruction switch -- $instruction { {} { if {$test_mode == 0} { @@ -657,15 +613,15 @@ namespace eval overtype { #testfile belinda.ans uses this #puts stdout "[a+ blue bold]CURSOR_RESTORE[a]" - if {[dict exists $cursor_saved_position row]} { - set row [dict get $cursor_saved_position row] - set col [dict get $cursor_saved_position column] + if {[tcl::dict::exists $cursor_saved_position row]} { + set row [tcl::dict::get $cursor_saved_position row] + set col [tcl::dict::get $cursor_saved_position column] #puts stdout "restoring: row $row col $col [ansistring VIEW $cursor_saved_attributes] [a] unapplied [ansistring VIEWCODES $unapplied]" #set nextprefix $cursor_saved_attributes #lset replay_codes_overlay [expr $overidx+1] $cursor_saved_attributes - set replay_codes_overlay [dict get $rinfo replay_codes_overlay]$cursor_saved_attributes + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay]$cursor_saved_attributes #set replay_codes_overlay $cursor_saved_attributes - set cursor_saved_position [dict create] + set cursor_saved_position [tcl::dict::create] set cursor_saved_attributes "" } else { #TODO @@ -684,10 +640,10 @@ namespace eval overtype { puts stdout ">>>[a+ red bold]overflow_right during restore_cursor[a]" - set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [dict get $opts -overflow] "" $overflow_right] - set foldline [dict get $sub_info result] - set insert_mode [dict get $sub_info insert_mode] ;#probably not needed.. - set autowrap_mode [dict get $sub_info autowrap_mode] ;#nor this.. + set sub_info [overtype::renderline -info 1 -width $colwidth -insert_mode $insert_mode -autowrap_mode $autowrap_mode -overflow [tcl::dict::get $opts -overflow] "" $overflow_right] + set foldline [tcl::dict::get $sub_info result] + set insert_mode [tcl::dict::get $sub_info insert_mode] ;#probably not needed.. + set autowrap_mode [tcl::dict::get $sub_info autowrap_mode] ;#nor this.. linsert outputlines $renderedrow $foldline #review - row & col set by restore - but not if there was no save.. } @@ -726,7 +682,7 @@ namespace eval overtype { if {$row > [llength $outputlines]} { lappend outputlines "" } - set col 1 + set col $opt_startcolumn # ---------------------- } lf_mid { @@ -754,7 +710,7 @@ namespace eval overtype { set row $renderedrow - set col 1 + set col $opt_startcolumn incr row #only add newline if we're at the bottom if {$row > [llength $outputlines]} { @@ -768,7 +724,7 @@ namespace eval overtype { set unapplied "" set row $post_render_row #set col $post_render_col - set col 1 + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -776,7 +732,7 @@ namespace eval overtype { append rendered $overflow_right set overflow_right "" set row $post_render_row - set col 1 + set col $opt_startcolumn if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } @@ -804,7 +760,7 @@ namespace eval overtype { if {$row > [llength $outputlines]} { lappend outputlines {*}[lrepeat 1 ""] } - set col 1 + set col $opt_startcolumn } newlines_above { @@ -835,7 +791,7 @@ namespace eval overtype { set row $renderedrow set outputlines [linsert $outputlines [expr {$renderedrow }] {*}[lrepeat $insert_lines_below ""]] ;#note - linsert can add to end too incr row $insert_lines_below - set col 1 + set col $opt_startcolumn } else { #set lhs [overtype::left -width 40 -wrap 1 "" [ansistring VIEWSTYLE -lf 1 -vt 1 $rendered]] #set lhs [textblock::frame -title rendered -subtitle "row-$renderedrow" $lhs] @@ -858,7 +814,7 @@ namespace eval overtype { lappend outputlines {*}[lrepeat $insert_lines_below ""] } incr row $insert_lines_below - set col 1 + set col $opt_startcolumn @@ -901,7 +857,7 @@ namespace eval overtype { lappend outputlines "" } } - set c 1 + set c $opt_startcolumn } else { incr c } @@ -952,12 +908,12 @@ namespace eval overtype { set row $post_render_row ;#renderline will not advance row when reporting overflow char if {$autowrap_mode} { incr row - set col 1 ;#whether wrap or not - next data is at column 1 ?? + set col $opt_startcolumn ;#whether wrap or not - next data is at column 1 ?? } else { #this works for test_mode (which should become the default) - but could give a bad result otherwise - review - add tests fix. set col $post_render_col #set unapplied "" ;#this seems wrong? - #set unapplied [string range $unapplied 1 end] + #set unapplied [tcl::string::range $unapplied 1 end] #The overflow can only be triggered by a grapheme (todo cluster?) - but our unapplied could contain SGR codes prior to the grapheme that triggered overflow - so we need to skip beyond any SGRs #There may be more than one, because although the stack leading up to overflow may have been merged - codes between the last column and the overflowing grapheme will remain separate #We don't expect any movement or other ANSI codes - as if they came before the grapheme, they would have triggered a different instruction to 'overflow' @@ -998,7 +954,7 @@ namespace eval overtype { } set unapplied [join [lreplace $unapplied_list $triggering_grapheme_index $triggering_grapheme_index $opt_exposed1] ""] } else { - set col 1 + set col $opt_startcolumn incr row } } else { @@ -1034,7 +990,7 @@ namespace eval overtype { if {!$opt_overflow && !$autowrap_mode} { #not allowed to overflow column or wrap therefore we get overflow data to truncate - if {[dict get $opts -ellipsis]} { + if {[tcl::dict::get $opts -ellipsis]} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { #we don't want ellipsis if only whitespace was lost @@ -1045,11 +1001,11 @@ namespace eval overtype { if {$unapplied ne ""} { append lostdata $unapplied } - if {[string trim $lostdata] eq ""} { + if {[tcl::string::trim $lostdata] eq ""} { set show_ellipsis 0 } - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - if {[string trim [punk::ansi::stripansi $lostdata]] eq ""} { + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim [punk::ansi::ansistrip $lostdata]] eq ""} { set show_ellipsis 0 } } @@ -1113,9 +1069,9 @@ namespace eval overtype { append debugmsg "test_mode:$test_mode\n" append debugmsg "data_mode:$data_mode\n" append debugmsg "opt_appendlines:$opt_appendlines\n" - append debugmsg "prev_row :[dict get $LASTCALL -cursor_row]\n" - append debugmsg "prev_col :[dict get $LASTCALL -cursor_column]\n" - dict for {k v} $rinfo { + append debugmsg "prev_row :[tcl::dict::get $LASTCALL -cursor_row]\n" + append debugmsg "prev_col :[tcl::dict::get $LASTCALL -cursor_column]\n" + tcl::dict::for {k v} $rinfo { append debugmsg "${Y}$k [ansistring VIEW -lf 1 -vt 1 $v]$RST" \n } append debugmsg "${Y}[string repeat - [string length $sep_header]]$RST" \n @@ -1148,7 +1104,7 @@ namespace eval overtype { foreach {underblock overblock} [lrange $args end-1 end] break #todo - vertical vs horizontal overflow for blocks - set defaults [dict create\ + set opts [tcl::dict::create\ -bias left\ -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ @@ -1159,29 +1115,30 @@ namespace eval overtype { -exposed2 \uFFFD\ ] set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { + foreach {k v} $argsflags { switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 {} + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 { + tcl::dict::set opts $k $v + } default { - set known_opts [dict keys $defaults] + set known_opts [tcl::dict::keys $opts] error "overtype::centre unknown option '$k'. Known options: $known_opts" } } } - set opts [dict merge $defaults $argsflags] + #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] # -- --- --- --- --- --- - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] @@ -1197,7 +1154,7 @@ namespace eval overtype { set left_exposed [expr {$under_exposed_max / 2}] } else { set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[string tolower [dict get $opts -bias]] eq "left"} { + if {[tcl::string::tolower [tcl::dict::get $opts -bias]] eq "left"} { set left_exposed $beforehalf } else { #bias to the right @@ -1223,30 +1180,30 @@ namespace eval overtype { set udiff [expr {$colwidth - $ulen}] set undertext "$undertext[string repeat { } $udiff]" } - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] + set undertext [tcl::string::cat $replay_codes_underlay $undertext] + set overtext [tcl::string::cat $replay_codes_overlay $overtext] set overflowlength [expr {$overtext_datalen - $colwidth}] #review - right-to-left langs should elide on left! - extra option required if {$overflowlength > 0} { #overlay line wider or equal - set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [dict get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [dict get $rinfo unapplied] + set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow [tcl::dict::get $opts -overflow] -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] #todo - get replay_codes from overflow_right instead of wherever it was truncated? #overlay line data is wider - trim if overflow not specified in opts - and overtype an ellipsis at right if it was specified - if {![dict get $opts -overflow]} { - #lappend outputlines [string range $overtext 0 [expr {$colwidth - 1}]] - #set overtext [string range $overtext 0 $colwidth-1 ] + if {![tcl::dict::get $opts -overflow]} { + #lappend outputlines [tcl::string::range $overtext 0 [expr {$colwidth - 1}]] + #set overtext [tcl::string::range $overtext 0 $colwidth-1 ] if {$opt_ellipsis} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { #we don't want ellipsis if only whitespace was lost - #don't use string range on ANSI data - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] set lostdata "" if {$overflow_right ne ""} { append lostdata $overflow_right @@ -1254,7 +1211,7 @@ namespace eval overtype { if {$unapplied ne ""} { append lostdata $unapplied } - if {[string trim $lostdata] eq ""} { + if {[tcl::string::trim $lostdata] eq ""} { set show_ellipsis 0 } } @@ -1269,10 +1226,10 @@ namespace eval overtype { #background block is wider than or equal to data for this line #lappend outputlines [renderline -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] set rinfo [renderline -info 1 -insert_mode 0 -startcolumn [expr {$left_exposed + 1}] -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 $undertext $overtext] - lappend outputlines [dict get $rinfo result] + lappend outputlines [tcl::dict::get $rinfo result] } - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] } return [join $outputlines \n] } @@ -1290,7 +1247,7 @@ namespace eval overtype { } foreach {underblock overblock} [lrange $args end-1 end] break - set defaults [dict create\ + set opts [tcl::dict::create\ -bias ignored\ -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ @@ -1302,30 +1259,31 @@ namespace eval overtype { -align "left"\ ] set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { + tcl::dict::for {k v} $argsflags { switch -- $k { - -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align {} + -bias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -align { + tcl::dict::set opts $k $v + } default { - set known_opts [dict keys $defaults] + set known_opts [tcl::dict::keys $opts] error "overtype::centre unknown option '$k'. Known options: $known_opts" } } } - set opts [dict merge $defaults $argsflags] + #set opts [tcl::dict::merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_overflow [dict get $opts -overflow] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - set opt_align [dict get $opts -align] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_align [tcl::dict::get $opts -align] # -- --- --- --- --- --- - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] @@ -1375,27 +1333,27 @@ namespace eval overtype { set startoffset 0 ;#negative? } - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] + set undertext [tcl::string::cat $replay_codes_underlay $undertext] + set overtext [tcl::string::cat $replay_codes_overlay $overtext] set overflowlength [expr {$overtext_datalen - $colwidth}] if {$overflowlength > 0} { #raw overtext wider than undertext column set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [dict get $rinfo replay_codes] - set rendered [dict get $rinfo result] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] if {!$opt_overflow} { if {$opt_ellipsis} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { #we don't want ellipsis if only whitespace was lost - set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - if {[string trim $lostdata] eq ""} { + set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + if {[tcl::string::trim $lostdata] eq ""} { set show_ellipsis 0 } } if {$show_ellipsis} { - set ellipsis [string cat $replay_codes $opt_ellipsistext] + set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] #todo - overflow on left if allign = right?? set rendered [overtype::right $rendered $ellipsis] } @@ -1407,11 +1365,11 @@ namespace eval overtype { #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - lappend outputlines [dict get $rinfo result] + lappend outputlines [tcl::dict::get $rinfo result] } - set replay_codes [dict get $rinfo replay_codes] - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] } return [join $outputlines \n] @@ -1428,9 +1386,10 @@ namespace eval overtype { if {[llength $args] < 2} { error {usage: ?-blockalign left|centre|right? ?-textalign left|centre|right? ?-overflow [1|0]? ?-transparent 0|? undertext overtext} } - foreach {underblock overblock} [lrange $args end-1 end] break + #foreach {underblock overblock} [lrange $args end-1 end] break + lassign [lrange $args end-1 end] underblock overblock - set defaults [dict create\ + set opts [tcl::dict::create\ -ellipsis 0\ -ellipsistext $default_ellipsis_horizontal\ -ellipsiswhitespace 0\ @@ -1445,34 +1404,33 @@ namespace eval overtype { -blockvertical "top"\ ] set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { + tcl::dict::for {k v} $argsflags { switch -- $k { - -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical {} + -blockalignbias - -ellipsis - -ellipsistext - -ellipsiswhitespace - -overflow - -transparent - -exposed1 - -exposed2 - -textalign - -blockalign - -blockvertical { + tcl::dict::set opts $k $v + } default { - set known_opts [dict keys $defaults] - error "overtype::block unknown option '$k'. Known options: $known_opts" + error "overtype::block unknown option '$k'. Known options: [tcl::dict::keys $opts]" } } } - set opts [dict merge $defaults $argsflags] # -- --- --- --- --- --- - set opt_transparent [dict get $opts -transparent] - set opt_ellipsis [dict get $opts -ellipsis] - set opt_ellipsistext [dict get $opts -ellipsistext] - set opt_ellipsiswhitespace [dict get $opts -ellipsiswhitespace] - set opt_overflow [dict get $opts -overflow] - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] - set opt_textalign [dict get $opts -textalign] - set opt_blockalign [dict get $opts -blockalign] + set opt_transparent [tcl::dict::get $opts -transparent] + set opt_ellipsis [tcl::dict::get $opts -ellipsis] + set opt_ellipsistext [tcl::dict::get $opts -ellipsistext] + set opt_ellipsiswhitespace [tcl::dict::get $opts -ellipsiswhitespace] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] + set opt_textalign [tcl::dict::get $opts -textalign] + set opt_blockalign [tcl::dict::get $opts -blockalign] if {$opt_blockalign eq "center"} { set opt_blockalign "centre" } # -- --- --- --- --- --- - set norm [list \r\n \n] - set underblock [string map $norm $underblock] - set overblock [string map $norm $overblock] + set underblock [tcl::string::map {\r\n \n} $underblock] + set overblock [tcl::string::map {\r\n \n} $overblock] set underlines [split $underblock \n] #set colwidth [tcl::mathfunc::max {*}[lmap v $underlines {punk::ansi::printing_length $v}]] @@ -1497,7 +1455,7 @@ namespace eval overtype { set left_exposed [expr {$under_exposed_max / 2}] } else { set beforehalf [expr {$under_exposed_max / 2}] ;#1 less than half due to integer division - if {[string tolower [dict get $opts -blockalignbias]] eq "left"} { + if {[tcl::string::tolower [tcl::dict::get $opts -blockalignbias]] eq "left"} { set left_exposed $beforehalf } else { #bias to the right @@ -1552,24 +1510,24 @@ namespace eval overtype { set startoffset 0 ;#negative? } - set undertext [string cat $replay_codes_underlay $undertext] - set overtext [string cat $replay_codes_overlay $overtext] + set undertext [tcl::string::cat $replay_codes_underlay $undertext] + set overtext [tcl::string::cat $replay_codes_overlay $overtext] set overflowlength [expr {$overtext_datalen - $colwidth}] if {$overflowlength > 0} { #raw overtext wider than undertext column set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -exposed1 $opt_exposed1 -exposed2 $opt_exposed2 -overflow $opt_overflow -startcolumn [expr {1 + $startoffset}] $undertext $overtext] - set replay_codes [dict get $rinfo replay_codes] - set rendered [dict get $rinfo result] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [dict get $rinfo unapplied] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set rendered [tcl::dict::get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] if {!$opt_overflow} { if {$opt_ellipsis} { set show_ellipsis 1 if {!$opt_ellipsiswhitespace} { #we don't want ellipsis if only whitespace was lost - #don't use string range on ANSI data - #set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] + #don't use tcl::string::range on ANSI data + #set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] set lostdata "" if {$overflow_right ne ""} { append lostdata $overflow_right @@ -1577,7 +1535,7 @@ namespace eval overtype { if {$unapplied ne ""} { append lostdata $unapplied } - if {[string trim $lostdata] eq ""} { + if {[tcl::string::trim $lostdata] eq ""} { set show_ellipsis 0 } } @@ -1590,13 +1548,13 @@ namespace eval overtype { # set show_ellipsis 1 # if {!$opt_ellipsiswhitespace} { # #we don't want ellipsis if only whitespace was lost - # set lostdata [string range $overtext end-[expr {$overflowlength-1}] end] - # if {[string trim $lostdata] eq ""} { + # set lostdata [tcl::string::range $overtext end-[expr {$overflowlength-1}] end] + # if {[tcl::string::trim $lostdata] eq ""} { # set show_ellipsis 0 # } # } # if {$show_ellipsis} { - # set ellipsis [string cat $replay_codes $opt_ellipsistext] + # set ellipsis [tcl::string::cat $replay_codes $opt_ellipsistext] # #todo - overflow on left if allign = right?? # set rendered [overtype::right $rendered $ellipsis] # } @@ -1608,13 +1566,13 @@ namespace eval overtype { #lappend outputlines [renderline -insert_mode 0 -transparent $opt_transparent -startcolumn [expr {$left_exposed + 1}] $undertext $overtext] #Note - we still need overflow here - as although the overtext is short - it may oveflow due to the startoffset set rinfo [renderline -info 1 -insert_mode 0 -transparent $opt_transparent -overflow $opt_overflow -startcolumn [expr {$left_exposed + 1 + $startoffset}] $undertext $overtext] - set overflow_right [dict get $rinfo overflow_right] - set unapplied [dict get $rinfo unapplied] - lappend outputlines [dict get $rinfo result] + set overflow_right [tcl::dict::get $rinfo overflow_right] + set unapplied [tcl::dict::get $rinfo unapplied] + lappend outputlines [tcl::dict::get $rinfo result] } - set replay_codes [dict get $rinfo replay_codes] - set replay_codes_underlay [dict get $rinfo replay_codes_underlay] - set replay_codes_overlay [dict get $rinfo replay_codes_overlay] + set replay_codes [tcl::dict::get $rinfo replay_codes] + set replay_codes_underlay [tcl::dict::get $rinfo replay_codes_underlay] + set replay_codes_overlay [tcl::dict::get $rinfo replay_codes_overlay] } return [join $outputlines \n] @@ -1661,7 +1619,8 @@ namespace eval overtype { # error "overtype::renderline not allowed to contain newlines" #} - set defaults [dict create\ + #generally faster to create a new dict in the proc than to use a namespace variable to create dict once and link to variable (2024 8.6/8.7) + set opts [tcl::dict::create\ -etabs 0\ -width \uFFEF\ -overflow 0\ @@ -1688,41 +1647,41 @@ namespace eval overtype { #todo - return info about such grapheme 'cuts' in -info structure and/or create option to raise an error set argsflags [lrange $args 0 end-2] - dict for {k v} $argsflags { + tcl::dict::for {k v} $argsflags { switch -- $k { - -experimental - -cp437 - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes {} + -experimental - -cp437 - -width - -overflow - -transparent - -startcolumn - -cursor_column - -cursor_row - -insert_mode - -autowrap_mode - -reverse_mode - -info - -exposed1 - -exposed2 - -cursor_restore_attributes { + tcl::dict::set opts $k $v + } default { - set known_opts [dict keys $defaults] - error "overtype::renderline unknown option '$k'. Known options: $known_opts" + error "overtype::renderline unknown option '$k'. Known options: [tcl::dict::keys $opts]" } } } - set opts [dict merge $defaults $argsflags] # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_width [dict get $opts -width] - set opt_etabs [dict get $opts -etabs] - set opt_overflow [dict get $opts -overflow] - set opt_colstart [dict get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay - set opt_colcursor [dict get $opts -cursor_column];#start cursor column relative to overlay - set opt_row_context [dict get $opts -cursor_row] + set opt_width [tcl::dict::get $opts -width] + set opt_etabs [tcl::dict::get $opts -etabs] + set opt_overflow [tcl::dict::get $opts -overflow] + set opt_colstart [tcl::dict::get $opts -startcolumn] ;#lhs limit for overlay - an offset to cursor_column - first visible column is 1. 0 or < 0 are before the start of the underlay + set opt_colcursor [tcl::dict::get $opts -cursor_column];#start cursor column relative to overlay + set opt_row_context [tcl::dict::get $opts -cursor_row] if {[string length $opt_row_context]} { - if {![string is integer -strict $opt_row_context] || $opt_row_context <1 } { + if {![tcl::string::is integer -strict $opt_row_context] || $opt_row_context <1 } { error "overtype::renderline -cursor_row must be empty for unspecified/unknown or a non-zero positive integer. received: '$opt_row_context'" } } # -- --- --- --- --- --- --- --- --- --- --- --- #The _mode flags correspond to terminal modes that can be set/reset via escape sequences (e.g DECAWM wraparound mode) - set opt_insert_mode [dict get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) + set opt_insert_mode [tcl::dict::get $opts -insert_mode];#should usually be 1 for each new line in editor mode but must be initialised to 1 externally (review) #default is for overtype # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_autowrap_mode [dict get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line - set opt_reverse_mode [dict get $opts -reverse_mode] ;#DECSNM + set opt_autowrap_mode [tcl::dict::get $opts -autowrap_mode] ;#DECAWM - char or movement can go beyond leftmost/rightmost col to prev/next line + set opt_reverse_mode [tcl::dict::get $opts -reverse_mode] ;#DECSNM # -- --- --- --- --- --- --- --- --- --- --- --- - set temp_cursor_saved [dict get $opts -cursor_restore_attributes] + set temp_cursor_saved [tcl::dict::get $opts -cursor_restore_attributes] set test_mode 0 - set cp437_glyphs [dict get $opts -cp437] - foreach e [dict get $opts -experimental] { + set cp437_glyphs [tcl::dict::get $opts -cp437] + foreach e [tcl::dict::get $opts -experimental] { switch -- $e { test_mode { set test_mode 1 @@ -1731,16 +1690,16 @@ namespace eval overtype { } } set test_mode 1 ;#try to elminate - set cp437_map [dict create] + set cp437_map [tcl::dict::create] if {$cp437_glyphs} { set cp437_map [set ::punk::ansi::cp437_map] #for cp437 images we need to map these *after* splitting ansi #some old files might use newline for its glyph.. but we can't easily support that. #Not sure how old files did it.. maybe cr lf in sequence was newline and any lone cr or lf were displayed as glyphs? - dict unset cp437_map \n + tcl::dict::unset cp437_map \n } - set opt_transparent [dict get $opts -transparent] + set opt_transparent [tcl::dict::get $opts -transparent] if {$opt_transparent eq "0"} { set do_transparency 0 } else { @@ -1750,10 +1709,10 @@ namespace eval overtype { } } # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_returnextra [dict get $opts -info] + set opt_returnextra [tcl::dict::get $opts -info] # -- --- --- --- --- --- --- --- --- --- --- --- - set opt_exposed1 [dict get $opts -exposed1] - set opt_exposed2 [dict get $opts -exposed2] + set opt_exposed1 [tcl::dict::get $opts -exposed1] + set opt_exposed2 [tcl::dict::get $opts -exposed2] # -- --- --- --- --- --- --- --- --- --- --- --- if {$opt_row_context eq ""} { @@ -1768,6 +1727,8 @@ namespace eval overtype { if {[info exists punk::console::tabwidth]} { #punk console is updated if punk::console::set_tabstop_width is used or rep is started/restarted #It is way too slow to test the current width by querying the terminal here - so it could conceivably get out of sync + #todo - we also need to handle the new threaded repl where console config is in a different thread. + # - also - concept of sub-regions being mini-consoles with their own settings - 'id' for console, or use in/out channels as id? set tw $::punk::console::tabwidth } else { set tw 8 @@ -1796,7 +1757,12 @@ namespace eval overtype { # -- --- --- --- --- --- --- --- if {$under ne ""} { - set undermap [punk::ansi::ta::split_codes_single $under] + if {[punk::ansi::ta::detect $under]} { + set undermap [punk::ansi::ta::split_codes_single $under] + } else { + #single plaintext part + set undermap [list $under] + } } else { set undermap [list] } @@ -1814,11 +1780,12 @@ namespace eval overtype { #pt = plain text #append pt_underchars $pt if {$cp437_glyphs} { - set pt [string map $cp437_map $pt] + set pt [tcl::string::map $cp437_map $pt] } foreach grapheme [punk::char::grapheme_split $pt] { - #an ugly hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. + #an ugly but easy hack to serve *some* common case ascii quickly with byte-compiled literal switch - feels dirty. #.. but even 0.5uS per char (grapheme_width_cached) adds up quickly when stitching lots of lines together. + #todo - test decimal value instead, compare performance switch -- $grapheme { " " - - - _ - ! - @ - # - $ - % - ^ - & - * - = - + - : - . - , - / - | - ? - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q - r - s - t - u - v - w - x - y - @@ -1868,23 +1835,24 @@ namespace eval overtype { #only stack SGR (graphics rendition) codes - not title sets, cursor moves etc if {$code ne ""} { - set c1c2 [string range $code 0 1] - set leadernorm [string range [string map [list\ - \x1b\[ 7CSI\ - \x9b 8CSI\ - \x1b\( 7GFX\ - ] $c1c2] 0 3] ;#leadernorm is 1st 2 chars mapped to 4char normalised indicator - or is original 2 chars + set c1c2 [tcl::string::range $code 0 1] + + set leadernorm [tcl::string::range [tcl::string::map [list\ + \x1b\[ 7CSI\ + \x9b 8CSI\ + \x1b\( 7GFX\ + ] $c1c2] 0 3];# leadernorm is 1st 2 chars mapped to normalised indicator - or is original 2 chars switch -- $leadernorm { 7CSI - 8CSI { #need to exclude certain leaders after the lb e.g < for SGR 1006 mouse #REVIEW - what else could end in m but be mistaken as a normal SGR code here? set maybemouse "" - if {[string index $c1c2 0] eq "\x1b"} { - set maybemouse [string index $code 2] + if {[tcl::string::index $c1c2 0] eq "\x1b"} { + set maybemouse [tcl::string::index $code 2] } - if {$maybemouse ne "<" && [string index $code end] eq "m"} { + if {$maybemouse ne "<" && [tcl::string::index $code end] eq "m"} { if {[punk::ansi::codetype::is_sgr_reset $code]} { set u_codestack [list "\x1b\[m"] } elseif {[punk::ansi::codetype::has_sgr_leadingreset $code]} { @@ -1898,7 +1866,7 @@ namespace eval overtype { } } 7GFX { - switch -- [string index $code 2] { + switch -- [tcl::string::index $code 2] { "0" { set u_gx_stack [list gx0_on] ;#we'd better use a placeholder - or debugging will probably get into a big mess } @@ -2008,7 +1976,17 @@ namespace eval overtype { #this will be processed as transparent - and handle doublewidth underlay characters appropriately set startpad_overlay [string repeat " " [expr {$opt_colstart -1}]] append startpad_overlay $overdata ;#overdata with left padding spaces based on col-start under will show through for left-padding portion regardless of -transparency - set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + if {$startpad_overlay ne ""} { + if {[punk::ansi::ta::detect $startpad_overlay]} { + set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] + } else { + #single plaintext part + set overmap [list $startpad_overlay] + } + } else { + set overmap [list] + } + #set overmap [punk::ansi::ta::split_codes_single $startpad_overlay] #### #??? @@ -2035,7 +2013,7 @@ namespace eval overtype { #todo - wrap in test for empty pt (we used split_codes_single - and it may be common for sgr sequences to be unmerged and so have empty pts between) if {$cp437_glyphs} { - set pt [string map $cp437_map $pt] + set pt [tcl::string::map $cp437_map $pt] } append pt_overchars $pt #will get empty pt between adjacent codes @@ -2099,8 +2077,8 @@ namespace eval overtype { #set replay_codes_overlay [join $o_codestack ""] set replay_codes_overlay [punk::ansi::codetype::sgr_merge_list {*}$o_codestack] - #if {[dict exists $overstacks $max_overlay_grapheme_index]} { - # set replay_codes_overlay [join [dict get $overstacks $max_overlay_grapheme_index] ""] + #if {[tcl::dict::exists $overstacks $max_overlay_grapheme_index]} { + # set replay_codes_overlay [join [tcl::dict::get $overstacks $max_overlay_grapheme_index] ""] #} else { # set replay_codes_overlay "" #} @@ -2161,6 +2139,17 @@ namespace eval overtype { set insert_mode $opt_insert_mode ;#default 1 set autowrap_mode $opt_autowrap_mode ;#default 1 + #set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM + #set re_col_move {\x1b\[([0-9]*)(C|D|G)$} + #set re_row_move {\x1b\[([0-9]*)(A|B)$} + #set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? + #set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} + #set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! + #set re_cursor_restore {\x1b\[u$} + #set re_cursor_save_dec {\x1b7$} + #set re_cursor_restore_dec {\x1b8$} + #set re_other_single {\x1b(D|M|E)$} + #set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins #puts "-->$overlay_grapheme_control_list<--" #puts "-->overflow_idx: $overflow_idx" @@ -2188,7 +2177,7 @@ namespace eval overtype { #This is hard to process in any standard manner - but I think the Hyper behaviour of doing what it was intended is perhaps most reasonable #We will map it to the same behaviour as lf here for now... but we need also to consider the equivalent ANSI sequence: \x1bE - set chtest [string map [list \n \x85 \b \r \v \x7f ] $ch] + set chtest [tcl::string::map [list \n \x85 \b \r \v \x7f ] $ch] #puts --->chtest:$chtest #specials - each shoud have it's own test of what to do if it happens after overflow_idx reached switch -- $chtest { @@ -2276,7 +2265,7 @@ namespace eval overtype { #review split 2w overflow? #we don't want to make the decision here to split a 2w into replacement characters at end of line and beginning of next line #better to consider the overlay char as unable to be applied to the line - #render empty string to column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied + #render empty column(?) - and reduce overlay grapheme index by one so that the current ch goes into unapplied #throwing back to caller with instruction complicates its job - but is necessary to avoid making decsions for it here. priv::render_addchar $idx "" [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode #change the overflow_idx @@ -2315,7 +2304,7 @@ namespace eval overtype { #pre opt_colstart is effectively transparent (we have applied padding of required number of columns to left of overlay) if {$idx > [llength $outcols]-1} { lappend outcols " " - #dict set understacks $idx [list] ;#review - use idx-1 codestack? + #tcl::dict::set understacks $idx [list] ;#review - use idx-1 codestack? lset understacks $idx [list] incr idx incr cursor_column @@ -2343,7 +2332,7 @@ namespace eval overtype { if {[grapheme_width_cached $ch] == 1} { if {!$insert_mode} { #normal singlewide transparent overlay onto double-wide underlay - set next_pt_overchar [string index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay + set next_pt_overchar [tcl::string::index $pt_overchars $idx_over+1] ;#lookahead of next plain-text char in overlay if {$next_pt_overchar eq ""} { #special-case trailing transparent - no next_pt_overchar incr idx @@ -2354,7 +2343,7 @@ namespace eval overtype { incr cursor_column } else { #next overlay char is not transparent.. first-half of underlying 2wide char is exposed - #priv::render_addchar $idx $opt_exposed1 [dict get $overstacks $idx_over] [dict get $overstacks_gx $idx_over] $insert_mode + #priv::render_addchar $idx $opt_exposed1 [tcl::dict::get $overstacks $idx_over] [tcl::dict::get $overstacks_gx $idx_over] $insert_mode priv::render_addchar $idx $opt_exposed1 [lindex $overstacks $idx_over] [lindex $overstacks_gx $idx_over] $insert_mode incr idx incr cursor_column @@ -2497,35 +2486,23 @@ namespace eval overtype { } other { - set code $item + #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. + #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore + set code [tcl::string::map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $item] #since this element isn't a grapheme - advance idx_over to next grapheme overlay when about to fill 'unapplied' - set re_mode {\x1b\[\?([0-9]*)(h|l)} ;#e.g DECAWM - set re_col_move {\x1b\[([0-9]*)(C|D|G)$} - set re_row_move {\x1b\[([0-9]*)(A|B)$} - set re_both_move {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)H$} ;# or "f" ? - set re_vt_sequence {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)~$} - set re_cursor_save {\x1b\[s$} ;#note probable incompatibility with DECSLRM (set left right margin)! - set re_cursor_restore {\x1b\[u$} - set re_cursor_save_dec {\x1b7$} - set re_cursor_restore_dec {\x1b8$} - set re_other_single {\x1b(D|M|E)$} - set re_decstbm {\x1b\[([0-9]*)(?:;){0,1}([0-9]*)r$} ;#DECSTBM set top and bottom margins set matchinfo [list] #remap of DEC cursor_save/cursor_restore from ESC sequence to equivalent CSI #probably not ideal - consider putting cursor_save/cursor_restore in functions so they can be called from the appropriate switch branch instead of using this mapping #review - cost/benefit of function calls within these switch-arms instead of inline code? - #todo - consider CSI s DECSLRM vs ansi.sys \x1b\[s - we need \x1b\[s for oldschool ansi art - but may have to enable only for that. - #we should probably therefore reverse this mapping so that x1b7 x1b8 are the primary codes for save/restore - set code [string map [list \x1b7 \x1b\[s \x1b8 \x1b\[u ] $code] - - - set c1 [string index $code 0] - set c1c2c3 [string range $code 0 2] + set c1 [tcl::string::index $code 0] + set c1c2c3 [tcl::string::range $code 0 2] #set re_ST_open {(?:\033P|\u0090|\033X|\u0098|\033\^|\u009e|\033_|\u009f)} - set leadernorm [string range [string map [list\ + #tcl 8.7 - faster to use inline list than to store it in a local var outside of loop. + #(surprising - but presumably ) + set leadernorm [tcl::string::range [tcl::string::map [list\ \x1b\[< 1006\ \x1b\[ 7CSI\ \x9b 8CSI\ @@ -2539,16 +2516,16 @@ namespace eval overtype { 1006 { #https://invisible-island.net/xterm/ctlseqs/ctlseqs.html #SGR (1006) CSI < followed by colon separated encoded-button-value,px,py ordinates and final M for button press m for button release - set codenorm [string cat $leadernorm [string range $code 3 end]] + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 3 end]] } 7CSI - 7OSC { - set codenorm [string cat $leadernorm [string range $code 2 end]] + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 2 end]] } 7ESC { - set codenorm [string cat $leadernorm [string range $code 1 end]] + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } 8CSI - 8OSC { - set codenorm [string cat $leadernorm [string range $code 1 end]] + set codenorm [tcl::string::cat $leadernorm [tcl::string::range $code 1 end]] } default { #we haven't made a mapping for this @@ -2561,7 +2538,7 @@ namespace eval overtype { 1006 { #TODO # - switch -- [string index $codenorm end] { + switch -- [tcl::string::index $codenorm end] { M { puts stderr "mousedown $codenorm" } @@ -2572,9 +2549,9 @@ namespace eval overtype { } {7CSI} - {8CSI} { - set param [string range $codenorm 4 end-1] - #puts stdout "--> CSI [string index $leadernorm 0] bit param:$param" - switch -- [string index $codenorm end] { + set param [tcl::string::range $codenorm 4 end-1] + #puts stdout "--> CSI [tcl::string::index $leadernorm 0] bit param:$param" + switch -- [tcl::string::index $codenorm end] { D { #Col move #puts stdout "<-back" @@ -2679,8 +2656,8 @@ namespace eval overtype { #puts "idxstart:$idxstart idxend:$idxend outcols[llength $outcols] undercols:[llength $undercols]" incr idx $moveend incr cursor_column $moveend - #if {[dict exists $understacks $idx]} { - # set stackinfo [dict get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext + #if {[tcl::dict::exists $understacks $idx]} { + # set stackinfo [tcl::dict::get $understacks $idx] ;#use understack at end - which may or may not have already been replaced by stack from overtext #} else { # set stackinfo [list] #} @@ -2690,7 +2667,7 @@ namespace eval overtype { set stackinfo [list] } if {$idx < [llength $understacks_gx]} { - #set gxstackinfo [dict get $understacks_gx $idx] + #set gxstackinfo [tcl::dict::get $understacks_gx $idx] set gxstackinfo [lindex $understacks_gx $idx] } else { set gxstackinfo [list] @@ -3000,8 +2977,8 @@ namespace eval overtype { #$re_mode if first after CSI is "?" #some docs mention ESC=h|l - not seen on windows terminals.. review #e.g https://www2.math.upenn.edu/~kazdan/210/computer/ansi.html - if {[string index $codenorm 4] eq "?"} { - set num [string range $codenorm 5 end-1] ;#param between ? and h|l + if {[tcl::string::index $codenorm 4] eq "?"} { + set num [tcl::string::range $codenorm 5 end-1] ;#param between ? and h|l #lassign $matchinfo _match num type switch -- $num { 5 { @@ -3062,7 +3039,7 @@ namespace eval overtype { } 7ESC { #$re_other_single - switch -- [string index $codenorm end] { + switch -- [tcl::string::index $codenorm end] { D { #\x84 #index (IND) @@ -3158,7 +3135,7 @@ namespace eval overtype { set gxleader "" if {$i < [llength $understacks_gx]} { - #set g0 [dict get $understacks_gx $i] + #set g0 [tcl::dict::get $understacks_gx $i] set g0 [lindex $understacks_gx $i] if {$g0 ne $prev_g0} { if {$g0 eq [list "gx0_on"]} { @@ -3174,7 +3151,7 @@ namespace eval overtype { set sgrleader "" if {$i < [llength $understacks]} { - #set cstack [dict get $understacks $i] + #set cstack [tcl::dict::get $understacks $i] set cstack [lindex $understacks $i] if {$cstack ne $prevstack} { if {[llength $prevstack] && ![llength $cstack]} { @@ -3228,7 +3205,7 @@ namespace eval overtype { append outstring $gxleader append outstring $sgrleader if {$idx+1 < $cursor_column} { - append outstring [string map [list "\u0000" " "] $ch] + append outstring [tcl::string::map {\u0000 " "} $ch] } else { append outstring $ch } @@ -3237,16 +3214,16 @@ namespace eval overtype { } #flower.ans good test for null handling - reverse line building if {![ansistring length $overflow_right]} { - set outstring [string trimright $outstring "\u0000"] + set outstring [tcl::string::trimright $outstring "\u0000"] } - set outstring [string map [list "\u0000" " "] $outstring] - set overflow_right [string trimright $overflow_right "\u0000"] - set overflow_right [string map [list "\u0000" " "] $overflow_right] + set outstring [tcl::string::map {\u0000 " "} $outstring] + set overflow_right [tcl::string::trimright $overflow_right "\u0000"] + set overflow_right [tcl::string::map {\u0000 " "} $overflow_right] set replay_codes "" if {[llength $understacks] > 0} { if {$overflow_idx == -1} { - #set tail_idx [dict size $understacks] + #set tail_idx [tcl::dict::size $understacks] set tail_idx [llength $understacks] } else { set tail_idx [llength $undercols] @@ -3289,7 +3266,7 @@ namespace eval overtype { } else { set overflow_right_column [expr {$overflow_idx+1}] } - set result [dict create\ + set result [tcl::dict::create\ result $outstring\ visualwidth [punk::ansi::printing_length $outstring]\ instruction $instruction\ @@ -3325,14 +3302,14 @@ namespace eval overtype { set viewop VIEWSTYLE ;#ansi colorise the characters within the output with preceding codes, stacking codes only within each dict value - may not be same SGR effect as the effect in-situ. } } - dict set result result [ansistring $viewop -lf 1 -vt 1 [dict get $result result]] - dict set result overflow_right [ansistring VIEW -lf 1 -vt 1 [dict get $result overflow_right]] - dict set result unapplied [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied]] - dict set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [dict get $result unapplied_list]] - dict set result replay_codes [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes]] - dict set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_underlay]] - dict set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [dict get $result replay_codes_overlay]] - dict set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [dict get $result cursor_saved_attributes]] + tcl::dict::set result result [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result result]] + tcl::dict::set result overflow_right [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result overflow_right]] + tcl::dict::set result unapplied [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied]] + tcl::dict::set result unapplied_list [ansistring VIEW -lf 1 -vt 1 [tcl::dict::get $result unapplied_list]] + tcl::dict::set result replay_codes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes]] + tcl::dict::set result replay_codes_underlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_underlay]] + tcl::dict::set result replay_codes_overlay [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result replay_codes_overlay]] + tcl::dict::set result cursor_saved_attributes [ansistring $viewop -lf 1 -vt 1 [tcl::dict::get $result cursor_saved_attributes]] return $result } } else { @@ -3345,7 +3322,7 @@ namespace eval overtype { #[list_end] [comment {--- end definitions namespace overtype ---}] } -namespace eval overtype::piper { +tcl::namespace::eval overtype::piper { proc overcentre {args} { if {[llength $args] < 2} { error {usage: ?-bias left|right? ?-transparent [0|1|]? ?-exposed1 ? ?-exposed2 ? ?-overflow [1|0]? overtext pipelinedata} @@ -3369,19 +3346,19 @@ namespace eval overtype::piper { proc overtype::transparentline {args} { foreach {under over} [lrange $args end-1 end] break set argsflags [lrange $args 0 end-2] - set defaults [dict create\ + set defaults [tcl::dict::create\ -transparent 1\ -exposed 1 " "\ -exposed 2 " "\ ] - set newargs [dict merge $defaults $argsflags] + set newargs [tcl::dict::merge $defaults $argsflags] tailcall overtype::renderline {*}$newargs $under $over } #renderline may not make sense as it is in the long run for blocks of text - but is handy in the single-line-handling form anyway. # We are trying to handle ansi codes in a block of text which is acting like a mini-terminal in some sense. #We can process standard cursor moves such as \b \r - but no way to respond to other cursor movements e.g moving to other lines. # -namespace eval overtype::piper { +tcl::namespace::eval overtype::piper { proc renderline {args} { if {[llength $args] < 2} { error {usage: ?-start ? ?-transparent [0|1|]? ?-overflow [1|0]? overtext pipelinedata} @@ -3398,11 +3375,11 @@ interp alias "" piper_renderline "" overtype::piper::renderline #(a cache of ansifreestring_width calls - as these are quite regex heavy) proc overtype::grapheme_width_cached {ch} { variable grapheme_widths - if {[dict exists $grapheme_widths $ch]} { - return [dict get $grapheme_widths $ch] + if {[tcl::dict::exists $grapheme_widths $ch]} { + return [tcl::dict::get $grapheme_widths $ch] } set width [punk::char::ansifreestring_width $ch] - dict set grapheme_widths $ch $width + tcl::dict::set grapheme_widths $ch $width return $width } @@ -3420,9 +3397,9 @@ proc overtype::test_renderline {} { #block width and height can be tricky. e.g \v handled differently on different terminal emulators and can affect both proc overtype::blocksize {textblock} { if {$textblock eq ""} { - return [dict create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings + return [tcl::dict::create width 0 height 1] ;#no such thing as zero-height block - for consistency with non-empty strings having no line-endings } - if {[string first \t $textblock] >= 0} { + if {[tcl::string::first \t $textblock] >= 0} { if {[info exists punk::console::tabwidth]} { set tw $::punk::console::tabwidth } else { @@ -3430,12 +3407,12 @@ proc overtype::blocksize {textblock} { } set textblock [textutil::tabify::untabify2 $textblock $tw] } - #stripansi on entire block in one go rather than line by line - result should be the same - review - make tests + #ansistrip on entire block in one go rather than line by line - result should be the same - review - make tests if {[punk::ansi::ta::detect $textblock]} { - set textblock [punk::ansi::stripansi $textblock] + set textblock [punk::ansi::ansistrip $textblock] } - if {[string first \n $textblock] >= 0} { - set num_le [expr {[string length $textblock]-[string length [string map [list \n {}] $textblock]]}] ;#faster than splitting into single-char list + if {[tcl::string::last \n $textblock] >= 0} { + set num_le [expr {[tcl::string::length $textblock]-[tcl::string::length [tcl::string::map {\n {}} $textblock]]}] ;#faster than splitting into single-char list set width [tcl::mathfunc::max {*}[lmap v [split $textblock \n] {::punk::char::ansifreestring_width $v}]] } else { set num_le 0 @@ -3444,22 +3421,22 @@ proc overtype::blocksize {textblock} { #our concept of block-height is likely to be different to other line-counting mechanisms set height [expr {$num_le + 1}] ;# one line if no le - 2 if there is one trailing le even if no data follows le - return [dict create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height + return [tcl::dict::create width $width height $height] ;#maintain order in 'image processing' standard width then height - caller may use lassign [dict values [blocksize ]] width height } -namespace eval overtype::priv { - variable cache_is_sgr [dict create] +tcl::namespace::eval overtype::priv { + variable cache_is_sgr [tcl::dict::create] #we are likely to be asking the same question of the same ansi codes repeatedly #caching the answer saves some regex expense - possibly a few uS to lookup vs under 1uS #todo - test if still worthwhile after a large cache is built up. (limit cache size?) proc is_sgr {code} { variable cache_is_sgr - if {[dict exists $cache_is_sgr $code]} { - return [dict get $cache_is_sgr $code] + if {[tcl::dict::exists $cache_is_sgr $code]} { + return [tcl::dict::get $cache_is_sgr $code] } set answer [punk::ansi::codetype::is_sgr $code] - dict set cache_is_sgr $code $answer + tcl::dict::set cache_is_sgr $code $answer return $answer } proc render_unapplied {overlay_grapheme_control_list gci} { @@ -3564,7 +3541,7 @@ namespace eval overtype::priv { upvar understacks_gx gxstacks #ECH clears character attributes from erased character positions #ECH accepts 0 or empty parameter, which is equivalent to 1. Caller should do that mapping and only supply 1 or greater. - if {![string is integer -strict $count] || $count < 1} { + if {![tcl::string::is integer -strict $count] || $count < 1} { error "render_erasechar count must be integer >= 1" } set start $i @@ -3639,15 +3616,15 @@ namespace eval overtype::priv { # -- --- --- --- --- --- --- --- --- --- --- -namespace eval overtype { +tcl::namespace::eval overtype { interp alias {} ::overtype::center {} ::overtype::centre } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready -package provide overtype [namespace eval overtype { +package provide overtype [tcl::namespace::eval overtype { variable version - set version 1.6.3 + set version 1.6.5 }] return diff --git a/src/vendormodules/packageTest-0.1.0.tm b/src/vendormodules/packageTest-0.1.0.tm new file mode 100644 index 00000000..befc864a Binary files /dev/null and b/src/vendormodules/packageTest-0.1.0.tm differ diff --git a/src/vendormodules/tablelist-6.22.tm b/src/vendormodules/tablelist-6.22.tm new file mode 100644 index 00000000..50b012e8 Binary files /dev/null and b/src/vendormodules/tablelist-6.22.tm differ diff --git a/src/vendormodules/tablelist_tile-6.22.tm b/src/vendormodules/tablelist_tile-6.22.tm new file mode 100644 index 00000000..455d33fb --- /dev/null +++ b/src/vendormodules/tablelist_tile-6.22.tm @@ -0,0 +1 @@ +source [file dirname [info script]]/tablelist-6.22.tm diff --git a/src/vendormodules/textutil/wcswidth-35.2.tm b/src/vendormodules/textutil/wcswidth-35.2.tm index a8afafeb..d153744a 100644 --- a/src/vendormodules/textutil/wcswidth-35.2.tm +++ b/src/vendormodules/textutil/wcswidth-35.2.tm @@ -8,7 +8,7 @@ # Author: Sean Woods # Author: Andreas Kupries ### -package require Tcl 8.5 +package require Tcl 8.5- package provide textutil::wcswidth 35.2 namespace eval ::textutil {} diff --git a/src/vendormodules_tcl8/include_modules.config b/src/vendormodules_tcl8/include_modules.config new file mode 100644 index 00000000..f080c8b1 --- /dev/null +++ b/src/vendormodules_tcl8/include_modules.config @@ -0,0 +1,11 @@ + +set local_modules [list\ + c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread\ + c:/repo/jn/tclmodules/Thread/modules_tcl8 Thread::platform::win32_x86_64_tcl8\ +] + +set fossil_modules [dict create\ +] + +set git_modules [dict create\ +] \ No newline at end of file diff --git a/src/vendormodules_tcl9/Thread-3.0b3.tm b/src/vendormodules_tcl9/Thread-3.0b3.tm new file mode 100644 index 00000000..cfc398d6 Binary files /dev/null and b/src/vendormodules_tcl9/Thread-3.0b3.tm differ diff --git a/src/vendormodules_tcl9/Thread/platform/win32_x86_64_tcl9-3.0b3.tm b/src/vendormodules_tcl9/Thread/platform/win32_x86_64_tcl9-3.0b3.tm new file mode 100644 index 00000000..9729945f Binary files /dev/null and b/src/vendormodules_tcl9/Thread/platform/win32_x86_64_tcl9-3.0b3.tm differ diff --git a/src/vendormodules_tcl9/include_modules.config b/src/vendormodules_tcl9/include_modules.config new file mode 100644 index 00000000..8af2951f --- /dev/null +++ b/src/vendormodules_tcl9/include_modules.config @@ -0,0 +1,11 @@ + +set local_modules [list\ + c:/repo/jn/tclmodules/Thread/modules_tcl9 Thread\ + c:/repo/jn/tclmodules/Thread/modules_tcl9 Thread::platform::win32_x86_64_tcl9\ +] + +set fossil_modules [dict create\ +] + +set git_modules [dict create\ +] \ No newline at end of file