Browse Source

belated shell*.tm version bumps, bootsupport

master
Julian Noble 10 months ago
parent
commit
23f08b63d6
  1. 377
      src/bootsupport/modules/punk/ansi-0.1.0.tm
  2. 8
      src/bootsupport/modules/punk/console-0.1.0.tm
  3. 696
      src/bootsupport/modules/punk/lib-0.1.0.tm
  4. 5
      src/bootsupport/modules/punk/ns-0.1.0.tm
  5. 0
      src/modules/shellfilter-0.1.9.tm
  6. 0
      src/modules/shellrun-0.1.1.tm
  7. 0
      src/modules/shellthread-1.6.1.tm

377
src/bootsupport/modules/punk/ansi-0.1.0.tm

@ -83,6 +83,7 @@ namespace eval punk::ansi {
#Note that a? is actually a pattern. We can't explicitly match it without also matcing a+ ab etc. Presumably this won't matter here. #Note that a? is actually a pattern. We can't explicitly match it without also matcing a+ ab etc. Presumably this won't matter here.
namespace export\ namespace export\
{a?} {a+} a \ {a?} {a+} a \
ansistring\
convert*\ convert*\
clear*\ clear*\
cursor_*\ cursor_*\
@ -105,8 +106,12 @@ namespace eval punk::ansi {
#NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm ) #NOTE - we are assuming an OSC or DCS started with one type of sequence (7 or 8bit) can be terminated by either 7 or 8 bit ST (or BEL e.g wezterm )
#This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows? #This using a different type of ST to that of the opening sequence is presumably unlikely in the wild - but who knows?
variable standalone_codes
set standalone_codes [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""]
#review - there doesn't seem to be an \x1b#7
# https://espterm.github.io/docs/VT100%20escape%20codes.html
#self-contained 2 byte ansi escape sequences - review more? #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 [dict create\
"reset_terminal" "\u001bc"\ "reset_terminal" "\u001bc"\
"save_cursor_posn" "\u001b7"\ "save_cursor_posn" "\u001b7"\
@ -119,11 +124,50 @@ namespace eval punk::ansi {
"DECPNM norm keypad" "\x1b>"\ "DECPNM norm keypad" "\x1b>"\
] ]
#control strings
#https://www.ecma-international.org/wp-content/uploads/ECMA-48_5th_edition_june_1991.pdf
#<excerpt>
#A control string is a string of bit combinations which may occur in the data stream as a logical entity for
#control purposes. A control string consists of an opening delimiter, a command string or a character string,
#and a terminating delimiter, the STRING TERMINATOR (ST).
#A command string is a sequence of bit combinations in the range 00/08 to 00/13 and 02/00 to 07/14.
#A character string is a sequence of any bit combination, except those representing START OF STRING
#(SOS) or STRING TERMINATOR (ST).
#The interpretation of the command string or the character string is not defined by this Standard, but instead
#requires prior agreement between the sender and the recipient of the data.
#The opening delimiters defined in this Standard are
#a) APPLICATION PROGRAM COMMAND (APC)
#b) DEVICE CONTROL STRING (DCS)
#c) OPERATING SYSTEM COMMAND (OSC)
#d) PRIVACY MESSAGE (PM)
#e) START OF STRING (SOS)
#</excerpt>
#debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway. #debatable whether strip should reveal the somethinghidden - some terminals don't hide it anyway.
# "PM - Privacy Message" "\u001b^somethinghidden\033\\"\ # "PM - Privacy Message" "\u001b^somethinghidden\033\\"\
#The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out. #The intent is that it's not rendered to the terminal - so on balance it seems best to strip it out.
#todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate. #todo - review - printing_length calculations affected by whether terminal honours PMs or not. detect and accomodate.
#review - can terminals handle SGR codes within a PM?
#Wezterm will hide PM,SOS,APC - but not any part following an SGR code - i.e it seems to terminate hiding before the ST (apparently at the )
proc controlstring_PM {text} {
return "\x1b^${text}\033\\"
}
proc controlstring_PM8 {text} {
return "\x9e${text}\x9c"
}
proc controlstring_SOS {text} {
return "\x1bX${text}\033\\"
}
proc controlstring_SOS8 {text} {
return "\x98${text}\x9c"
}
proc controlstring_APC {text} {
return "\x1b_${text}\033\\"
}
proc controlstring_APC8 {text} {
return "\x9f${text}\x9c"
}
#candidate for zig/c implementation? #candidate for zig/c implementation?
proc stripansi {text} { proc stripansi {text} {
#*** !doctools #*** !doctools
@ -133,6 +177,7 @@ namespace eval punk::ansi {
#todo - character set selection - SS2 SS3 - how are they terminated? REVIEW #todo - character set selection - SS2 SS3 - how are they terminated? REVIEW
variable escape_terminals ;#dict variable escape_terminals ;#dict
variable standalone_codes ;#map to empty string
set text [convert_g0 $text] set text [convert_g0 $text]
@ -145,9 +190,7 @@ namespace eval punk::ansi {
#\x1b#6 double-width line #\x1b#6 double-width line
#\x1b#8 dec test fill screen #\x1b#8 dec test fill screen
set clean_map_2b [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> ""] set text [string map $standalone_codes $text]
set clean_map_3b [list \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""]
set text [string map [concat $clean_map_2b $clean_map_3b] $text]
#we process char by char - line-endings whether \r\n or \n should be processed as per any other character. #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 payload (review e.g title?) #line endings can theoretically occur within an ansi escape sequence payload (review e.g title?)
@ -169,7 +212,7 @@ namespace eval punk::ansi {
if {$u in $endseq} { if {$u in $endseq} {
set in_escapesequence 0 set in_escapesequence 0
} elseif {$uv in $endseq} { } elseif {$uv in $endseq} {
set in_escapseequence 2b ;#flag next byte as last in sequence set in_escapesequence 2b ;#flag next byte as last in sequence
} }
} else { } else {
#handle both 7-bit and 8-bit CSI and OSC #handle both 7-bit and 8-bit CSI and OSC
@ -179,7 +222,7 @@ namespace eval punk::ansi {
set in_escapesequence OSC set in_escapesequence OSC
} elseif {[regexp {^(?:\033P|\u0090)} $uv]} { } elseif {[regexp {^(?:\033P|\u0090)} $uv]} {
set in_escapesequence DCS set in_escapesequence DCS
} elseif {[regexp {^(?:\033X|\u0098|\033^|\u009E|\033_|\u009F)} $uv]} { } elseif {[regexp {^(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)} $uv]} {
#SOS,PM,APC - all terminated with ST #SOS,PM,APC - all terminated with ST
set in_escapesequence MISC set in_escapesequence MISC
} else { } else {
@ -248,7 +291,7 @@ namespace eval punk::ansi {
proc colourmap1 {{bgname White}} { proc colourmap1 {{bgname White}} {
package require textblock package require textblock
set bg [textblock::block 3 33 "[a+ $bgname] [a]"] set bg [textblock::block 33 3 "[a+ $bgname] [a]"]
set colormap "" set colormap ""
for {set i 0} {$i <= 7} {incr i} { for {set i 0} {$i <= 7} {incr i} {
append colormap "_[a+ white bold 48\;5\;$i] $i [a]" append colormap "_[a+ white bold 48\;5\;$i] $i [a]"
@ -258,7 +301,7 @@ namespace eval punk::ansi {
} }
proc colourmap2 {{bgname White}} { proc colourmap2 {{bgname White}} {
package require textblock package require textblock
set bg [textblock::block 3 39 "[a+ $bgname] [a]"] set bg [textblock::block 39 3 "[a+ $bgname] [a]"]
set colormap "" set colormap ""
for {set i 8} {$i <= 15} {incr i} { for {set i 8} {$i <= 15} {incr i} {
append colormap "_[a+ black normal 48\;5\;$i] $i [a]" ;#black normal is blacker than black bold - which often displays as a grey append colormap "_[a+ black normal 48\;5\;$i] $i [a]" ;#black normal is blacker than black bold - which often displays as a grey
@ -691,6 +734,7 @@ namespace eval punk::ansi {
return "\u0090+q$payload\u009c" return "\u0090+q$payload\u009c"
} }
namespace eval codetype { namespace eval codetype {
#Functions that operate on a single ansi code sequence - not a sequence, and not codes embedded in another string
proc is_sgr {code} { proc is_sgr {code} {
#SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline #SGR (Select Graphic Rendition) - codes ending in 'm' - e.g colour/underline
#we will accept and pass through the less common colon separator (ITU Open Document Architecture) #we will accept and pass through the less common colon separator (ITU Open Document Architecture)
@ -701,13 +745,13 @@ namespace eval punk::ansi {
#review - what about CSI n : m H where row n happens to be current line? #review - what about CSI n : m H where row n happens to be current line?
regexp {\033\[[0-9]*(:?C|D|G)$} regexp {\033\[[0-9]*(:?C|D|G)$}
} }
#pure SGR reset #pure SGR reset with no other functions
proc is_sgr_reset {code} { proc is_sgr_reset {code} {
#todo 8-bit csi #todo 8-bit csi
regexp {\033\[0*m$} $code regexp {\033\[0*m$} $code
} }
#whether this code has 0 (or equivalently empty) parameter (but may set others) #whether this code has 0 (or equivalently empty) parameter (but may set others)
#if an SGR code as a reset in it - we don't need to carry forward any previous SGR codes #if an SGR code has a reset in it - we don't need to carry forward any previous SGR codes
#it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions #it generally only makes sense for the reset to be the first entry - otherwise the code has ineffective portions
#However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params. #However - detecting zero or empty parameter in other positions requires knowing all other codes that may allow zero or empty params.
#We will only look at initial parameter as this is the well-formed normal case. #We will only look at initial parameter as this is the well-formed normal case.
@ -723,6 +767,9 @@ namespace eval punk::ansi {
return 0 return 0
} }
} }
#has_sgr_reset - rather than support this function - create an sgr normalize function that removes dead params and brings reset to front of param list?
} }
namespace eval sequence_type { namespace eval sequence_type {
proc is_Fe {code} { proc is_Fe {code} {
@ -773,14 +820,35 @@ namespace eval punk::ansi::ta {
#OSC - termnate with BEL (\a \007) or ST (string terminator \033\\) #OSC - termnate with BEL (\a \007) or ST (string terminator \033\\)
# 8-byte string terminator is \x9c (\u009c) # 8-byte string terminator is \x9c (\u009c)
#test - non-greedy #non-greedy via "*?" doesn't seem to work like this..
variable re_esc_osc1 {(?:\033\]).*?\007} #variable re_esc_osc1 {(?:\033\]).*?\007}
variable re_esc_osc2 {(?:\033\]).*?\033\\} #variable re_esc_osc2 {(?:\033\]).*?\033\\}
variable re_esc_osc3 {(?:\u009d).*?\u009c} #variable re_esc_osc3 {(?:\u009d).*?\u009c}
#non-greedy by excluding ST terminators
#TODO - FIX? see re_ST below
variable re_esc_osc1 {(?:\033\])(?:[^\007]*)\007}
variable re_esc_osc2 {(?:\033\])(?:[^\033]*)\033\\}
variable re_esc_osc3 {(?:\u009d)(?:[^\u009c]*)?\u009c}
variable re_osc_open {(?:\033\]|\u009d).*} variable re_osc_open {(?:\033\]|\u009d).*}
variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}" #standalone_codes [list \x1bc "" \x1b7 "" \x1b8 "" \x1bM "" \x1bE "" \x1bD "" \x1bH "" \x1b= "" \x1b> "" \x1b#3 "" \x1b#4 "" \x1b#5 "" \x1b#5 "" \x1b#6 "" \x1b#8 ""]
variable re_standalones {(?:\x1bc|\x1b7|\x1b8|\x1bM|\x1bE|\x1bD|\x1bD|\x1bH|\x1b=|\x1b>|\x1b#3|\x1b#4|\x1b#5|\x1b#6|\x1b#8)}
#see stripansi
set re_start_ST {^(?:\033X|\u0098|\033\^|\u009e|\033_|\u009f)}
#ST terminators [list \007 \033\\ \u009c]
#regex to capture the start of string/privacy message/application command block including the contents and string terminator (ST)
#non-greedy by exclusion of ST terminators in body
#!!!
#TODO - fix. we need to match \033\\ not just \033 ! could be colour codes nested in a privacy msg/string
#This will currently terminate the code too early in this case
#we also need to track the start of ST terminated code and not add it for replay (in the ansistring functions)
variable re_ST {(?:\033X|\u0098|\033\^|\u009E|\033_|\u009F)(?:[^\033\007\u009c]*)(?:\033\\|\007|\u009c)}
variable re_ansi_detect "${re_csi_open}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_start_ST}"
#detect any ansi escapes #detect any ansi escapes
#review - only detect 'complete' codes - or just use the opening escapes for performance? #review - only detect 'complete' codes - or just use the opening escapes for performance?
@ -851,7 +919,9 @@ namespace eval punk::ansi::ta {
variable re_esc_osc1 variable re_esc_osc1
variable re_esc_osc2 variable re_esc_osc2
variable re_csi_code variable re_csi_code
punk::ansi::internal::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" variable re_standalones
variable re_ST
punk::ansi::internal::splitx $text "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}|${re_standalones}|${re_ST}"
} }
# -- --- --- --- --- --- # -- --- --- --- --- ---
@ -871,7 +941,9 @@ namespace eval punk::ansi::ta {
variable re_esc_osc1 variable re_esc_osc1
variable re_esc_osc2 variable re_esc_osc2
variable re_csi_code variable re_csi_code
set re "(?:${re_csi_code}|${re_esc_osc1}|${re_esc_osc2})+" variable re_standalones
variable re_ST
set re "(?:${re_csi_code}|${re_standalones}|${re_ST}|${re_esc_osc1}|${re_esc_osc2})+"
return [_perlish_split $re $text] return [_perlish_split $re $text]
} }
#like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds) #like split_codes - but each ansi-escape is split out separately (with empty string of plaintext between codes so odd/even plain ansi still holds)
@ -879,7 +951,9 @@ namespace eval punk::ansi::ta {
variable re_esc_osc1 variable re_esc_osc1
variable re_esc_osc2 variable re_esc_osc2
variable re_csi_code variable re_csi_code
set re "${re_csi_code}|${re_esc_osc1}|${re_esc_osc2}" variable re_standalones
variable re_ST
set re "${re_csi_code}|${re_standalones}|${re_ST}|${re_esc_osc1}|${re_esc_osc2}"
return [_perlish_split $re $text] return [_perlish_split $re $text]
} }
@ -890,10 +964,26 @@ namespace eval punk::ansi::ta {
} }
set list [list] set list [list]
set start 0 set start 0
#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]} { while {[regexp -start $start -indices -- $re $text match]} {
lassign $match matchStart matchEnd lassign $match matchStart matchEnd
#puts "->start $start ->match $matchStart $matchEnd"
if {$matchEnd < $matchStart} {
lappend list [string range $text $start $matchStart-1] [string index $text $matchStart]
incr start
if {$start >= [string length $text]} {
break
}
continue
}
lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd] lappend list [string range $text $start $matchStart-1] [string range $text $matchStart $matchEnd]
set start [expr {$matchEnd+1}] set start [expr {$matchEnd+1}]
#?
if {$start >= [string length $text]} {
break
}
} }
lappend list [string range $text $start end] lappend list [string range $text $start end]
return $list return $list
@ -911,19 +1001,264 @@ namespace eval punk::ansi::ta {
namespace eval punk::ansi::ansistring { namespace eval punk::ansi::ansistring {
#*** !doctools #*** !doctools
#[subsection {Namespace punk::ansi::ansistring}] #[subsection {Namespace punk::ansi::ansistring}]
#[para]punk::ansi::string ensemble #[para]punk::ansi::ansistring ensemble - ansi-aware string operations
#[para]Working with strings containing ansi in a way that preserves/understands the codes is always going to be significantly slower than working with plain strings
#[para]Just as working with other forms of markup such as HTML - you simply need to be aware of the tradeoffs and design accordingly.
#[list_begin definitions] #[list_begin definitions]
namespace path [list ::punk::ansi ::punk::ansi::ta] namespace path [list ::punk::ansi ::punk::ansi::ta]
namespace ensemble create namespace ensemble create
namespace export length namespace export length trim trimleft trimright index VIEW
#todo - expose _splits_ methods so caller can work efficiently with the splits themselves
#we need to consider whether these can be agnostic towards splits from split_codes vs split_codes_single
#\UFFFD - replacement char or \U2426
#using ISO 2047 graphical representations of control characters
#00 NUL Null ⎕ U+2395 NU
#01 TC1, SOH Start of Heading ⌈ U+2308 SH
#02 TC2, STX Start of Text ⊥ U+22A5 SX
#03 TC3, ETX End of Text ⌋ U+230B EX
#04 TC4, EOT End of Transmission ⌁ U+2301[9] ET
#05 TC5, ENQ Enquiry ⊠[a] U+22A0 EQ
#06 TC6, ACK Acknowledge ✓ U+2713 AK
#07 BEL Bell ⍾ U+237E[9] BL
#08 FE0, BS Backspace ⤺ —[b] BS
#09 FE1, HT Horizontal Tabulation ⪫ U+2AAB HT
#0A FE2, LF Line Feed ≡ U+2261 LF
#0B FE3, VT Vertical Tabulation ⩛ U+2A5B VT
#0C FE4, FF Form Feed ↡ U+21A1 FF
#0D FE5, CR Carriage Return ⪪ U+2AAA CR
#0E SO Shift Out ⊗ U+2297 SO
#0F SI Shift In ⊙ U+2299 SI
#10 TC7, DLE Data Link Escape ⊟ U+229F DL
#11 DC1, XON, CON[10] Device Control 1 ◷ U+25F7 D1
#12 DC2, RPT,[10] TAPE[c] Device Control 2 ◶ U+25F6 D2
#13 DC3, XOF, XOFF Device Control 3 ◵ U+25F5 D3
#14 DC4, COF, KMC,[10] TAPE[c] Device Control 4 ◴ U+25F4 D4
#15 TC8, NAK Negative Acknowledge ⍻ U+237B[9] NK
#16 TC9, SYN Synchronization ⎍ U+238D SY
#17 TC10, ETB End of Transmission Block ⊣ U+22A3 EB
#18 CAN Cancel ⧖ U+29D6 CN
#19 EM End of Medium ⍿ U+237F[9] EM
#1A SUB Substitute Character ␦ U+2426[12] SB
#1B ESC Escape ⊖ U+2296 EC
#1C IS4, FS File Separator ◰ U+25F0 FS
#1D IS3, GS Group Separator ◱ U+25F1 GS
#1E IS2, RS Record Separator ◲ U+25F2 RS
#1F IS1 US Unit Separator ◳ U+25F3 US
#20 SP Space △ U+25B3 SP
#7F DEL Delete ▨ —[d] DT
proc VIEW {string} {
return [string map [list \033 \U2296 \007 \U237E] $string]
}
proc length {string} { proc length {string} {
string length [ansistrip $string] #*** !doctools
#[call [fun length] [arg string]]
#[para]Returns the length of the string without ansi codes
#[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 equivalent to calling string length on the result of stripansi $string
#[para]Note that this returns the number of characters in the payload, and is not always the same as the width of the string as rendered on a terminal.
#[para]To get the width, use punk::ansi::printing_length instead, which is also ansi aware.
string length [stripansi $string]
} }
proc trimleft {string args} { proc trimleft {string args} {
set intext 0
set out ""
#for split_codes only first or last pt can be empty string
foreach {pt ansiblock} [split_codes $string] {
if {!$intext} {
if {$pt eq "" || [regexp {^\s+$} $pt]} {
append out $ansiblock
} else {
append out [string trimleft $pt]$ansiblock
set intext 1
}
} else {
append out $pt$ansiblock
}
}
return $out
}
proc trimright {string} {
if {$string eq ""} {return ""} ;#excludes the case where split_codes would return nothing
set rtrimmed_list [lreverse [_splits_trimleft [lreverse [split_codes $string]]]]
return [join $rtrimmed_list ""]
}
proc trim {string} {
#make sure we do our ansi-scanning split only once - so use list-based trim operations
#order of left vs right probably makes zero difference - as any reduction the first operation can do is only in terms of characters at other end of list - not in total list length
#we save a single function call by calling both here rather than _splits_trim
join [_splits_trimright [_splits_trimleft [split_codes $string]]] ""
}
proc index {string index} {
#*** !doctools
#[call [fun index] [arg string] [arg index]]
#[para]Takes a string that possibly contains ansi codes such as colour,underline etc (SGR codes)
#[para]Returns the character (with applied ansi effect) at position index
#[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]todo: SGR codes within ST-terminated strings not yet ignored properly
#[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-+<int> 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]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.
#[para]This shouldn't make any difference to the visual output - but a possible future enhancement is something to produce the shortest ansi sequence possible
#[para]Notes:
#[para]This function has to split the whole string into plaintext & ansi codes even for a very low index
#[para]Some sort of generator that parses more of the string as required might be more efficient for large chunks.
#[para]For end-x operations we have to pre-calculate the content-length by stripping the ansi - which is also potentially sub-optimal
set splits [split_codes_single $string]; #we get empty pt(plaintext) between each ansi code that is in a run
#todo - end-x +/-x+/-x etc
set original_index $index
set index [string map [list _ ""] $index]
#short-circuit some trivial cases
if {[string is integer -strict $index]} {
if {$index < 0} {return ""}
#this only short-circuits an index greater than length including ansi-chars
#we don't want to spend cycles stripping ansi for this test so code below will still have to handle index just larger than content-length but still less than entire length
if {$index > [string length $string]} {return ""}
} else {
if {[string match end* $index]} {
#for end- we will probably have to blow a few cycles stripping first and calculate the length
if {$index ne "end"} {
set op [string index $index 3]
set offset [string range $index 4 end]
if {$op ni {+ -} || ![string is integer -strict $offset]} {error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"}
if {$op eq "+" && $offset != 0} {
return ""
}
} else {
set offset 0
}
#by now, if op = + then offset = 0 so we only need to handle the minus case
set payload_len [punk::ansi::ansistring::length $string] ;#a little bit wasteful - but hopefully no big deal
if {$offset == 0} {
set index [expr {$payload_len-1}]
} else {
set index [expr {($payload_len-1) - $offset}]
}
if {$index < 0} {
#don't waste time splitting and looping the string
return ""
}
} else {
#we are trying to avoid evaluating unbraced expr of potentially insecure origin
regexp {^([+-]{0,1})(.*)} $index _match sign tail ;#should always match - even empty string
if {[string is integer -strict $tail]} {
#plain +-<int>
if {$op eq "-"} {
#return nothing for negative indices as per Tcl's lindex etc
return ""
}
set index $tail
} else {
if {[regexp {(.*)([+-])(.*)} $index _match a op b]} {
if {[string is integer -strict $a] && [string is integer -strict $b]} {
if {$op eq "-"} {
set index [expr {$a - $b}]
} else {
set index [expr {$a + $b}]
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
}
} else {
error "bad index '$index': must be integer?\[+-\]integer? or end?\[+-\]integer?"
}
}
}
}
#any pt could be empty if using split_codes_single (or just first and last pt if split_codes)
set low -1
set high -1
set pt_index -2
set pt_found -1
set char ""
set codes_in_effect ""
#we can't only apply leading sequence from previous code - as there may be codes in effect from earlier, so we have to track as we go
#(this would apply even if we used split_codes - but then we would need to do further splitting of each codeset anyway)
foreach {pt code} $splits {
incr pt_index 2
if {$pt ne ""} {
set low [expr {$high + 1}] ;#last high
incr high [string length $pt]
}
if {$pt ne "" && ($index >= $low && $index <= $high)} {
set pt_found $pt_index
set char [string index $pt $index-$low]
break
}
if {[punk::ansi::codetype::is_sgr_reset $code]} {
#we can throw away previous codes_in_effect
set codes_in_effect ""
} else {
#may have partial resets - but we don't want to track individual states of SGR features
#A possible feature would be some function to optimise an ansi code sequence - which we could then apply at the end.
#we don't apply non SGR codes to our output. This is probably what is wanted - but should be reviewed.
#Review - consider if any other types of code make sense to retain in the output in this context.
if {[punk::ansi::codetype::is_sgr $code]} {
append codes_in_effect $code
}
}
}
if {$pt_found >= 0} {
return $codes_in_effect$char
} else {
return ""
}
} }
proc _splits_trimleft {sclist} {
set intext 0
set outlist [list]
foreach {pt ansiblock} $sclist {
if {!$intext} {
if {$pt eq "" || [regexp {^\s+$} $pt]} {
lappend outlist "" $ansiblock
} else {
lappend outlist [string trimleft $pt] $ansiblock
set intext 1
}
} else {
lappend outlist $pt $ansiblock
}
}
return $outlist
}
proc _splits_trimright {sclist} {
set intext 0
set outlist [list]
foreach {pt ansiblock} [lreverse $sclist] {
if {!$intext} {
if {$pt eq "" || [regexp {^\s+$} $pt]} {
lappend outlist "" $ansiblock
} else {
lappend outlist [string trimright $pt] $ansiblock
set intext 1
}
} else {
lappend outlist $pt $ansiblock
}
}
return [lreverse $outlist]
}
proc _splits_trim {sclist} {
return [_splits_trimright [_splits_trimleft $sclist]]
}
#*** !doctools #*** !doctools
#[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}] #[list_end] [comment {--- end definitions namespace punk::ansi::ta ---}]

8
src/bootsupport/modules/punk/console-0.1.0.tm

@ -441,7 +441,13 @@ namespace eval punk::console {
if {!$emit} { if {!$emit} {
puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1 puts -nonewline stdout \033\[2K\033\[1G ;#2K erase line 1G cursor at col1
} }
lassign [split [punk::console::get_cursor_pos] ";"] _row1 col1 if {[catch {
lassign [split [punk::console::get_cursor_pos] ";"] _row1 col1
} errM]} {
puts stderr "Cannot test_char_width - may be no console? Error message from get_cursor_pos: $errM"
return
}
puts -nonewline stdout $char_or_string puts -nonewline stdout $char_or_string
lassign [split [punk::console::get_cursor_pos] ";"] _row2 col2 lassign [split [punk::console::get_cursor_pos] ";"] _row2 col2
if {!$emit} { if {!$emit} {

696
src/bootsupport/modules/punk/lib-0.1.0.tm

@ -514,6 +514,702 @@ namespace eval punk::lib {
return $answer return $answer
} }
#e.g linesort -decreasing $data
proc linesort {args} {
#*** !doctools
#[call [fun linesort] [opt {sortoption ?val?...}] [arg textblock]]
#[para]Sort lines in textblock
#[para]Returns another textblock with lines sorted
#[para]options are flags as accepted by lsort ie -ascii -command -decreasing -dictionary -index -indices -integer -nocase -real -stride -unique
if {[llength $args] < 1} {
error "linesort missing lines argument"
}
set lines [lindex $args end]
set opts [lrange $args 0 end-1]
#.= list $lines |@0,sortopts/1> linelist |> .=data>1,sortopts>1* lsort |> list_as_lines <| {*}$opts
list_as_lines [lsort {*}$opts [linelist $lines]]
}
proc list_as_lines {args} {
#*** !doctools
#[call [fun list_as_lines] [opt {-joinchar char}] [arg linelist]]
#[para]This simply joines the elements of the list with -joinchar
#[para]It is mainly intended for use in pipelines where the primary argument comes at the end - but it can also be used as a general replacement for join $lines <le>
#[para]The sister function lines_as_list takes a block of text and splits it into lines - but with more options related to trimming the block and/or each line.
if {[set eop [lsearch $args --]] == [llength $args]-2} {
#end-of-opts not really necessary - except for consistency with lines_as_list
set args [concat [lrange $args 0 $eop-1] [lrange $args $eop+1 end]]
}
if {[llength $args] == 3 && [lindex $args 0] eq "-joinchar"} {
set joinchar [lindex $args 1]
set lines [lindex $args 2]
} elseif {[llength $args] == 1} {
set joinchar "\n"
set lines [lindex $args 0]
} else {
error "list_as_lines usage: list_as_lines ?-joinchar <char>? <linelist>"
}
return [join $lines $joinchar]
}
proc list_as_lines2 {args} {
#eat or own dogfood version - shows the implementation is simpler - but unfortunately not suitable for a simple function like this which should be as fast as possible
lassign [dict values [punk::lib::opts_values -minvalues 1 -maxvalues 1 {
-joinchar -default \n
} $args]] opts values
return [join [dict get $values 0] [dict get $opts -joinchar]]
}
proc lines_as_list {args} {
#The underlying function linelist has the validation code which gives nice usage errors.
#we can't use a dict merge here without either duplicating the underlying validation somewhat, or risking a default message from dict merge error
#..because we don't know what to say if there are odd numbers of args
#we can guess that it's ok to insert our default if no -block found in $args - but as a general principle this mightn't always work
#e.g if -block is also a valid value for the textblock itself. Which in this case it is - although unlikely, and our -block {} default is irrelevant in that case anyway
if {[lsearch $args "--"] == [llength $args]-2} {
set opts [lrange $args 0 end-2]
} else {
set opts [lrange $args 0 end-1]
}
#set opts [dict merge {-block {}} $opts]
set bposn [lsearch $opts -block]
if {$bposn < 0} {
set opts {-block {}}
}
set text [lindex $args end]
tailcall linelist {*}$opts $text
}
#this demonstrates the ease of using an args processor - but as lines_as_list is heavily used in terminal output - we can't afford the extra microseconds
proc lines_as_list2 {args} {
#pass -anyopts 1 so we can let the next function decide what arguments are valid - but still pass our defaults
#-anyopts 1 avoids having to know what to say if odd numbers of options passed etc
#we don't have to decide what is an opt vs a value
#even if the caller provides the argument -block without a value the next function's validation will report a reasonable error because there is now nothing in $values (consumed by -block)
lassign [dict values [punk::lib::opts_values -anyopts 1 {
-block -default {}
} $args]] opts valuedict
tailcall linelist {*}$opts {*}[dict values $valuedict]
}
# important for pipeline & match_assign
# -line trimline|trimleft|trimright -block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty -commandprefix {string length} ?
# -block trimming only trims completely empty lines. use -line trimming to remove whitespace e.g -line trimright will clear empty lines without affecting leading whitespace on other lines that aren't pure whitespace
proc linelist {args} {
#puts "---->linelist '$args'"
set usage "linelist ?-line trimline|trimleft|trimright? ?-block trimhead|trimtail|triminner|trimall|trimhead1|trimtail1|collateempty? -commandprefix <cmdlist> text"
if {[llength $args] == 0} {
error "linelist missing textchunk argument usage:$usage"
}
set text [lindex $args end]
set arglist [lrange $args 0 end-1]
set defaults [dict create\
-block {trimhead1 trimtail1}\
-line {}\
-commandprefix ""\
-ansiresets 1\
]
dict for {o v} $arglist {
if {$o ni {-block -line -commandprefix -ansiresets}} {
error "linelist: Unrecognized option '$o' usage:$usage"
}
}
set opts [dict merge $defaults $arglist]
# -- --- --- --- --- ---
set opt_block [dict get $opts -block]
set known_blockopts [list trimhead trimtail triminner trimall trimhead1 trimtail1 collateempty]
foreach bo $opt_block {
if {$bo ni $known_blockopts} {
error "linelist: unknown -block option value: $bo known values: $known_blockopts"
}
}
#normalize certain combos
if {[set posn [lsearch $opt_block trimhead1]] >=0 && "trimhead" in $opt_block} {
set opt_block [lreplace $opt_block $posn $posn]
}
if {[set posn [lsearch $opt_block trimtail1]] >=0 && "trimtail" in $opt_block} {
set opt_block [lreplace $opt_block $posn $posn]
}
if {"trimall" in $opt_block} {
#no other block options make sense in combination with this
set opt_block [list "trimall"]
}
#TODO
if {"triminner" in $opt_block } {
error "linelist -block triminner not implemented - sorry"
}
# -- --- --- --- --- ---
set opt_line [dict get $opts -line]
set known_lineopts [list trimline trimleft trimright]
foreach lo $opt_line {
if {$lo ni $known_lineopts} {
error "linelist: unknown -line option value: $lo known values: $known_lineopts"
}
}
#normalize trimleft trimright combo
if {"trimleft" in $opt_line && "trimright" in $opt_line} {
set opt_line [list "trimline"]
}
# -- --- --- --- --- ---
set opt_commandprefix [dict get $opts -commandprefix]
# -- --- --- --- --- ---
set linelist [list]
set nlsplit [split $text \n]
if {![llength $opt_line]} {
set linelist $nlsplit
#lappend linelist {*}$nlsplit
} else {
foreach ln $nlsplit {
#already normalized trimleft+trimright to trimline
if {"trimline" in $opt_line} {
lappend linelist [string trim $ln]
} elseif {"trimleft" in $opt_line} {
lappend linelist [string trimleft $ln]
} elseif {"trimright" in $opt_line} {
lappend linelist [string trimright $ln]
}
}
}
if {"collateempty" in $opt_block} {
set inputlist $linelist[set linelist [list]]
set last "-"
foreach input $inputlist {
if {$input ne ""} {
lappend linelist $input
set last "-"
} else {
if {$last ne ""} {
lappend linelist ""
}
set last ""
}
}
}
if {"trimall" in $opt_block} {
set linelist [lsearch -all -inline -not -exact $linelist[set linelist {}] ""]
} else {
set start 0
if {"trimhead" in $opt_block} {
set idx 0
set lastempty -1
foreach ln $linelist {
if {[lindex $linelist $idx] ne ""} {
break
} else {
set lastempty $idx
}
incr idx
}
if {$lastempty >=0} {
set start [expr {$lastempty +1}]
}
}
set linelist [lrange $linelist $start end]
if {"trimtail" in $opt_block} {
set revlinelist [lreverse $linelist][set linelist {}]
set i 0
foreach ln $revlinelist {
if {$ln ne ""} {
set linelist [lreverse [lrange $revlinelist $i end]]
break
}
incr i
}
}
# --- ---
set start 0
set end "end"
if {"trimhead1" in $opt_block} {
if {[lindex $linelist 0] eq ""} {
set start 1
}
}
if {"trimtail1" in $opt_block} {
if {[lindex $linelist end] eq ""} {
set end "end-1"
}
}
set linelist [lrange $linelist $start $end]
}
if {[llength $opt_commandprefix]} {
set transformed [list]
foreach ln $linelist {
lappend transformed [{*}$opt_commandprefix $ln]
}
set linelist $transformed
}
return $linelist
}
#maintenance - take over from punk::args - or put back in punk::args once fixed to support pipeline argument order
#possible improvements - after the 1st call, replace the callsite in the calling proc with an inline script to process and validate the arguments as specified in optionspecs
#This would require a tcl parser .. and probably lots of other work
#It would also probably only be practical if there are no dynamic entries in the optionspecs. An option for opts_values to indicate the caller wants this optimisation would probably be best.
#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
#If an option is supplied multiple times - only the last value is used.
proc opts_values {args} {
#*** !doctools
#[call [fun opts_values] [opt {option value...}] [arg optionspecs] [arg rawargs] ]
#[para]Parse rawargs as a sequence of zero or more option-value pairs followed by zero or more values
#[para]Returns a dict of the form: opts <options_dict> values <values_dict>
#[para]ARGUMENTS:
#[list_begin arguments]
#[arg_def multiline-string optionspecs]
#[para] This a block of text with records delimited by newlines (lf or crlf) - but with multiline values allowed if properly quoted/braced
#[para]'info complete' is used to determine if a record spans multiple lines due to multiline values
#[para]Each optionspec line must be of the form:
#[para]-optionname -key val -key2 val2...
#[para]where the valid keys for each option specification are: -default -type -range -choices -optional
#[arg_def list rawargs]
#[para] This is a list of the arguments to parse. Usually it will be the \$args value from the containing proc
#[list_end]
#[para]
#consider line-processing example below for we need info complete to determine record boundaries
#punk::lib::opt_values {
# -opt1 -default {}
# -opt2 -default {
# etc
# } -multiple 1
#} $args
#-- cannot be used to allow opts_values itself to accept rawargs as separate values - so it doesn't serve much purpose other than as an indicator of intention
#For consistency we support it anyway.
#we have to be careful with end-of-options flag --
#It may legitimately be the only value in the rawargs list (which is a bit odd - but possible) or it may occur immediately before optionspecs and rawargs
#if there is more than one entry in rawargs - we won't find it anyway - so that's ok
set eopts_posn [lsearch $args --]
if {$eopts_posn == ([llength $args]-1)} {
#sole argument in rawargs - not the one we're looking for
set eopts_posn -1
}
if {$eopts_posn >= 0} {
set ov_opts [lrange $args 0 $eopts_posn-1]
set ov_vals [lrange $args $eopts_posn+1 end]
} else {
set ov_opts [lrange $args 0 end-2]
set ov_vals [lrange $args end-1 end]
}
if {[llength $ov_vals] < 2 || [llength $ov_opts] %2 != 0} {
error "opts_args wrong # args: should be opts_values ?opt val?... optionspecs rawargs_as_list
}
set optionspecs [lindex $ov_vals 0]
set optionspecs [string map [list \r\n \n] $optionspecs]
set rawargs [lindex $ov_vals 1]
set known_argspecs [list -default -type -range -choices -nocase -optional -multiple -validate_without_ansi -allow_ansi -strip_ansi -ARGTYPE]
set optspec_defaults [dict create\
-optional 1\
-allow_ansi 1\
-validate_without_ansi 0\
-strip_ansi 0\
-nocase 0\
]
set required_opts [list]
set required_vals [list]
set arg_info [dict create]
set defaults_dict_opts [dict create]
set defaults_dict_values [dict create]
#first process dashed and non-dashed argspecs without regard to whether non-dashed are at the beginning or end
set value_names [list]
set records [list]
set linebuild ""
foreach rawline [split $optionspecs \n] {
set recordsofar [string cat $linebuild $rawline]
if {![info complete $recordsofar]} {
append linebuild [string trimleft $rawline] \n
} else {
lappend records [string cat $linebuild $rawline]
set linebuild ""
}
}
foreach ln $records {
set trimln [string trim $ln]
if {$trimln eq "" || [string index $trimln 0] eq "#"} {
continue
}
set argname [lindex $trimln 0]
set argspecs [lrange $trimln 1 end]
if {[llength $argspecs] %2 != 0} {
error "punk::lib::opts_values - bad optionspecs line for argument '$argname' Remaining items on line must be in paired option-value format - received '$argspecs'"
}
if {[string match -* $argname]} {
dict set argspecs -ARGTYPE option
set is_opt 1
} else {
dict set argspecs -ARGTYPE value
lappend value_names $argname
set is_opt 0
}
dict for {spec specval} $argspecs {
if {$spec ni $known_argspecs} {
error "punk::lib::opts_values - unrecognised key '$spec' in specifications for argument '$argname' Known option specification keys: $known_argspecs"
}
}
set argspecs [dict merge $optspec_defaults $argspecs]
dict set arg_info $argname $argspecs
if {![dict get $argspecs -optional]} {
if {$is_opt} {
lappend required_opts $argname
} else {
lappend required_vals $argname
}
}
if {[dict exists $arg_info $argname -default]} {
if {$is_opt} {
dict set defaults_dict_opts $argname [dict get $arg_info $argname -default]
} else {
dict set defaults_dict_values $argname [dict get $arg_info $argname -default]
}
}
}
#puts "--> [info frame -2] <--"
set cmdinfo [dict get [info frame -2] cmd]
#we can't treat cmdinfo as a list - it may be something like {command {*}$args} in which case lindex $cmdinfo 0 won't work
#hopefully first word is a plain proc name if this function was called in the normal manner - directly from a proc
#we will break at first space and assume the lhs of that will give enough info to be reasonable - (alternatively we could use entire cmdinfo - but it might be big and ugly)
set caller [regexp -inline {\S+} $cmdinfo]
#if called from commandline or some other contexts such as outside of a proc in a namespace - caller may just be "namespace"
if {$caller eq "namespace"} {
set caller "punk::lib::opts_values called from namespace"
}
# ------------------------------
if {$caller ne "punk::lib::opts_values"} {
#1) check our caller's call to us - recursive version - perhaps more elegant to eat our own dogfood - but maybe too much overhead for a script-based args processor which is already quite heavy :/
#lassign [punk::lib::opts_values "-anyopts -default 0 -type integer\n -minvalues -default 0 -type integer\n -maxvalues -default -1 -type integer" $args] _o ownopts _v ownvalues
#if {[dict size $ownvalues] != 2} {
# error "punk::lib::opts_values expected: a multiline text block of option-specifications, a list of args and at most three option pairs -minvalues <int>, -maxvalues <int>, -anyopts true|false - got extra arguments: '$ownvalues'"
#}
#set opt_minvalues [dict get $ownopts -minvalues]
#set opt_maxvalues [dict get $ownopts -maxvalues]
#set opt_anyopts [dict get $ownopts -anyopts]
#2) Quick and dirty - but we don't need much validation
set defaults [dict create\
-minvalues 0\
-maxvalues -1\
-anyopts 0\
]
dict for {k v} $ov_opts {
if {$k ni {-minvalues -maxvalues -anyopts}} {
error "punk::lib::opts_values unrecognised option $k. Known values [dict keys $defaults]"
}
if {![string is integer -strict $v]} {
error "punk::lib::opts_values argument $k must be of type integer"
}
}
set ov_opts [dict merge $defaults $ov_opts]
set opt_minvalues [dict get $ov_opts -minvalues]
set opt_maxvalues [dict get $ov_opts -maxvalues]
set opt_anyopts [dict get $ov_opts -anyopts]
} else {
#don't recurse ie don't check our own args if we called ourself
set opt_minvalues 2
set opt_maxvalues 2
set opt_anyopts 0
}
# ------------------------------
if {[set eopts [lsearch $rawargs "--"]] >= 0} {
set values [lrange $rawargs $eopts+1 end]
set arglist [lrange $rawargs 0 $eopts-1]
} else {
if {[lsearch $rawargs -*] >= 0} {
#to support option values with leading dash e.g -offset -1 , we can't just take the last flagindex
set i 0
foreach {k v} $rawargs {
if {![string match -* $k]} {
break
}
if {$i+1 >= [llength $rawargs]} {
#no value for last flag
error "bad options for $caller. No value supplied for last option $k"
}
incr i 2
}
set arglist [lrange $rawargs 0 $i-1]
set values [lrange $rawargs $i end]
} else {
set arglist [list]
set values $rawargs ;#no -flags detected
}
}
#confirm any valnames before last don't have -multiple key
foreach valname [lrange $value_names 0 end-1] {
if {[dict exists $arg_info $valname -multiple ]} {
error "bad key -multiple on argument spec for '$valname'. Only the last value argument specification can be marked -multiple"
}
}
set values_dict [dict create]
set validx 0
set in_multiple ""
foreach valname $value_names val $values {
if {$validx+1 > [llength $values]} {
break
}
if {$valname ne ""} {
if {[dict exists $arg_info $valname -multiple] && [dict get $arg_info $valname -multiple]} {
dict lappend values_dict $valname $val
set in_multiple $valname
} else {
dict set values_dict $valname $val
}
} else {
if {$in_multiple ne ""} {
dict lappend values_dict $in_multiple $val
} else {
dict set values_dict $validx $val
}
}
incr validx
}
if {$opt_maxvalues == -1} {
#only check min
if {[llength $values] < $opt_minvalues} {
error "bad number of trailing values for $caller. Got [llength $values] values. Expected at least $opt_minvalues"
}
} else {
if {[llength $values] < $opt_minvalues || [llength $values] > $opt_maxvalues} {
if {$opt_minvalues == $opt_maxvalues} {
error "bad number of trailing values for $caller. Got [llength $values] values. Expected exactly $opt_minvalues"
} else {
error "bad number of trailing values for $caller. Got [llength $values] values. Expected between $opt_minvalues and $opt_maxvalues inclusive"
}
}
}
#opts explicitly marked as -optional 0 must be present - regardless of -anyopts (which allows us to ignore additional opts to pass on to next call)
#however - if -anyopts is true, there is a risk we will treat a shortened option name as matching our default - when it was intended for the next call
#We will always require exact matches for all required opts to avoid this risk, even though an ultimately-called function may not require the full-length option-name REVIEW
#The aim is to allow a wrapper function to specify a default value for an option (and/or other changes/restrictions to a particular option or two) - without having to re-specify all the options for the underlying function.
#without full respecification in the wrapper - we can't know that a supplied prefix is unambiguous at the next level
#For this reason we need to pass on full-length opts for any defined options in the wrapper even if anyopts is true
set argnamespresent [dict keys $arglist]
foreach r $required_opts {
if {$r ni $argspresent} {
error "Required option missing for $caller. '$r' is marked with -optional false - so must be present in its full-length form"
}
}
set valuenamespresent [dict keys $values_dict]
foreach r $required_vals {
if {$r ni $valuenamespresent} {
error "Required value missing for $caller. '$r' is marked with -optional false - so must be present"
}
}
if {!$opt_anyopts} {
set checked_args [dict create]
for {set i 0} {$i < [llength $arglist]} {incr i} {
#allow this to error out with message indicating expected flags
set val [lindex $arglist $i+1]
set fullopt [tcl::prefix match -message "options for $caller. Unexpected option" [dict keys $arg_info] [lindex $arglist $i]]
if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} {
dict lappend checked_args $fullopt $val
} else {
dict set checked_args $fullopt $val
}
incr i ;#skip val
}
} else {
#still need to use tcl::prefix match to normalize - but don't raise an error
set checked_args [dict create]
dict for {k v} $arglist {
if {![catch {tcl::prefix::match [dict keys $arg_info] $k} fullopt]} {
if {[dict exists $arg_info $fullopt -multiple] && [dict get $arg_info $fullopt -multiple]} {
dict lappend checked_args $fullopt $v
} else {
dict set checked_args $fullopt $v
}
} else {
#opt was unspecified
dict set checked_args $k $v
}
}
}
set opts [dict merge $defaults_dict_opts $checked_args]
#assert - checked_args keys are full-length option names if -anyopts was false or if the supplied option as a shortname matched one of our defined options
set values [dict merge $defaults_dict_values $values_dict]
#todo - allow defaults outside of choices/ranges
#check types,ranges,choices
set opts_and_values [concat $opts $values]
set combined_defaults [concat $defaults_dict_values $defaults_dict_opts] ;#can be no key collisions - we don't allow a value key beginning with dash - opt names must begin with dash
dict for {o v} $opts_and_values {
if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} {
set vlist $v
} else {
set vlist [list $v]
}
if {[dict exists $arg_info $o -validate_without_ansi] && [dict get $arg_info $o -validate_without_ansi]} {
set validate_without_ansi 1
package require punk::ansi
} else {
set validate_without_ansi 0
}
if {[dict exists $arg_info $o -allow_ansi] && [dict get $arg_info $o -allow_ansi]} {
set allow_ansi 1
} else {
#ironically - we need punk::ansi to detect and disallow - but we don't need it if ansi is allowed
package require punk::ansi
set allow_ansi 0
}
if {!$allow_ansi} {
foreach e $vlist {
if {[punk::ansi::ta::detect $e]} {
error "Option $o for $caller contains ansi - but -allow_ansi is false. Received: '$e'"
}
}
}
set vlist_check [list]
foreach e $vlist {
if {$validate_without_ansi} {
lappend vlist_check [punk::ansi::stripansi $e]
} else {
lappend vlist_check $e
}
}
set is_default 0
foreach e $vlist e_check $vlist_check {
if {[dict exists $combined_defaults $o] && ($e_check eq [dict get $combined_defaults $o])} {
incr is_default
}
}
if {$is_default eq [llength $vlist]} {
set is_default true
}
#we want defaults to pass through - even if they don't pass the checks that would be required for a specified value
#If the caller manually specified a value that happens to match the default - we don't detect that as any different from an unspecified value - Review.
if {!$is_default} {
if {[dict exists $arg_info $o -type]} {
set type [dict get $arg_info $o -type]
if {[string tolower $type] in {int integer double}} {
if {[string tolower $type] in {int integer}} {
foreach e $vlist e_check $vlist_check {
if {![string is integer -strict $e_check]} {
error "Option $o for $caller requires type 'integer'. Received: '$e'"
}
}
} elseif {[string tolower $type] in {double}} {
foreach e $vlist e_check $vlist_check {
if {![string is double -strict $e_check]} {
error "Option $o for $caller requires type 'double'. Received: '$e'"
}
}
}
#todo - small-value double comparisons with error-margin? review
if {[dict exists $arg_info $o -range]} {
lassign [dict get $arg_info $o -range] low high
foreach e $vlist e_check $vlist_check {
if {$e_check < $low || $e_check > $high} {
error "Option $o for $caller must be between $low and $high. Received: '$e'"
}
}
}
} elseif {[string tolower $type] in {bool boolean}} {
foreach e $vlist e_check $vlist_check {
if {![string is boolean -strict $e_check]} {
error "Option $o for $caller requires type 'boolean'. Received: '$e'"
}
}
} elseif {[string tolower $type] in {alnum alpha ascii control digit graph lower print punct space upper wordchar xdigit}} {
foreach e $vlist e_check $vlist_check {
if {![string is [string tolower $type] $e_check]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e'"
}
}
} elseif {[string tolower $type] in {file directory existingfile existingdirectory}} {
foreach e $vlist e_check $vlist_check {
if {!([string length $e_check]>0 && ![regexp {[\"*?<>\;]} $e_check])} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which doesn't look like it could be a file or directory"
}
}
if {[string tolower $type] in {existingfile}} {
foreach e $vlist e_check $vlist_check {
if {![file exists $e_check]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing file"
}
}
} elseif {[string tolower $type] in {existingdirectory}} {
foreach e $vlist e_check $vlist_check {
if {![file isdirectory $e_check]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not an existing directory"
}
}
}
} elseif {[string tolower $type] in {char character}} {
foreach e $vlist e_check $vlist_check {
if {[string length != 1]} {
error "Option $o for $caller requires type '[string tolower $type]'. Received: '$e' which is not a single character"
}
}
}
}
if {[dict exists $arg_info $o -choices]} {
set choices [dict get $arg_info $o -choices]
set nocase [dict get $arg_info $o -nocase]
foreach e $vlist e_check $vlist_check {
if {$nocase} {
set casemsg "(case insensitive)"
set choices_test [string tolower $choices]
set v_test [string tolower $e_check]
} else {
set casemsg "(case sensitive)"
set v_test $e_check
set choices_test $choices
}
if {$v_test ni $choices_test} {
error "Option $o for $caller must be one of the listed values $choices $casemsg. Received: '$e'"
}
}
}
}
if {[dict exists $arg_info $o -strip_ansi] && [dict get $arg_info $o -strip_ansi]} {
set stripped_list [list]
foreach e $vlist {
lappend stripped_list [punk::ansi::stripansi $e]
}
if {[dict exists $arg_info $o -multiple] && [dict get $arg_info $o -multiple]} {
if {[dict get $arg_info $o -ARGTYPE] eq "option"} {
dict set opts $o $stripped_list
} else {
dict set values $o $stripped_list
}
} else {
if {[dict get $arg_info $o -ARGTYPE] eq "option"} {
dict set opts $o [lindex $stripped_list 0]
} else {
dict set values [lindex $stripped_list 0]
}
}
}
}
#maintain order of opts $opts values $values as caller may use lassign.
return [dict create opts $opts values $values]
}
#*** !doctools #*** !doctools
#[list_end] [comment {--- end definitions namespace punk::lib ---}] #[list_end] [comment {--- end definitions namespace punk::lib ---}]
} }

5
src/bootsupport/modules/punk/ns-0.1.0.tm

@ -17,6 +17,7 @@
# ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++
## Requirements ## Requirements
##e.g package require frobz ##e.g package require frobz
package require punk::lib
package require punk::args package require punk::args
namespace eval ::punk_dynamic::ns { namespace eval ::punk_dynamic::ns {
@ -972,8 +973,8 @@ namespace eval punk::ns {
#nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string. #nscommands returns exactly one line per entry + a trailing newline. If there is an empty line other than at the end - that is because there is a command named as the empty string.
# By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {} # By default 'linelist' trims 1st and last empty line. Turn off all block trimming with -block {}
#set commands [.= nscommands -raw [nsjoin $ch $glob] |> linelist -block {}] #set commands [.= nscommands -raw [nsjoin $ch $glob] |> punk::lib::linelist -block {}]
set commands [linelist -block {} [nscommands -raw [nsjoin $ch $glob]]] set commands [punk::lib::linelist -block {} [nscommands -raw [nsjoin $ch $glob]]]
#by convention - returning just \n represents a single result of the empty string whereas no results #by convention - returning just \n represents a single result of the empty string whereas no results
#after passing through linelist this becomes {} {} which appears as a list of two empty strings. #after passing through linelist this becomes {} {} which appears as a list of two empty strings.

0
src/modules/shellfilter-0.1.8.tm → src/modules/shellfilter-0.1.9.tm

0
src/modules/shellrun-0.1.tm → src/modules/shellrun-0.1.1.tm

0
src/modules/shellthread-1.6.tm → src/modules/shellthread-1.6.1.tm

Loading…
Cancel
Save